diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index e0786631cb6..1a7301d4903 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -76,11 +76,11 @@ jobs: check_arch: true - name: build_upstream_closure - config: --enable-middle-end=closure + config: --enable-middle-end=upstream-closure os: ubuntu-20.04 - name: build_upstream_closure_runtime5 - config: --enable-middle-end=closure --enable-runtime5 + config: --enable-middle-end=upstream-closure --enable-runtime5 os: ubuntu-20.04 expected_fail: true diff --git a/.github/workflows/ocamlformat.yml b/.github/workflows/ocamlformat.yml index d611a0f527d..6436fb783b9 100644 --- a/.github/workflows/ocamlformat.yml +++ b/.github/workflows/ocamlformat.yml @@ -40,7 +40,7 @@ jobs: run: | ./configure \ --prefix=$GITHUB_WORKSPACE/_install \ - --enable-middle-end=closure \ + --enable-middle-end=flambda2 \ --with-dune=/bin/false - name: Check formatting of Flambda 2 and Cfg code diff --git a/README.md b/README.md index c67985289af..50e01748a16 100644 --- a/README.md +++ b/README.md @@ -37,10 +37,8 @@ The Flambda backend tree has to be configured before building. The configure sc in; you have to run `autoconf`. For example: ``` $ autoconf -$ ./configure --prefix=/path/to/install/dir --enable-middle-end=closure +$ ./configure --prefix=/path/to/install/dir ``` -You can also specify `--enable-middle-end=flambda` or `--enable-middle-end=flambda2`. (The Flambda 2 -compiler is not yet ready for production use.) ## Building and installing diff --git a/backend/asmgen.ml b/backend/asmgen.ml index cd1ec912893..dbc8f9b86f4 100644 --- a/backend/asmgen.ml +++ b/backend/asmgen.ml @@ -471,14 +471,6 @@ let end_gen_implementation unix ?toplevel ~ppf_dump ~sourcefile make_cmm = !Translmod.primitive_declarations)); emit_end_assembly sourcefile () -type middle_end = - backend:(module Backend_intf.S) - -> filename:string - -> prefixname:string - -> ppf_dump:Format.formatter - -> Lambda.program - -> Clambda.with_constants - type direct_to_cmm = ppf_dump:Format.formatter -> prefixname:string @@ -487,10 +479,6 @@ type direct_to_cmm = -> Cmm.phrase list type pipeline = - | Via_clambda of { - backend : (module Backend_intf.S); - middle_end : middle_end; - } | Direct_to_cmm of direct_to_cmm let asm_filename output_prefix = @@ -508,12 +496,6 @@ let compile_implementation unix ?toplevel ~pipeline Compilation_unit.Set.iter Compilenv.require_global program.required_globals; match pipeline with - | Via_clambda { middle_end; backend; } -> - let clambda_with_constants = - middle_end ~backend ~filename ~prefixname ~ppf_dump program - in - end_gen_implementation unix ?toplevel ~ppf_dump ~sourcefile:filename - (fun () -> Profile.record "cmm" Cmmgen.compunit clambda_with_constants) | Direct_to_cmm direct_to_cmm -> let cmm_phrases = direct_to_cmm ~ppf_dump ~prefixname ~filename program diff --git a/backend/asmgen.mli b/backend/asmgen.mli index 8d56db6ecf1..4f24ed0f46d 100644 --- a/backend/asmgen.mli +++ b/backend/asmgen.mli @@ -15,15 +15,6 @@ (** From Lambda to assembly code *) -(** The type of converters from Lambda to Clambda. *) -type middle_end = - backend:(module Backend_intf.S) - -> filename:string - -> prefixname:string - -> ppf_dump:Format.formatter - -> Lambda.program - -> Clambda.with_constants - (** The type of converters straight from Lambda to Cmm. This is how Flambda 2 operates. *) type direct_to_cmm = @@ -33,12 +24,8 @@ type direct_to_cmm = -> Lambda.program -> Cmm.phrase list -(** The ways to get from Lambda to Cmm. *) +(** The one true way to get from Lambda to Cmm. *) type pipeline = - | Via_clambda of { - backend : (module Backend_intf.S); - middle_end : middle_end; - } | Direct_to_cmm of direct_to_cmm (** Compile an implementation from Lambda using the given middle end. *) diff --git a/backend/asmlibrarian.ml b/backend/asmlibrarian.ml index bc966a7ce3c..f3b721b56de 100644 --- a/backend/asmlibrarian.ml +++ b/backend/asmlibrarian.ml @@ -27,12 +27,7 @@ type error = exception Error of error let default_ui_export_info = - if Config.flambda then - Cmx_format.Flambda1 Export_info.empty - else if Config.flambda2 then - Cmx_format.Flambda2 None - else - Cmx_format.Clambda Clambda.Value_unknown + Cmx_format.Flambda2 None let read_info name = let filename = diff --git a/backend/asmlink.ml b/backend/asmlink.ml index 7ef1ead3301..2700c568ea4 100644 --- a/backend/asmlink.ml +++ b/backend/asmlink.ml @@ -359,7 +359,8 @@ let make_startup_file unix ~ppf_dump ~sourcefile_for_dwarf genfns units = List.flatten (List.map (fun u -> u.defines) units) in List.iter compile_phrase (Cmm_helpers.entry_point name_list); List.iter compile_phrase - (Cmm_helpers.emit_preallocated_blocks [] (* add gc_roots (for dynlink) *) + (* Emit the GC roots table, for dynlink. *) + (Cmm_helpers.emit_gc_roots_table ~symbols:[] (Generic_fns.compile ~shared:false genfns)); Array.iteri (fun i name -> compile_phrase (Cmm_helpers.predef_exception i name)) @@ -404,7 +405,7 @@ let make_shared_startup_file unix ~ppf_dump ~sourcefile_for_dwarf genfns units = sourcefile_for_dwarf; Emit.begin_assembly unix; List.iter compile_phrase - (Cmm_helpers.emit_preallocated_blocks [] (* add gc_roots (for dynlink) *) + (Cmm_helpers.emit_gc_roots_table ~symbols:[] (Generic_fns.compile ~shared:true genfns)); let dynunits = List.map (fun u -> Option.get u.dynunit) units in compile_phrase (Cmm_helpers.plugin_header dynunits); diff --git a/backend/asmpackager.ml b/backend/asmpackager.ml index 586bb9c2994..216c7802589 100644 --- a/backend/asmpackager.ml +++ b/backend/asmpackager.ml @@ -92,7 +92,7 @@ type flambda2 = Cmm.phrase list let make_package_object unix ~ppf_dump members targetobj targetname coercion - ~backend ~(flambda2 : flambda2) = + ~(flambda2 : flambda2) = Profile.record_call (Printf.sprintf "pack(%s)" targetname) (fun () -> let objtemp = if !Clflags.keep_asm_file @@ -137,14 +137,7 @@ let make_package_object unix ~ppf_dump members targetobj targetname coercion } in let pipeline : Asmgen.pipeline = - if Config.flambda2 then - Direct_to_cmm (flambda2 ~keep_symbol_tables:true) - else - let middle_end = - if Config.flambda then Flambda_middle_end.lambda_to_clambda - else Closure_middle_end.lambda_to_clambda - in - Via_clambda { middle_end; backend } + Direct_to_cmm (flambda2 ~keep_symbol_tables:true) in Asmgen.compile_implementation ~pipeline unix ~filename:targetname @@ -167,24 +160,8 @@ let make_package_object unix ~ppf_dump members targetobj targetname coercion let get_export_info_flambda2 ui : Flambda2_cmx.Flambda_cmx_format.t option = assert(Config.flambda2); match ui.ui_export_info with - | Clambda _ -> assert false - | Flambda1 _ -> assert false | Flambda2 info -> info -let get_export_info_flambda1 ui : Export_info.t = - assert(Config.flambda); - match ui.ui_export_info with - | Clambda _ -> assert false - | Flambda1 (info : Export_info.t) -> info - | Flambda2 _ -> assert false - -let get_approx ui : Clambda.value_approximation = - assert(not (Config.flambda || Config.flambda2)); - match ui.ui_export_info with - | Clambda info -> info - | Flambda1 _ -> assert false - | Flambda2 _ -> assert false - let build_package_cmx members cmxfile = let unit_names = List.map (fun m -> m.pm_name) members in @@ -203,26 +180,14 @@ let build_package_cmx members cmxfile = members [] in let ui = Compilenv.current_unit_infos() in let ui_export_info = - if Config.flambda then - let ui_export_info = - List.fold_left (fun acc info -> - Export_info.merge acc - (get_export_info_flambda1 info)) - (get_export_info_flambda1 ui) - units - in - Flambda1 ui_export_info - else if Config.flambda2 then - let flambda_export_info = - List.fold_left (fun acc info -> - Flambda2_cmx.Flambda_cmx_format.merge - (get_export_info_flambda2 info) acc) - (get_export_info_flambda2 ui) - units - in - Flambda2 flambda_export_info - else - Clambda (get_approx ui) + let flambda_export_info = + List.fold_left (fun acc info -> + Flambda2_cmx.Flambda_cmx_format.merge + (get_export_info_flambda2 info) acc) + (get_export_info_flambda2 ui) + units + in + Flambda2 flambda_export_info in let ui_checks = Checks.create () in List.iter (fun info -> Checks.merge info.ui_checks ~into:ui_checks) units; @@ -255,7 +220,7 @@ let build_package_cmx members cmxfile = (* Make the .cmx and the .o for the package *) let package_object_files unix ~ppf_dump files targetcmx - targetobj targetname coercion ~backend ~flambda2 = + targetobj targetname coercion ~flambda2 = let pack_path = let for_pack_prefix = CU.Prefix.from_clflags () in let name = targetname |> CU.Name.of_string in @@ -264,13 +229,12 @@ let package_object_files unix ~ppf_dump files targetcmx let members = map_left_right (read_member_info pack_path) files in check_units members; make_package_object unix ~ppf_dump members targetobj targetname coercion - ~backend ~flambda2; + ~flambda2; build_package_cmx members targetcmx (* The entry point *) -let package_files unix ~ppf_dump initial_env files targetcmx ~backend - ~flambda2 = +let package_files unix ~ppf_dump initial_env files targetcmx ~flambda2 = let files = List.map (fun f -> @@ -293,7 +257,7 @@ let package_files unix ~ppf_dump initial_env files targetcmx ~backend let coercion = Typemod.package_units initial_env files targetcmi comp_unit in package_object_files unix ~ppf_dump files targetcmx targetobj targetname - coercion ~backend ~flambda2 + coercion ~flambda2 ) ~exceptionally:(fun () -> remove_file targetcmx; remove_file targetobj) diff --git a/backend/asmpackager.mli b/backend/asmpackager.mli index 5092d539ac9..42aae720f85 100644 --- a/backend/asmpackager.mli +++ b/backend/asmpackager.mli @@ -22,7 +22,6 @@ val package_files -> Env.t -> string list -> string - -> backend:(module Backend_intf.S) -> flambda2:( ppf_dump:Format.formatter -> prefixname:string -> diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml index 4056a6c3241..70377210d8c 100644 --- a/backend/cmm_helpers.ml +++ b/backend/cmm_helpers.ml @@ -20,6 +20,12 @@ module VP = Backend_var.With_provenance open Cmm open Arch +type arity = + { function_kind : Lambda.function_kind; + params_layout : Lambda.layout list; + return_layout : Lambda.layout + } + (* Local binding of complex expressions *) let bind name arg fn = @@ -29,16 +35,6 @@ let bind name arg fn = let id = V.create_local name in Clet (VP.create id, arg, fn (Cvar id)) -let bind_load name arg fn = - match arg with Cop (Cload _, [Cvar _], _) -> fn arg | _ -> bind name arg fn - -let bind_nonvar name arg fn = - match arg with - | Cconst_int _ | Cconst_natint _ | Cconst_symbol _ -> fn arg - | _ -> - let id = V.create_local name in - Clet (VP.create id, arg, fn (Cvar id)) - let bind_list name args fn = let rec aux bound_args = function | [] -> fn bound_args @@ -151,7 +147,7 @@ let closure_info' ~arity ~startenv ~is_last = in pack_closure_info ~arity ~startenv ~is_last -let closure_info ~(arity : Clambda.arity) ~startenv ~is_last = +let closure_info ~(arity : arity) ~startenv ~is_last = closure_info' ~arity:(arity.function_kind, arity.params_layout) ~startenv ~is_last @@ -175,9 +171,6 @@ let alloc_closure_header ~mode sz dbg = let alloc_infix_header ofs dbg = Cconst_natint (infix_header ofs, dbg) -let alloc_closure_info ~arity ~startenv ~is_last dbg = - Cconst_natint (closure_info ~arity ~startenv ~is_last, dbg) - let alloc_boxedint32_header mode dbg = match mode with | Lambda.Alloc_heap -> Cconst_natint (boxedint32_header, dbg) @@ -214,9 +207,6 @@ let natint_const_untagged dbg n = let cint_const n = Cint (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) -let targetint_const n = - Targetint.add (Targetint.shift_left (Targetint.of_int n) 1) Targetint.one - let add_no_overflow n x c dbg = let d = n + x in if d = 0 then c else Cop (Caddi, [c; Cconst_int (d, dbg)], dbg) @@ -308,12 +298,6 @@ let ignore_low_bit_int = function | Cop (Cor, [c; Cconst_int (1, _)], _) -> c | c -> c -(* removes the 1-bit sign-extension left by untag_int (tag_int c) *) -let ignore_high_bit_int = function - | Cop (Casr, [Cop (Clsl, [c; Cconst_int (1, _)], _); Cconst_int (1, _)], _) -> - c - | c -> c - let lsr_int c1 c2 dbg = match c2 with | Cconst_int (0, _) -> c1 @@ -352,12 +336,6 @@ let untag_int i dbg = Cop (Clsr, [c; Cconst_int (n + 1, dbg)], dbg) | c -> asr_int c (Cconst_int (1, dbg)) dbg -let mk_if_then_else dbg value_kind cond ifso_dbg ifso ifnot_dbg ifnot = - match cond with - | Cconst_int (0, _) -> ifnot - | Cconst_int (1, _) -> ifso - | _ -> Cifthenelse (cond, ifso_dbg, ifso, ifnot_dbg, ifnot, dbg, value_kind) - let mk_not dbg cmm = match cmm with | Cop (Caddi, [Cop (Clsl, [c; Cconst_int (1, _)], _); Cconst_int (1, _)], dbg') @@ -717,7 +695,7 @@ let rec unbox_float dbg = c | Cconst_symbol (s, _dbg) as cmm -> ( match Cmmgen_state.structured_constant_of_sym s.sym_name with - | Some (Uconst_float x) -> Cconst_float (x, dbg) (* or keep _dbg? *) + | Some (Const_float x) -> Cconst_float (x, dbg) (* or keep _dbg? *) | _ -> Cop (mk_load_immut Double, [cmm], dbg)) | Cregion e as cmm -> ( (* It is valid to push unboxing inside a Cregion except when the extra @@ -749,7 +727,7 @@ let rec unbox_vec128 dbg = c | Cconst_symbol (s, _dbg) as cmm -> ( match Cmmgen_state.structured_constant_of_sym s.sym_name with - | Some (Uconst_vec128 { low; high }) -> + | Some (Const_vec128 { low; high }) -> Cconst_vec128 ({ low; high }, dbg) (* or keep _dbg? *) | _ -> Cop (mk_load_immut Onetwentyeight_unaligned, [cmm], dbg)) | Cregion e as cmm -> ( @@ -787,36 +765,6 @@ let complex_im c dbg = let return_unit dbg c = Csequence (c, Cconst_int (1, dbg)) -let rec remove_unit = function - | Cconst_int (1, _) -> Ctuple [] - | Csequence (c, Cconst_int (1, _)) -> c - | Csequence (c1, c2) -> Csequence (c1, remove_unit c2) - | Cifthenelse (cond, ifso_dbg, ifso, ifnot_dbg, ifnot, dbg, kind) -> - Cifthenelse - (cond, ifso_dbg, remove_unit ifso, ifnot_dbg, remove_unit ifnot, dbg, kind) - | Cswitch (sel, index, cases, dbg, kind) -> - Cswitch - ( sel, - index, - Array.map (fun (case, dbg) -> remove_unit case, dbg) cases, - dbg, - kind ) - | Ccatch (rec_flag, handlers, body, kind) -> - let map_h (n, ids, handler, dbg, is_cold) = - n, ids, remove_unit handler, dbg, is_cold - in - Ccatch (rec_flag, List.map map_h handlers, remove_unit body, kind) - | Ctrywith (body, kind, exn, handler, dbg, value_kind) -> - Ctrywith (remove_unit body, kind, exn, remove_unit handler, dbg, value_kind) - | Clet (id, c1, c2) -> Clet (id, c1, remove_unit c2) - | Cop (Capply (_mty, pos), args, dbg) -> - Cop (Capply (typ_void, pos), args, dbg) - | Cop (Cextcall c, args, dbg) -> - Cop (Cextcall { c with ty = typ_void }, args, dbg) - | Cexit (_, _, _) as c -> c - | Ctuple [] as c -> c - | c -> Csequence (c, Ctuple []) - let field_address ptr n dbg = if n = 0 then ptr else Cop (Cadda, [ptr; Cconst_int (n * size_addr, dbg)], dbg) @@ -890,9 +838,6 @@ let is_addr_array_hdr hdr dbg = [Cop (Cand, [hdr; Cconst_int (255, dbg)], dbg); floatarray_tag dbg], dbg ) -let is_addr_array_ptr ptr dbg = - Cop (Ccmpi Cne, [get_tag ptr dbg; floatarray_tag dbg], dbg) - let addr_array_length_shifted hdr dbg = Cop (Clsr, [hdr; Cconst_int (wordsize_shift, dbg)], dbg) @@ -1061,9 +1006,6 @@ let string_length exp dbg = dbg ) ], dbg ) )) -let bigstring_length ba dbg = - Cop (mk_load_mut Word_int, [field_address ba 5 dbg], dbg) - let bigstring_get_alignment ba idx align dbg = bind "ba_data" (Cop (mk_load_mut Word_int, [field_address ba 1 dbg], dbg)) @@ -1288,17 +1230,6 @@ let make_float_alloc ~mode dbg tag args = (List.length args * size_float / size_addr) args -(* Bounds checking *) - -let make_checkbound dbg = function - | [Cop (Clsr, [a1; Cconst_int (n, _)], _); Cconst_int (m, _)] when m lsl n > n - -> - Cop (Ccheckbound, [a1; Cconst_int ((m lsl n) + (1 lsl n) - 1, dbg)], dbg) - | args -> Cop (Ccheckbound, args, dbg) - -let make_checkalign dbg bytes_pow2 args = - Cop (Ccheckalign { bytes_pow2 }, args, dbg) - (* Record application and currying functions *) let apply_function_name arity result (mode : Lambda.alloc_mode) = @@ -1358,64 +1289,6 @@ let bigarray_elt_size_in_bytes : Lambda.bigarray_kind -> int = function | Pbigarray_complex32 -> 8 | Pbigarray_complex64 -> 16 -(* Produces a pointer to the element of the bigarray [b] on the position [args]. - [args] is given as a list of tagged int expressions, one per array - dimension. *) -let bigarray_indexing unsafe elt_kind layout b args dbg = - let check_ba_bound bound idx v = - Csequence (make_checkbound dbg [bound; idx], v) - in - (* Validates the given multidimensional offset against the array bounds and - transforms it into a one dimensional offset. The offsets are expressions - evaluating to tagged int. *) - let rec ba_indexing dim_ofs delta_ofs = function - | [] -> assert false - | [arg] -> - if unsafe - then arg - else - bind "idx" arg (fun idx -> - (* Load the untagged int bound for the given dimension *) - let bound = - Cop (mk_load_mut Word_int, [field_address b dim_ofs dbg], dbg) - in - let idxn = untag_int idx dbg in - check_ba_bound bound idxn idx) - | arg1 :: argl -> - (* The remainder of the list is transformed into a one dimensional - offset *) - let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in - (* Load the untagged int bound for the given dimension *) - let bound = - Cop (mk_load_mut Word_int, [field_address b dim_ofs dbg], dbg) - in - if unsafe - then add_int (mul_int (decr_int rem dbg) bound dbg) arg1 dbg - else - bind "idx" arg1 (fun idx -> - bind "bound" bound (fun bound -> - let idxn = untag_int idx dbg in - (* [offset = rem * (tag_int bound) + idx] *) - let offset = - add_int (mul_int (decr_int rem dbg) bound dbg) idx dbg - in - check_ba_bound bound idxn offset)) - in - (* The offset as an expression evaluating to int *) - let offset = - match (layout : Lambda.bigarray_layout) with - | Pbigarray_unknown_layout -> assert false - | Pbigarray_c_layout -> - ba_indexing (4 + List.length args) (-1) (List.rev args) - | Pbigarray_fortran_layout -> - ba_indexing 5 1 - (List.map (fun idx -> sub_int idx (Cconst_int (2, dbg)) dbg) args) - and elt_size = bigarray_elt_size_in_bytes elt_kind in - (* [array_indexing] can simplify the given expressions *) - array_indexing ~typ:Addr (Misc.log2 elt_size) - (Cop (mk_load_mut Word_int, [field_address b 1 dbg], dbg)) - offset dbg - let bigarray_word_kind : Lambda.bigarray_kind -> memory_chunk = function | Pbigarray_unknown -> assert false | Pbigarray_float32 -> Single @@ -1431,54 +1304,6 @@ let bigarray_word_kind : Lambda.bigarray_kind -> memory_chunk = function | Pbigarray_complex32 -> Single | Pbigarray_complex64 -> Double -let bigarray_get unsafe elt_kind layout b args dbg = - bind "ba" b (fun b -> - match (elt_kind : Lambda.bigarray_kind) with - | Pbigarray_complex32 | Pbigarray_complex64 -> - let kind = bigarray_word_kind elt_kind in - let sz = bigarray_elt_size_in_bytes elt_kind / 2 in - bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) - (fun addr -> - bind "reval" - (Cop (mk_load_mut kind, [addr], dbg)) - (fun reval -> - bind "imval" - (Cop - ( mk_load_mut kind, - [Cop (Cadda, [addr; Cconst_int (sz, dbg)], dbg)], - dbg )) - (fun imval -> box_complex dbg reval imval))) - | _ -> - Cop - ( mk_load_mut (bigarray_word_kind elt_kind), - [bigarray_indexing unsafe elt_kind layout b args dbg], - dbg )) - -let bigarray_set unsafe elt_kind layout b args newval dbg = - bind "ba" b (fun b -> - match (elt_kind : Lambda.bigarray_kind) with - | Pbigarray_complex32 | Pbigarray_complex64 -> - let kind = bigarray_word_kind elt_kind in - let sz = bigarray_elt_size_in_bytes elt_kind / 2 in - bind "newval" newval (fun newv -> - bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) - (fun addr -> - Csequence - ( Cop - ( Cstore (kind, Assignment), - [addr; complex_re newv dbg], - dbg ), - Cop - ( Cstore (kind, Assignment), - [ Cop (Cadda, [addr; Cconst_int (sz, dbg)], dbg); - complex_im newv dbg ], - dbg ) ))) - | _ -> - Cop - ( Cstore (bigarray_word_kind elt_kind, Assignment), - [bigarray_indexing unsafe elt_kind layout b args dbg; newval], - dbg )) - (* the three functions below assume 64-bit words *) let () = assert (size_int = 8) @@ -1611,9 +1436,6 @@ let box_int_gen dbg (bi : Primitive.boxed_integer) mode arg = arg' ], dbg ) -let box_vec128_gen dbg mode arg = - Cop (Calloc mode, [alloc_boxedvec128_header mode dbg; arg], dbg) - let alloc_matches_boxed_int bi ~hdr ~ops = match (bi : Primitive.boxed_integer), hdr, ops with | Pnativeint, Cconst_natint (hdr, _dbg), Cconst_symbol (sym, _) -> @@ -1659,11 +1481,11 @@ let rec unbox_int dbg bi = contents | Cconst_symbol (s, _dbg) as cmm -> ( match Cmmgen_state.structured_constant_of_sym s.sym_name, bi with - | Some (Uconst_nativeint n), Primitive.Pnativeint -> + | Some (Const_nativeint n), Primitive.Pnativeint -> natint_const_untagged dbg n - | Some (Uconst_int32 n), Primitive.Pint32 -> + | Some (Const_int32 n), Primitive.Pint32 -> natint_const_untagged dbg (Nativeint.of_int32 n) - | Some (Uconst_int64 n), Primitive.Pint64 -> + | Some (Const_int64 n), Primitive.Pint64 -> natint_const_untagged dbg (Int64.to_nativeint n) | _ -> default cmm) | Cregion e as cmm -> ( @@ -1990,95 +1812,8 @@ let aligned_set_128 ptr idx newval dbg = [add_int ptr idx dbg; newval], dbg ) -let max_or_zero a dbg = - bind "size" a (fun a -> - (* equivalent to: - - Cifthenelse(Cop(Ccmpi Cle, [a; cconst_int 0]), cconst_int 0, a) - - if a is positive, sign is 0 hence sign_negation is full of 1 so - sign_negation&a = a - - if a is negative, sign is full of 1 hence sign_negation is 0 so - sign_negation&a = 0 *) - let sign = Cop (Casr, [a; Cconst_int ((size_int * 8) - 1, dbg)], dbg) in - let sign_negation = Cop (Cxor, [sign; Cconst_int (-1, dbg)], dbg) in - Cop (Cand, [sign_negation; a], dbg)) - -let check_bound_and_alignment unsafe access_size dbg ~address ~length ~offset k - = - match (unsafe : Lambda.is_safe) with - | Unsafe -> k - | Safe -> - let access_length, access_align = - match (access_size : Clambda_primitives.memory_access_size) with - | Sixteen -> 1, 0 - | Thirty_two -> 3, 0 - | Sixty_four -> 7, 0 - | One_twenty_eight { aligned = false } -> 15, 0 - | One_twenty_eight { aligned = true } -> 15, 16 - in - let check_align = - match access_align with - | 0 -> k - | align -> - Csequence (make_checkalign dbg align [add_int address offset dbg], k) - in - let valid_length = sub_int length (Cconst_int (access_length, dbg)) dbg in - Csequence - (make_checkbound dbg [max_or_zero valid_length dbg; offset], check_align) - let opaque e dbg = Cop (Copaque, [e], dbg) -(* The alignment of 128-bit stores is determined by [size], and may be - aligned. *) -let unaligned_set size ptr idx newval dbg = - match (size : Clambda_primitives.memory_access_size) with - | Sixteen -> unaligned_set_16 ptr idx newval dbg - | Thirty_two -> unaligned_set_32 ptr idx newval dbg - | Sixty_four -> unaligned_set_64 ptr idx newval dbg - | One_twenty_eight { aligned = false } -> unaligned_set_128 ptr idx newval dbg - | One_twenty_eight { aligned = true } -> aligned_set_128 ptr idx newval dbg - -(* The alignment of 128-bit loads is determined by [size], and may be - aligned. *) -let unaligned_load size ptr idx dbg = - match (size : Clambda_primitives.memory_access_size) with - | Sixteen -> unaligned_load_16 ptr idx dbg - | Thirty_two -> unaligned_load_32 ptr idx dbg - | Sixty_four -> unaligned_load_64 ptr idx dbg - | One_twenty_eight { aligned = false } -> unaligned_load_128 ptr idx dbg - | One_twenty_eight { aligned = true } -> aligned_load_128 ptr idx dbg - -let box_sized size mode dbg exp = - match (size : Clambda_primitives.memory_access_size) with - | Sixteen -> tag_int exp dbg - | Thirty_two -> box_int_gen dbg Pint32 mode exp - | Sixty_four -> box_int_gen dbg Pint64 mode exp - | One_twenty_eight _ -> box_vec128_gen dbg mode exp - -(* Simplification of some primitives into C calls *) - -let default_prim name = - Primitive.simple_on_values ~name ~arity:0 (*ignored*) ~alloc:true - -let simplif_primitive p : Clambda_primitives.primitive = - match (p : Clambda_primitives.primitive) with - | Pduprecord _ -> Pccall (default_prim "caml_obj_dup") - | Pbigarrayref (_unsafe, n, Pbigarray_unknown, _layout) -> - Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) - | Pbigarrayset (_unsafe, n, Pbigarray_unknown, _layout) -> - Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) - | Pbigarrayref (_unsafe, n, _kind, Pbigarray_unknown_layout) -> - Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) - | Pbigarrayset (_unsafe, n, _kind, Pbigarray_unknown_layout) -> - Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) - | p -> p - -(* Build switchers both for constants and blocks *) - -let transl_isout h arg dbg = tag_int (Cop (Ccmpa Clt, [h; arg], dbg)) dbg - (* Build an actual switch (ie jump table) *) let make_switch arg cases actions dbg kind = @@ -2235,66 +1970,8 @@ module StoreExpForSwitch = Switch.CtxStore (struct | _, _ -> Stdlib.compare index index' end) -(* For string switches, we can use a generic store *) -module StoreExp = Switch.Store (struct - type t = expression - - type key = int - - let make_key = function Cexit (Lbl i, [], []) -> Some i | _ -> None - - let compare_key = Stdlib.compare -end) - module SwitcherBlocks = Switch.Make (SArgBlocks) -(* Int switcher, arg in [low..high], cases is list of individual cases, and is - sorted by first component *) - -let transl_int_switch dbg value_kind arg low high cases default = - match cases with - | [] -> assert false - | _ :: _ -> - let store = StoreExp.mk_store () in - assert (store.Switch.act_store () default = 0); - let cases = - List.map (fun (i, act) -> i, store.Switch.act_store () act) cases - in - let rec inters plow phigh pact = function - | [] -> - if phigh = high - then [plow, phigh, pact] - else [plow, phigh, pact; phigh + 1, high, 0] - | (i, act) :: rem -> - if i = phigh + 1 - then - if pact = act - then inters plow i pact rem - else (plow, phigh, pact) :: inters i i act rem - else if (* insert default *) - pact = 0 - then - if act = 0 - then inters plow i 0 rem - else (plow, i - 1, pact) :: inters i i act rem - else - (* pact <> 0 *) - (plow, phigh, pact) - :: - (if act = 0 - then inters (phigh + 1) i 0 rem - else (phigh + 1, i - 1, 0) :: inters i i act rem) - in - let inters = - match cases with - | [] -> assert false - | (k0, act0) :: rem -> - if k0 = low then inters k0 k0 act0 rem else inters low (k0 - 1) 0 cases - in - bind "switcher" arg (fun a -> - SwitcherBlocks.zyva dbg value_kind (low, high) a (Array.of_list inters) - store) - let transl_switch_clambda loc value_kind arg index cases = let store = StoreExpForSwitch.mk_store () in let index = Array.map (fun j -> store.Switch.act_store j cases.(j)) index in @@ -2322,22 +1999,6 @@ let transl_switch_clambda loc value_kind arg index cases = (0, n_index - 1) a (Array.of_list inters) store) -let strmatch_compile = - let module S = Strmatch.Make (struct - let string_block_length ptr = get_size ptr Debuginfo.none - - let transl_switch = transl_int_switch - end) in - S.compile - -let ptr_offset ptr offset dbg = - if offset = 0 - then ptr - else Cop (Caddv, [ptr; Cconst_int (offset * size_addr, dbg)], dbg) - -let direct_apply lbl ty args (pos, _mode) dbg = - Cop (Capply (ty, pos), Cconst_symbol (lbl, dbg) :: args, dbg) - let split_arity_for_apply arity args = (* Decides whether a caml_applyN needs to be split. If N <= max_arity, then keep caml_apply as is; otherwise, split at caml_apply[max_arity] *) @@ -3066,14 +2727,6 @@ let curry_function (kind, arity, return) = type unary_primitive = expression -> Debuginfo.t -> expression -let floatfield n ptr dbg = - Cop - ( mk_load_mut Double, - [ (if n = 0 - then ptr - else Cop (Cadda, [ptr; Cconst_int (n * size_float, dbg)], dbg)) ], - dbg ) - let int_as_pointer arg dbg = Cop (Caddi, [arg; Cconst_int (-1, dbg)], dbg) (* always a pointer outside the heap *) @@ -3084,18 +2737,6 @@ let raise_prim raise_kind arg dbg = let negint arg dbg = Cop (Csubi, [Cconst_int (2, dbg); arg], dbg) -(* [offsetint] moved down to reuse add_int_caml *) - -let offsetref n arg dbg = - return_unit dbg - (bind "ref" arg (fun arg -> - Cop - ( Cstore (Word_int, Assignment), - [ arg; - add_const (Cop (mk_load_mut Word_int, [arg], dbg)) (n lsl 1) dbg - ], - dbg ))) - let arraylength kind arg dbg = let hdr = get_header_masked arg dbg in match (kind : Lambda.array_kind) with @@ -3177,8 +2818,6 @@ let bswap16 arg dbg = type binary_primitive = expression -> expression -> Debuginfo.t -> expression -(* let pfield_computed = addr_array_ref *) - (* Helper for compilation of initialization and assignment operations *) type assignment_kind = @@ -3250,29 +2889,8 @@ let setfield n ptr init arg1 arg2 dbg = dbg )) | Simple init -> return_unit dbg (set_field arg1 n arg2 init dbg) -let setfloatfield n init arg1 arg2 dbg = - let init = - match init with - | Lambda.Assignment _ -> Assignment - | Lambda.Heap_initialization | Lambda.Root_initialization -> Initialization - in - return_unit dbg - (Cop - ( Cstore (Double, init), - [ (if n = 0 - then arg1 - else Cop (Cadda, [arg1; Cconst_int (n * size_float, dbg)], dbg)); - arg2 ], - dbg )) - let add_int_caml arg1 arg2 dbg = decr_int (add_int arg1 arg2 dbg) dbg -(* Unary primitive delayed to reuse add_int_caml *) -let offsetint n arg dbg = - if Misc.no_overflow_lsl n 1 - then add_const arg (n lsl 1) dbg - else add_int_caml arg (int_const dbg n) dbg - let sub_int_caml arg1 arg2 dbg = incr_int (sub_int arg1 arg2 dbg) dbg let mul_int_caml arg1 arg2 dbg = @@ -3319,122 +2937,6 @@ let lsr_int_caml arg1 arg2 dbg = let asr_int_caml arg1 arg2 dbg = Cop (Cor, [asr_int arg1 (untag_int arg2 dbg) dbg; Cconst_int (1, dbg)], dbg) -let int_comp_caml cmp arg1 arg2 dbg = - tag_int (Cop (Ccmpi cmp, [arg1; arg2], dbg)) dbg - -let stringref_unsafe arg1 arg2 dbg = - tag_int - (Cop - (mk_load_mut Byte_unsigned, [add_int arg1 (untag_int arg2 dbg) dbg], dbg)) - dbg - -let stringref_safe arg1 arg2 dbg = - tag_int - (bind "index" (untag_int arg2 dbg) (fun idx -> - bind "str" arg1 (fun str -> - Csequence - ( make_checkbound dbg [string_length str dbg; idx], - Cop (mk_load_mut Byte_unsigned, [add_int str idx dbg], dbg) )))) - dbg - -let string_load size unsafe mode arg1 arg2 dbg = - box_sized size mode dbg - (bind "index" (untag_int arg2 dbg) (fun idx -> - bind "str" arg1 (fun str -> - check_bound_and_alignment unsafe size dbg ~address:str - ~length:(string_length str dbg) ~offset:idx - (unaligned_load size str idx dbg)))) - -let bigstring_load size unsafe mode arg1 arg2 dbg = - box_sized size mode dbg - (bind "index" (untag_int arg2 dbg) (fun idx -> - bind "ba" arg1 (fun ba -> - bind "ba_data" - (Cop (mk_load_mut Word_int, [field_address ba 1 dbg], dbg)) - (fun ba_data -> - check_bound_and_alignment unsafe size dbg ~address:ba_data - ~length:(bigstring_length ba dbg) ~offset:idx - (unaligned_load size ba_data idx dbg))))) - -let arrayref_unsafe rkind arg1 arg2 dbg = - match (rkind : Lambda.array_ref_kind) with - | Pgenarray_ref mode -> - bind "index" arg2 (fun idx -> - bind "arr" arg1 (fun arr -> - Cifthenelse - ( is_addr_array_ptr arr dbg, - dbg, - addr_array_ref arr idx dbg, - dbg, - float_array_ref mode arr idx dbg, - dbg, - Any ))) - | Paddrarray_ref -> addr_array_ref arg1 arg2 dbg - | Pintarray_ref -> - (* CR mshinwell: for int/addr_array_ref move "dbg" to first arg *) - int_array_ref arg1 arg2 dbg - | Pfloatarray_ref mode -> float_array_ref mode arg1 arg2 dbg - -let arrayref_safe rkind arg1 arg2 dbg = - match (rkind : Lambda.array_ref_kind) with - | Pgenarray_ref mode -> - bind "index" arg2 (fun idx -> - bind "arr" arg1 (fun arr -> - bind "header" (get_header_masked arr dbg) (fun hdr -> - if wordsize_shift = numfloat_shift - then - Csequence - ( make_checkbound dbg - [addr_array_length_shifted hdr dbg; idx], - Cifthenelse - ( is_addr_array_hdr hdr dbg, - dbg, - addr_array_ref arr idx dbg, - dbg, - float_array_ref mode arr idx dbg, - dbg, - Any ) ) - else - Cifthenelse - ( is_addr_array_hdr hdr dbg, - dbg, - Csequence - ( make_checkbound dbg - [addr_array_length_shifted hdr dbg; idx], - addr_array_ref arr idx dbg ), - dbg, - Csequence - ( make_checkbound dbg - [float_array_length_shifted hdr dbg; idx], - float_array_ref mode arr idx dbg ), - dbg, - Any )))) - | Paddrarray_ref -> - bind "index" arg2 (fun idx -> - bind "arr" arg1 (fun arr -> - Csequence - ( make_checkbound dbg - [ addr_array_length_shifted (get_header_masked arr dbg) dbg; - idx ], - addr_array_ref arr idx dbg ))) - | Pintarray_ref -> - bind "index" arg2 (fun idx -> - bind "arr" arg1 (fun arr -> - Csequence - ( make_checkbound dbg - [ addr_array_length_shifted (get_header_masked arr dbg) dbg; - idx ], - int_array_ref arr idx dbg ))) - | Pfloatarray_ref mode -> - box_float dbg mode - (bind "index" arg2 (fun idx -> - bind "arr" arg1 (fun arr -> - Csequence - ( make_checkbound dbg - [ float_array_length_shifted (get_header_masked arr dbg) dbg; - idx ], - unboxed_float_array_ref arr idx dbg )))) - type ternary_primitive = expression -> expression -> expression -> Debuginfo.t -> expression @@ -3447,140 +2949,6 @@ let setfield_computed ptr init arg1 arg2 arg3 dbg = return_unit dbg (addr_array_initialize arg1 arg2 arg3 dbg) | Simple _ -> return_unit dbg (int_array_set arg1 arg2 arg3 dbg) -let bytesset_unsafe arg1 arg2 arg3 dbg = - return_unit dbg - (Cop - ( Cstore (Byte_unsigned, Assignment), - [ add_int arg1 (untag_int arg2 dbg) dbg; - ignore_high_bit_int (untag_int arg3 dbg) ], - dbg )) - -let bytesset_safe arg1 arg2 arg3 dbg = - return_unit dbg - (bind "newval" - (ignore_high_bit_int (untag_int arg3 dbg)) - (fun newval -> - bind "index" (untag_int arg2 dbg) (fun idx -> - bind "str" arg1 (fun str -> - Csequence - ( make_checkbound dbg [string_length str dbg; idx], - Cop - ( Cstore (Byte_unsigned, Assignment), - [add_int str idx dbg; newval], - dbg ) ))))) - -let arrayset_unsafe skind arg1 arg2 arg3 dbg = - return_unit dbg - (match (skind : Lambda.array_set_kind) with - | Pgenarray_set mode -> - bind "newval" arg3 (fun newval -> - bind "index" arg2 (fun index -> - bind "arr" arg1 (fun arr -> - Cifthenelse - ( is_addr_array_ptr arr dbg, - dbg, - addr_array_set mode arr index newval dbg, - dbg, - float_array_set arr index (unbox_float dbg newval) dbg, - dbg, - Any )))) - | Paddrarray_set mode -> addr_array_set mode arg1 arg2 arg3 dbg - | Pintarray_set -> int_array_set arg1 arg2 arg3 dbg - | Pfloatarray_set -> float_array_set arg1 arg2 arg3 dbg) - -let arrayset_safe skind arg1 arg2 arg3 dbg = - return_unit dbg - (match (skind : Lambda.array_set_kind) with - | Pgenarray_set mode -> - bind "newval" arg3 (fun newval -> - bind "index" arg2 (fun idx -> - bind "arr" arg1 (fun arr -> - bind "header" (get_header_masked arr dbg) (fun hdr -> - if wordsize_shift = numfloat_shift - then - Csequence - ( make_checkbound dbg - [addr_array_length_shifted hdr dbg; idx], - Cifthenelse - ( is_addr_array_hdr hdr dbg, - dbg, - addr_array_set mode arr idx newval dbg, - dbg, - float_array_set arr idx (unbox_float dbg newval) - dbg, - dbg, - Any ) ) - else - Cifthenelse - ( is_addr_array_hdr hdr dbg, - dbg, - Csequence - ( make_checkbound dbg - [addr_array_length_shifted hdr dbg; idx], - addr_array_set mode arr idx newval dbg ), - dbg, - Csequence - ( make_checkbound dbg - [float_array_length_shifted hdr dbg; idx], - float_array_set arr idx (unbox_float dbg newval) - dbg ), - dbg, - Any ))))) - | Paddrarray_set mode -> - bind "newval" arg3 (fun newval -> - bind "index" arg2 (fun idx -> - bind "arr" arg1 (fun arr -> - Csequence - ( make_checkbound dbg - [ addr_array_length_shifted - (get_header_masked arr dbg) - dbg; - idx ], - addr_array_set mode arr idx newval dbg )))) - | Pintarray_set -> - bind "newval" arg3 (fun newval -> - bind "index" arg2 (fun idx -> - bind "arr" arg1 (fun arr -> - Csequence - ( make_checkbound dbg - [ addr_array_length_shifted - (get_header_masked arr dbg) - dbg; - idx ], - int_array_set arr idx newval dbg )))) - | Pfloatarray_set -> - bind_load "newval" arg3 (fun newval -> - bind "index" arg2 (fun idx -> - bind "arr" arg1 (fun arr -> - Csequence - ( make_checkbound dbg - [ float_array_length_shifted - (get_header_masked arr dbg) - dbg; - idx ], - float_array_set arr idx newval dbg ))))) - -let bytes_set size unsafe arg1 arg2 arg3 dbg = - return_unit dbg - (bind "newval" arg3 (fun newval -> - bind "index" (untag_int arg2 dbg) (fun idx -> - bind "str" arg1 (fun str -> - check_bound_and_alignment unsafe size dbg ~address:str - ~length:(string_length str dbg) ~offset:idx - (unaligned_set size str idx newval dbg))))) - -let bigstring_set size unsafe arg1 arg2 arg3 dbg = - return_unit dbg - (bind "newval" arg3 (fun newval -> - bind "index" (untag_int arg2 dbg) (fun idx -> - bind "ba" arg1 (fun ba -> - bind "ba_data" - (Cop (mk_load_mut Word_int, [field_address ba 1 dbg], dbg)) - (fun ba_data -> - check_bound_and_alignment unsafe size dbg ~address:ba_data - ~length:(bigstring_length ba dbg) ~offset:idx - (unaligned_set size ba_data idx newval dbg)))))) - (* Symbols *) let cdefine_symbol sym = [Cdefine_symbol sym] @@ -3822,98 +3190,6 @@ let plugin_header units = ({ dynu_magic = Config.cmxs_magic_number; dynu_units = units } : Cmxs_format.dynheader) -(* To compile "let rec" over values *) - -let fundecls_size fundecls = - let sz = ref (-1) in - List.iter - (fun (f : Clambda.ufunction) -> - let indirect_call_code_pointer_size = - match f.arity with - | { function_kind = Curried _; params_layout = [] | [_]; _ } -> - 0 - (* arity 1 does not need an indirect call handler. arity 0 cannot be - indirect called *) - | _ -> 1 - (* For other arities there is an indirect call handler. - - if arity >= 2 it is caml_curry... - - if arity < 0 it is caml_tuplify... *) - in - sz := !sz + 1 + 2 + indirect_call_code_pointer_size) - fundecls; - !sz - -(* Emit constant closures *) - -let emit_constant_closure symb fundecls clos_vars cont = - let closure_symbol (f : Clambda.ufunction) = - if Config.flambda - then - cdefine_symbol - { sym_name = f.label ^ "_closure"; sym_global = symb.sym_global } - else [] - in - match (fundecls : Clambda.ufunction list) with - | [] -> - (* This should probably not happen: dead code has normally been eliminated - and a closure cannot be accessed without going through a - [Project_closure], which depends on the function. *) - assert (clos_vars = []); - cdefine_symbol symb @ clos_vars @ cont - | f1 :: remainder -> ( - let startenv = fundecls_size fundecls in - let rec emit_others pos = function - | [] -> clos_vars @ cont - | (f2 : Clambda.ufunction) :: rem -> ( - let is_last = match rem with [] -> true | _ :: _ -> false in - match f2.arity with - | { function_kind = Curried _; params_layout = [] | [_]; _ } as arity -> - (Cint (infix_header pos) :: closure_symbol f2) - @ Csymbol_address - { sym_name = f2.label; sym_global = symb.sym_global } - :: Cint (closure_info ~arity ~startenv:(startenv - pos) ~is_last) - :: emit_others (pos + 3) rem - | arity -> - (* See note in the apply function code about the conversion from - tagged integer to value machtypes. *) - let params_machtypes = - List.map machtype_of_layout_changing_tagged_int_to_val - arity.params_layout - in - let return_machtype = - machtype_of_layout_changing_tagged_int_to_val arity.return_layout - in - (Cint (infix_header pos) :: closure_symbol f2) - @ Csymbol_address - (curry_function_sym arity.function_kind params_machtypes - return_machtype) - :: Cint (closure_info ~arity ~startenv:(startenv - pos) ~is_last) - :: Csymbol_address - { sym_name = f2.label; sym_global = symb.sym_global } - :: emit_others (pos + 4) rem) - in - let is_last = match remainder with [] -> true | _ :: _ -> false in - Cint (black_closure_header (fundecls_size fundecls + List.length clos_vars)) - :: cdefine_symbol symb - @ closure_symbol f1 - @ - match f1.arity with - | { function_kind = Curried _; params_layout = [] | [_]; _ } as arity -> - Csymbol_address { sym_name = f1.label; sym_global = symb.sym_global } - :: Cint (closure_info ~arity ~startenv ~is_last) - :: emit_others 3 remainder - | arity -> - Csymbol_address - (curry_function_sym arity.function_kind - (List.map machtype_of_layout_changing_tagged_int_to_val - arity.params_layout) - (machtype_of_layout_changing_tagged_int_to_val arity.return_layout)) - :: Cint (closure_info ~arity ~startenv ~is_last) - :: Csymbol_address { sym_name = f1.label; sym_global = symb.sym_global } - :: emit_others 4 remainder) - (* Build the NULL terminated array of gc roots *) let emit_gc_roots_table ~symbols cont = @@ -3924,41 +3200,6 @@ let emit_gc_roots_table ~symbols cont = @ [Cint 0n]) :: cont -(* Build preallocated blocks (used for Flambda [Initialize_symbol] constructs, - and Clambda global module) *) - -let preallocate_block cont { Clambda.symbol; exported; tag; fields } = - let mksym sym_name = - { sym_name; sym_global = (if exported then Global else Local) } - in - let space = - (* These words will be registered as roots and as such must contain valid - values, in case we are in no-naked-pointers mode. Likewise the block - header must be black, below (see [caml_darken]), since the overall record - may be referenced. *) - List.map - (fun field -> - match field with - | None -> Cint (Nativeint.of_int 1 (* Val_unit *)) - | Some (Clambda.Uconst_field_int n) -> cint_const n - | Some (Clambda.Uconst_field_ref label) -> Csymbol_address (mksym label)) - fields - in - let data = - emit_block (mksym symbol) (block_header tag (List.length fields)) space - in - Cdata data :: cont - -let emit_preallocated_blocks preallocated_blocks cont = - let symbols = - List.map - (fun ({ Clambda.symbol; exported } : Clambda.preallocated_block) -> - { sym_name = symbol; sym_global = (if exported then Global else Local) }) - preallocated_blocks - in - let c1 = emit_gc_roots_table ~symbols cont in - List.fold_left preallocate_block c1 preallocated_blocks - (* Helper functions and values used by Flambda 2. *) let typ_int64 = diff --git a/backend/cmm_helpers.mli b/backend/cmm_helpers.mli index f5595bf5d95..48cf026b20b 100644 --- a/backend/cmm_helpers.mli +++ b/backend/cmm_helpers.mli @@ -15,22 +15,18 @@ open Cmm +type arity = + { function_kind : Lambda.function_kind; + params_layout : Lambda.layout list; + return_layout : Lambda.layout + } + (** [bind name arg fn] is equivalent to [let name = arg in fn name], or simply [fn arg] if [arg] is simple enough *) val bind : string -> expression -> (expression -> expression) -> expression -(** Same as [bind], but also treats loads from a variable as simple *) -val bind_load : string -> expression -> (expression -> expression) -> expression - -(** Same as [bind], but does not treat variables as simple *) -val bind_nonvar : - string -> expression -> (expression -> expression) -> expression - (** Headers *) -(** A null header with GC bits set to black *) -val caml_black : nativeint - (** A constant equal to the tag for float arrays *) val floatarray_tag : Debuginfo.t -> expression @@ -41,27 +37,13 @@ val block_header : int -> int -> nativeint (** Same as block_header, but with GC bits set to black *) val black_block_header : int -> int -> nativeint -(** Closure headers of the given size *) -val white_closure_header : int -> nativeint - val black_closure_header : int -> nativeint (** Infix header at the given offset *) val infix_header : int -> nativeint -(** Header for a boxed float value *) -val float_header : nativeint - -(** Boxed integer headers *) -val boxedint32_header : nativeint - -val boxedint64_header : nativeint - -val boxedintnat_header : nativeint - (** Closure info for a closure of given arity and distance to environment *) -val closure_info : - arity:Clambda.arity -> startenv:int -> is_last:bool -> nativeint +val closure_info : arity:arity -> startenv:int -> is_last:bool -> nativeint val closure_info' : arity:Lambda.function_kind * 'a list -> @@ -72,47 +54,12 @@ val closure_info' : (** Wrappers *) val alloc_infix_header : int -> Debuginfo.t -> expression -val alloc_closure_info : - arity:Clambda.arity -> - startenv:int -> - is_last:bool -> - Debuginfo.t -> - expression - -(** Integers *) - -(** Minimal/maximal OCaml integer values whose backend representation fits in a - regular OCaml integer *) -val max_repr_int : int - -val min_repr_int : int - (** Make an integer constant from the given integer (tags the integer) *) val int_const : Debuginfo.t -> int -> expression -val cint_const : int -> data_item - -val targetint_const : int -> Targetint.t - -(** Make a Cmm constant holding the given nativeint value. Uses [Cconst_int] - instead of [Cconst_nativeint] when possible to preserve peephole - optimisations. *) -val natint_const_untagged : Debuginfo.t -> Nativeint.t -> expression - -(** Add an integer to the given expression *) -val add_const : expression -> int -> Debuginfo.t -> expression - -(** Increment/decrement of integers *) -val incr_int : expression -> Debuginfo.t -> expression - -val decr_int : expression -> Debuginfo.t -> expression - (** Simplify the given expression knowing its last bit will be irrelevant *) val ignore_low_bit_int : expression -> expression -(** Simplify the given expression knowing its first bit will be irrelevant *) -val ignore_high_bit_int : expression -> expression - (** Arithmetical operations on integers *) val add_int : expression -> expression -> Debuginfo.t -> expression @@ -163,21 +110,6 @@ val safe_mod_bi : Debuginfo.t -> expression -(** If-Then-Else expression - - [mk_if_then_else dbg kind cond ifso_dbg ifso ifnot_dbg ifnot] associates - [dbg] to the global if-then-else expression, [ifso_dbg] to the then branch - [ifso], and [ifnot_dbg] to the else branch [ifnot] *) -val mk_if_then_else : - Debuginfo.t -> - Cmm.kind_for_unboxing -> - expression -> - Debuginfo.t -> - expression -> - Debuginfo.t -> - expression -> - expression - (** Boolean negation *) val mk_not : Debuginfo.t -> expression -> expression @@ -193,13 +125,6 @@ val mk_compare_ints_untagged : val mk_compare_floats_untagged : Debuginfo.t -> expression -> expression -> expression -(** Loop construction (while true do expr done). Used to be represented as - Cloop. *) -val create_loop : expression -> Debuginfo.t -> expression - -(** Exception raising *) -val raise_symbol : Debuginfo.t -> string -> expression - (** Convert a tagged integer into a raw integer with boolean meaning *) val test_bool : Debuginfo.t -> expression -> expression @@ -213,27 +138,14 @@ val box_vec128 : Debuginfo.t -> Lambda.alloc_mode -> expression -> expression val unbox_vec128 : Debuginfo.t -> expression -> expression -(** Complex number creation and access *) -val box_complex : Debuginfo.t -> expression -> expression -> expression - -val complex_re : expression -> Debuginfo.t -> expression - -val complex_im : expression -> Debuginfo.t -> expression - (** Make the given expression return a unit value *) val return_unit : Debuginfo.t -> expression -> expression -(** Remove a trailing unit return if any *) -val remove_unit : expression -> expression - (** Blocks *) (** Non-atomic load of a mutable field *) val mk_load_mut : memory_chunk -> operation -(** Atomic load. All atomic fields are mutable. *) -val mk_load_atomic : memory_chunk -> operation - (** [field_address ptr n dbg] returns an expression for the address of the [n]th field of the block pointed to by [ptr] *) val field_address : expression -> int -> Debuginfo.t -> expression @@ -263,68 +175,18 @@ val get_field_computed : Debuginfo.t -> expression -(** [set_field ptr n newval init dbg] returns an expression for setting the - [n]th field of the block pointed to by [ptr] to [newval] *) -val set_field : - expression -> - int -> - expression -> - initialization_or_assignment -> - Debuginfo.t -> - expression - (** Load a block's header *) val get_header : expression -> Debuginfo.t -> expression -(** Same as [get_header], but also clear all reserved bits of the result *) -val get_header_masked : expression -> Debuginfo.t -> expression - (** Load a block's tag *) val get_tag : expression -> Debuginfo.t -> expression -(** Load a block's size *) -val get_size : expression -> Debuginfo.t -> expression - (** Arrays *) val wordsize_shift : int val numfloat_shift : int -(** Check whether the given array is an array of regular OCaml values (as - opposed to unboxed floats), from its header or pointer *) -val is_addr_array_hdr : expression -> Debuginfo.t -> expression - -val is_addr_array_ptr : expression -> Debuginfo.t -> expression - -(** Get the length of an array from its header - - Shifts by one bit fewer than necessary, keeping one of the GC colour bits, - to save an operation when returning the length as a caml integer or when - comparing it to a caml integer. - Assumes that the reserved bits are clear (see get_header_masked) *) -val addr_array_length_shifted : expression -> Debuginfo.t -> expression - -val float_array_length_shifted : expression -> Debuginfo.t -> expression - -(** For [array_indexing ?typ log2size ptr ofs dbg] : - - Produces a pointer to the element of the array [ptr] on the position [ofs] - with the given element [log2size] log2 element size. [ofs] is given as a - tagged int expression. - - The optional ?typ argument is the C-- type of the result. By default, it is - Addr, meaning we are constructing a derived pointer into the heap. If we - know the pointer is outside the heap (this is the case for bigarray - indexing), we give type Int instead. *) -val array_indexing : - ?typ:machtype_component -> - int -> - expression -> - expression -> - Debuginfo.t -> - expression - (** Array loads and stores [unboxed_float_array_ref] and [float_array_ref] differ in the boxing of the @@ -366,8 +228,6 @@ val float_array_set : val string_length : expression -> Debuginfo.t -> expression -val bigstring_length : expression -> Debuginfo.t -> expression - val bigstring_get_alignment : expression -> expression -> int -> Debuginfo.t -> expression @@ -418,46 +278,6 @@ module Extended_machtype : sig val change_tagged_int_to_val : t -> machtype end -(** Objects *) - -(** Lookup a method by its hash, using [caml_get_public_method]. Arguments: - - - obj : the object from which to lookup - - - tag : the hash of the method name, as a tagged integer *) -val lookup_tag : expression -> expression -> Debuginfo.t -> expression - -(** Lookup a method by its offset in the method table. Arguments: - - - obj : the object from which to lookup - - - lab : the position of the required method in the object's method array, as - a tagged integer *) -val lookup_label : expression -> expression -> Debuginfo.t -> expression - -(** Lookup and call a method using the method cache. Arguments: - - - obj : the object from which to lookup - - - tag : the hash of the method name, as a tagged integer - - - cache : the method cache array - - - pos : the position of the cache entry in the cache array - - - args : the additional arguments to the method call *) -val call_cached_method : - expression -> - expression -> - expression -> - expression -> - expression list -> - Extended_machtype.t list -> - Extended_machtype.t -> - Clambda.apply_kind -> - Debuginfo.t -> - expression - (** Allocations *) (** Allocate a block of regular values with the given tag *) @@ -468,27 +288,6 @@ val make_alloc : val make_float_alloc : mode:Lambda.alloc_mode -> Debuginfo.t -> int -> expression list -> expression -(** Bounds checking *) - -(** Generate a [Ccheckbound] term *) -val make_checkbound : Debuginfo.t -> expression list -> expression - -(** [check_bound_and_alignment - ~skip_if_unsafe access_size dbg ~address ~length ~offset k] - Prefixes expression [k] with a check that accessing [access_size] bits at - [data + offset] is valid, unless [skip_if_unsafe] is [Unsafe]. - An access is valid if it is within the bound specified by [length], and - the resulting address is sufficiently aligned. *) -val check_bound_and_alignment : - Lambda.is_safe -> - Clambda_primitives.memory_access_size -> - Debuginfo.t -> - address:expression -> - length:expression -> - offset:expression -> - expression -> - expression - (** Sys.opaque_identity *) val opaque : expression -> Debuginfo.t -> expression @@ -513,42 +312,6 @@ val bigarray_elt_size_in_bytes : Lambda.bigarray_kind -> int bigarray. *) val bigarray_word_kind : Lambda.bigarray_kind -> memory_chunk -(** [bigarray_get unsafe kind layout b args dbg] - - - unsafe : if true, do not insert bound checks - - - kind : see [Lambda.bigarray_kind] - - - layout : see [Lambda.bigarray_layout] - - - b : the bigarray to load from - - - args : a list of tagged integer expressions, corresponding to the indices - in the respective dimensions - - - dbg : debugging information *) -val bigarray_get : - bool -> - Lambda.bigarray_kind -> - Lambda.bigarray_layout -> - expression -> - expression list -> - Debuginfo.t -> - expression - -(** [bigarray_set unsafe kind layout b args newval dbg] - - Same as [bigarray_get], with [newval] the value being assigned *) -val bigarray_set : - bool -> - Lambda.bigarray_kind -> - Lambda.bigarray_layout -> - expression -> - expression list -> - expression -> - Debuginfo.t -> - expression - (** Operations on 32-bit integers *) (** [low_32 _ x] is a value which agrees with x on at least the low 32 bits *) @@ -572,15 +335,6 @@ val sign_extend_63 : Debuginfo.t -> expression -> expression (** Zero extend from 63 bits to the word size *) val zero_extend_63 : Debuginfo.t -> expression -> expression -(** Boxed numbers *) - -(** Global symbols for the ops field of boxed integers *) -val caml_nativeint_ops : string - -val caml_int32_ops : string - -val caml_int64_ops : string - (** Box a given integer, without sharing of constants *) val box_int_gen : Debuginfo.t -> @@ -622,44 +376,10 @@ val aligned_load_128 : expression -> expression -> Debuginfo.t -> expression val aligned_set_128 : expression -> expression -> expression -> Debuginfo.t -> expression -(** Raw memory accesses *) - -(** [unaligned_set size ptr idx newval dbg] *) -val unaligned_set : - Clambda_primitives.memory_access_size -> - expression -> - expression -> - expression -> - Debuginfo.t -> - expression - -(** [unaligned_load size ptr idx dbg] *) -val unaligned_load : - Clambda_primitives.memory_access_size -> - expression -> - expression -> - Debuginfo.t -> - expression - -(** [box_sized size dbg exp] *) -val box_sized : - Clambda_primitives.memory_access_size -> - Lambda.alloc_mode -> - Debuginfo.t -> - expression -> - expression - (** Primitives *) -val simplif_primitive : - Clambda_primitives.primitive -> Clambda_primitives.primitive - type unary_primitive = expression -> Debuginfo.t -> expression -(** Return the n-th field of a float array (or float-only record), as an unboxed - float *) -val floatfield : int -> unary_primitive - (** Int_as_pointer primitive *) val int_as_pointer : unary_primitive @@ -669,12 +389,6 @@ val raise_prim : Lambda.raise_kind -> unary_primitive (** Unary negation of an OCaml integer *) val negint : unary_primitive -(** Add a constant number to an OCaml integer *) -val offsetint : int -> unary_primitive - -(** Add a constant number to an OCaml integer reference *) -val offsetref : int -> unary_primitive - (** Return the length of the array argument, as an OCaml integer *) val arraylength : Lambda.array_kind -> unary_primitive @@ -693,12 +407,6 @@ val setfield : Lambda.initialization_or_assignment -> binary_primitive -(** [setfloatfield offset init ptr value dbg] - - [value] is expected to be an unboxed floating point number *) -val setfloatfield : - int -> Lambda.initialization_or_assignment -> binary_primitive - (** Operations on OCaml integers *) val add_int_caml : binary_primitive @@ -722,36 +430,6 @@ val lsr_int_caml : binary_primitive val asr_int_caml : binary_primitive -val int_comp_caml : Lambda.integer_comparison -> binary_primitive - -(** Strings, Bytes and Bigstrings *) - -(** Regular string/bytes access. Args: string/bytes, index *) -val stringref_unsafe : binary_primitive - -val stringref_safe : binary_primitive - -(** Load by chunk from string/bytes, bigstring. Args: string, index *) -val string_load : - Clambda_primitives.memory_access_size -> - Lambda.is_safe -> - Lambda.alloc_mode -> - binary_primitive - -val bigstring_load : - Clambda_primitives.memory_access_size -> - Lambda.is_safe -> - Lambda.alloc_mode -> - binary_primitive - -(** Arrays *) - -(** Array access. Args: array, index *) -val arrayref_unsafe : Lambda.array_ref_kind -> binary_primitive - -(** Array access. Args: array, index *) -val arrayref_safe : Lambda.array_ref_kind -> binary_primitive - type ternary_primitive = expression -> expression -> expression -> Debuginfo.t -> expression @@ -762,64 +440,6 @@ val setfield_computed : Lambda.initialization_or_assignment -> ternary_primitive -(** Set the byte at the given offset to the given value. Args: bytes, index, - value *) -val bytesset_unsafe : ternary_primitive - -val bytesset_safe : ternary_primitive - -(** Set the element at the given index in the given array to the given value. - - WARNING: if [kind] is [Pfloatarray], then [value] is expected to be an - _unboxed_ float. Otherwise, it is expected to be a regular caml value, - including in the case where the array contains floats. - - Args: array, index, value *) -val arrayset_unsafe : Lambda.array_set_kind -> ternary_primitive - -(** As [arrayset_unsafe], but performs bounds-checking. *) -val arrayset_safe : Lambda.array_set_kind -> ternary_primitive - -(** Set a chunk of data in the given bytes or bigstring structure. See also - [string_load] and [bigstring_load]. - - Note: [value] is expected to be an unboxed number of the given size. - - Args: pointer, index, value *) -val bytes_set : - Clambda_primitives.memory_access_size -> Lambda.is_safe -> ternary_primitive - -val bigstring_set : - Clambda_primitives.memory_access_size -> Lambda.is_safe -> ternary_primitive - -(** Switch *) - -(** [transl_isout h arg dbg] *) -val transl_isout : expression -> expression -> Debuginfo.t -> expression - -(** [make_switch arg cases actions dbg kind] : - - Generate a Cswitch construct, or optimize as a static table lookup when - possible. *) -val make_switch : - expression -> - int array -> - (expression * Debuginfo.t) array -> - Debuginfo.t -> - Cmm.kind_for_unboxing -> - expression - -(** [transl_int_switch loc kind arg low high cases default] *) -val transl_int_switch : - Debuginfo.t -> - Cmm.kind_for_unboxing -> - expression -> - int -> - int -> - (int * expression) list -> - expression -> - expression - (** [transl_switch_clambda loc kind arg index cases] *) val transl_switch_clambda : Debuginfo.t -> @@ -829,44 +449,6 @@ val transl_switch_clambda : expression array -> expression -(** [strmatch_compile dbg arg default cases] *) -val strmatch_compile : - Debuginfo.t -> - Cmm.kind_for_unboxing -> - expression -> - expression option -> - (string * expression) list -> - expression - -(** Closures and function applications *) - -(** Adds a constant offset to a pointer (for infix access) *) -val ptr_offset : expression -> int -> Debuginfo.t -> expression - -(** Direct application of a function via a symbol *) -val direct_apply : - symbol -> - machtype -> - expression list -> - Clambda.apply_kind -> - Debuginfo.t -> - expression - -(** Generic application of a function to one or several arguments. The - mutable_flag argument annotates the loading of the code pointer from the - closure. The Cmmgen code uses a mutable load by default, with a special case - when the load is from (the first function of) the currently defined - closure. *) -val generic_apply : - Asttypes.mutable_flag -> - expression -> - expression list -> - Extended_machtype.t list -> - Extended_machtype.t -> - Clambda.apply_kind -> - Debuginfo.t -> - expression - (** Method call : [send kind met obj args dbg] - [met] is a method identifier, which can be a hashed variant or an index in @@ -884,19 +466,13 @@ val send : expression list -> Extended_machtype.t list -> Extended_machtype.t -> - Clambda.apply_kind -> + Lambda.region_close * Lambda.alloc_mode -> Debuginfo.t -> expression (** Construct [Cregion e], eliding some useless regions *) val region : expression -> expression -(** Generic Cmm fragments *) - -val placeholder_dbg : unit -> Debuginfo.t - -val placeholder_fun_dbg : human_name:string -> Debuginfo.t - (** Entry point *) val entry_point : Compilation_unit.t list -> phrase list @@ -956,18 +532,6 @@ val emit_vec128_constant : val emit_float_array_constant : symbol -> float list -> data_item list -> data_item list -val fundecls_size : Clambda.ufunction list -> int - -val emit_constant_closure : - symbol -> - Clambda.ufunction list -> - data_item list -> - data_item list -> - data_item list - -val emit_preallocated_blocks : - Clambda.preallocated_block list -> phrase list -> phrase list - (** {1} Helper functions and values used by Flambda 2. *) (** An adequate Cmm machtype for an int64 (including on a 32-bit target). *) @@ -1327,3 +891,5 @@ val atomic_compare_and_set : old_value:expression -> new_value:expression -> expression + +val emit_gc_roots_table : symbols:symbol list -> phrase list -> phrase list diff --git a/backend/cmmgen.ml b/backend/cmmgen.ml deleted file mode 100644 index 6edae7ee6ef..00000000000 --- a/backend/cmmgen.ml +++ /dev/null @@ -1,1887 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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 from closed lambda to C-- *) - -[@@@ocaml.warning "-40"] - -open Misc -open Asttypes -open Primitive -open Types -open Lambda -open Clambda -open Clambda_primitives -open Cmm - -module String = Misc.Stdlib.String -module IntMap = Map.Make(Int) -module V = Backend_var -module VP = Backend_var.With_provenance -open Cmm_helpers -open Cmm_builtins - -(* Environments used for translation to Cmm. *) - -type boxed_number = - | Boxed_float of alloc_mode * Debuginfo.t - | Boxed_integer of boxed_integer * alloc_mode * Debuginfo.t - | Boxed_vector of boxed_vector * alloc_mode * Debuginfo.t - -type env = { - unboxed_ids : (V.t * boxed_number) V.tbl; - notify_catch : (Cmm.expression list -> unit) IntMap.t; - environment_param : V.t option; - trywith_depth : int; - catch_trywith_depths : int IntMap.t; -} - -(* notify_catch associates to each catch handler a callback - which will be passed the list of arguments of each - staticfail instruction pointing to that handler. This - allows transl_catch to observe concrete arguments passed to each - handler parameter and decide whether to unbox them accordingly. - - Other ways to achieve the same result would be to either (1) traverse - the body of the catch block after translation (this would be costly - and could easily lead to quadratric behavior) or (2) return - a description of arguments passed to each catch handler as an extra - value to be threaded through all transl_* functions (this would be - quite heavy, and probably less efficient that the callback approach). -*) - - -let empty_env = - { - unboxed_ids = V.empty; - notify_catch = IntMap.empty; - environment_param = None; - trywith_depth = 0; - catch_trywith_depths = IntMap.empty; - } - -let create_env ~environment_param = - { empty_env with - environment_param; - } - -let is_unboxed_id id env = - try Some (V.find_same id env.unboxed_ids) - with Not_found -> None - -let add_unboxed_id id unboxed_id bn env = - { env with - unboxed_ids = V.add id (unboxed_id, bn) env.unboxed_ids; - } - -let add_notify_catch n f env = - { env with - notify_catch = IntMap.add n f env.notify_catch; - } - -let notify_catch i env l = - match IntMap.find_opt i env.notify_catch with - | Some f -> f l - | None -> () - -let incr_depth env = - { env with trywith_depth = succ env.trywith_depth; } - -let enter_catch_body env nfail = - { env with - catch_trywith_depths = - IntMap.add nfail env.trywith_depth env.catch_trywith_depths; - } - -let mk_traps env nfail = - let catch_trywith_depths_inverse = - env.catch_trywith_depths - |> IntMap.to_seq - |> Seq.map (fun (nfail, depth) -> depth, nfail) - |> IntMap.of_seq - in - let handler_depth = - match IntMap.find_opt nfail env.catch_trywith_depths with - | None -> Misc.fatal_errorf "Cmmgen.mk_traps: Unknown handler %d" nfail - | Some d -> d - in - if handler_depth = env.trywith_depth then [] - else begin - assert (handler_depth <= env.trywith_depth); - List.init (env.trywith_depth - handler_depth) - (fun offset -> - let depth = handler_depth + offset in - match IntMap.find depth catch_trywith_depths_inverse with - | exception Not_found -> - Misc.fatal_errorf "No exception handler for depth %d" depth - | nfail -> Pop (Pop_specific nfail)) - end - -(* Description of the "then" and "else" continuations in [transl_if]. If - the "then" continuation is true and the "else" continuation is false then - we can use the condition directly as the result. Similarly, if the "then" - continuation is false and the "else" continuation is true then we can use - the negation of the condition directly as the result. *) -type then_else = - | Then_true_else_false - | Then_false_else_true - | Unknown - -let invert_then_else = function - | Then_true_else_false -> Then_false_else_true - | Then_false_else_true -> Then_true_else_false - | Unknown -> Unknown - -let mut_from_env env ptr = - match env.environment_param with - | None -> Asttypes.Mutable - | Some environment_param -> - match ptr with - | Cvar ptr -> - (* Loads from the current function's closure are immutable. *) - if V.same environment_param ptr then Asttypes.Immutable - else Asttypes.Mutable - | _ -> Asttypes.Mutable - -(* Minimum of two [mutable_flag] values, assuming [Immutable < Mutable]. *) -let min_mut x y = - match x,y with - | Asttypes.Immutable, _ - | _, Asttypes.Immutable -> Asttypes.Immutable - | Asttypes.Mutable, Asttypes.Mutable -> Asttypes.Mutable - -let mut_from_lambda = function - | Lambda.Immutable -> Asttypes.Immutable - | Lambda.Immutable_unique -> Asttypes.Immutable - | Lambda.Mutable -> Asttypes.Mutable - -let get_field env mut layout ptr n dbg = - let mut = if Config.runtime5 - then min_mut (mut_from_lambda mut) (mut_from_env env ptr) - else mut_from_env env ptr in - let memory_chunk = - match layout with - | Pvalue Pintval | Punboxed_int _ -> Word_int - | Pvalue _ -> Word_val - | Punboxed_float -> Double - | Punboxed_vector (Pvec128 _) -> - (* Record fields are not 16-byte aligned. *) - Onetwentyeight_unaligned - | Punboxed_product _ -> - Misc.fatal_error "Unboxed products cannot be stored as fields for now." - | Ptop -> - Misc.fatal_errorf "get_field with Ptop: %a" Debuginfo.print_compact dbg - | Pbottom -> - Misc.fatal_errorf "get_field with Pbottom: %a" Debuginfo.print_compact - dbg - in - get_field_gen_given_memory_chunk memory_chunk mut ptr n dbg - -type rhs_kind = - | RHS_block of Lambda.alloc_mode * int - | RHS_infix of { blocksize : int; offset : int; blockmode: Lambda.alloc_mode } - | RHS_floatblock of Lambda.alloc_mode * int - | RHS_nonrec - -let rec expr_size env = function - | Uvar id -> - begin try V.find_same id env with Not_found -> RHS_nonrec end - | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> - (* should all have the same mode *) - let fn_mode = (List.hd functions).mode in - List.iter (fun f -> assert (Lambda.eq_mode fn_mode f.mode)) functions; - RHS_block (fn_mode, - fundecls_size functions + List.length not_scanned_slots - + List.length scanned_slots) - | Ulet(_str, _kind, id, exp, body) -> - expr_size (V.add (VP.var id) (expr_size env exp) env) body - | Uletrec(bindings, body) -> - let env = - List.fold_right - (fun (id, exp) env -> V.add (VP.var id) (expr_size env exp) env) - bindings env - in - expr_size env body - | Uprim(Pmakeblock (_, _, _, mode), args, _) -> - RHS_block (mode, List.length args) - | Uprim(Pmakeufloatblock (_, mode), args, _) -> - RHS_floatblock (mode, List.length args) - | Uprim(Pmakearray((Paddrarray | Pintarray), _, mode), args, _) -> - RHS_block (mode, List.length args) - | Uprim(Pmakearray(Pfloatarray, _, mode), args, _) -> - RHS_floatblock (mode, List.length args) - | Uprim(Pmakearray(Pgenarray, _, _mode), _, _) -> - (* Pgenarray is excluded from recursive bindings by the - check in Translcore.check_recursive_lambda *) - RHS_nonrec - | Uprim (Pduprecord ((Record_boxed _ | Record_inlined (_, Variant_boxed _)), - sz), _, _) -> - RHS_block (Lambda.alloc_heap, sz) - | Uprim (Pduprecord ((Record_unboxed - | Record_inlined (_, Variant_unboxed)), - _), _, _) -> - assert false - | Uprim (Pduprecord (Record_inlined (_, Variant_extensible), sz), _, _) -> - RHS_block (Lambda.alloc_heap, sz + 1) - | Uprim (Pduprecord ((Record_float | Record_ufloat), sz), _, _) -> - RHS_floatblock (Lambda.alloc_heap, sz) - | Uprim (Pccall { prim_name; _ }, closure::_, _) - when prim_name = "caml_check_value_is_closure" -> - (* Used for "-clambda-checks". *) - expr_size env closure - | Usequence(_exp, exp') -> - expr_size env exp' - | Uoffset (exp, offset) -> - (match expr_size env exp with - | RHS_block (blockmode, blocksize) -> - RHS_infix { blocksize; offset; blockmode } - | RHS_nonrec -> RHS_nonrec - | _ -> assert false) - | Uregion exp -> - expr_size env exp - | Uexclave exp -> - expr_size env exp - | _ -> RHS_nonrec - -(* Translate structured constants to Cmm data items *) - -let const_symbol sym_name = - { sym_name; - sym_global = - match Cmmgen_state.get_structured_constant sym_name with - | None -> Global - | Some (g, _) -> g } - - -let transl_constant dbg = function - | Uconst_int n -> - int_const dbg n - | Uconst_ref (label, def_opt) -> - Option.iter - (fun def -> Cmmgen_state.add_global_structured_constant label def) - def_opt; - Cconst_symbol (const_symbol label, dbg) - -let emit_constant cst cont = - match cst with - | Uconst_int n -> - cint_const n - :: cont - | Uconst_ref (sym, _) -> - Csymbol_address (const_symbol sym) :: cont - -let emit_structured_constant symb cst cont = - match cst with - | Uconst_float s -> - emit_float_constant symb s cont - | Uconst_string s -> - emit_string_constant symb s cont - | Uconst_int32 n -> - emit_int32_constant symb n cont - | Uconst_int64 n -> - emit_int64_constant symb n cont - | Uconst_nativeint n -> - emit_nativeint_constant symb n cont - | Uconst_vec128 {high; low} -> - emit_vec128_constant symb {high; low} cont - | Uconst_block (tag, csts) -> - let cont = List.fold_right emit_constant csts cont in - emit_block symb (block_header tag (List.length csts)) cont - | Uconst_float_array fields -> - emit_float_array_constant symb fields cont - | Uconst_closure(fundecls, lbl, fv) -> - Cmmgen_state.add_constant lbl (Const_closure (symb.sym_global, fundecls, fv)); - List.iter (fun f -> Cmmgen_state.add_function f) fundecls; - cont - -(* Boxed integers *) - -let box_int_constant sym_name bi n = - let sym = { sym_name; sym_global = Local } in - match bi with - Pnativeint -> - emit_nativeint_constant sym n [], sym - | Pint32 -> - let n = Nativeint.to_int32 n in - emit_int32_constant sym n [], sym - | Pint64 -> - let n = Int64.of_nativeint n in - emit_int64_constant sym n [], sym - -let box_int dbg bi mode arg = - match arg with - | Cconst_int (n, _) -> - let sym = Compilenv.new_const_symbol () in - let data_items, sym = box_int_constant sym bi (Nativeint.of_int n) in - Cmmgen_state.add_data_items data_items; - Cconst_symbol (sym, dbg) - | Cconst_natint (n, _) -> - let sym = Compilenv.new_const_symbol () in - let data_items, sym = box_int_constant sym bi n in - Cmmgen_state.add_data_items data_items; - Cconst_symbol (sym, dbg) - | _ -> - box_int_gen dbg bi mode arg - -(* Boxed numbers *) - -let typ_of_boxed_number = function - | Boxed_float _ -> Cmm.typ_float - | Boxed_integer _ -> Cmm.typ_int - | Boxed_vector (Pvec128 _, _, _) -> Cmm.typ_vec128 - -let equal_unboxed_integer ui1 ui2 = - match ui1, ui2 with - | Pnativeint, Pnativeint -> true - | Pint32, Pint32 -> true - | Pint64, Pint64 -> true - | _, _ -> false - -let equal_boxed_number bn1 bn2 = - match bn1, bn2 with - | Boxed_float _, Boxed_float _ -> true - | Boxed_integer(ui1, m, _), Boxed_integer(ui2, m', _) -> - equal_unboxed_integer ui1 ui2 && Lambda.eq_mode m m' - | _, _ -> false - -let box_number bn arg = - match bn with - | Boxed_float (m, dbg) -> box_float dbg m arg - | Boxed_integer (bi, m, dbg) -> box_int dbg bi m arg - | Boxed_vector (Pvec128 _, m, dbg) -> box_vec128 dbg m arg - -(* Returns the unboxed representation of a boxed float or integer. - For Pint32 on 64-bit archs, the high 32 bits of the result are undefined. *) -let unbox_number dbg bn arg = - match bn with - | Boxed_float (_, dbg) -> - unbox_float dbg arg - | Boxed_integer (Pint32, _, _) -> - low_32 dbg (unbox_int dbg Pint32 arg) - | Boxed_integer (bi, _, _) -> - unbox_int dbg bi arg - | Boxed_vector (Pvec128 _, _, _) -> - unbox_vec128 dbg arg - -(* Auxiliary functions for optimizing "let" of boxed numbers (floats and - boxed integers *) - -type unboxed_number_kind = - No_unboxing - | Boxed of boxed_number * bool (* true: boxed form available at no cost *) - | No_result (* expression never returns a result *) - -(* Given unboxed_number_kind from two branches of the code, returns the - resulting unboxed_number_kind. - - If [strict=false], one knows that the type of the expression - is an unboxable number, and we decide to return an unboxed value - if this indeed eliminates at least one allocation. - - If [strict=true], we need to ensure that all possible branches - return an unboxable number (of the same kind). This could not - be the case in presence of GADTs. -*) -let join_unboxed_number_kind ~strict k1 k2 = - match k1, k2 with - | Boxed (b1, c1), Boxed (b2, c2) when equal_boxed_number b1 b2 -> - Boxed (b1, c1 && c2) - | No_result, k | k, No_result -> - k (* if a branch never returns, it is safe to unbox it *) - | No_unboxing, k | k, No_unboxing when not strict -> - k - | _, _ -> No_unboxing - -let is_strict : kind_for_unboxing -> bool = function - | Boxed_integer _ | Boxed_float | Boxed_vector _ -> false - | Any -> true - -(* [exttype_of_sort] and [machtype_of_sort] should be kept in sync with - [Typeopt.layout_of_const_sort]. *) -(* CR layouts v5: Void case should probably be typ_void *) -let exttype_of_sort (s : Jkind.Sort.const) = - match s with - | Value -> XInt - | Float64 -> XFloat - | Void -> Misc.fatal_error "Cmmgen.exttype_of_sort: void encountered" - -let machtype_of_sort (s : Jkind.Sort.const) = - match s with - | Value -> typ_val - | Float64 -> typ_float - | Void -> Misc.fatal_error "Cmmgen.machtype_of_sort: void encountered" - -let rec is_unboxed_number_cmm = function - | Cop(Calloc mode, [Cconst_natint (hdr, _); _], dbg) - when Nativeint.equal hdr float_header -> - Boxed (Boxed_float (mode, dbg), false) - | Cop(Calloc mode, [Cconst_natint (hdr, _); Cconst_symbol (ops, _); _], dbg) -> - if Nativeint.equal hdr boxedintnat_header - && String.equal ops.sym_name caml_nativeint_ops - then - Boxed (Boxed_integer (Pnativeint, mode, dbg), false) - else - if Nativeint.equal hdr boxedint32_header - && String.equal ops.sym_name caml_int32_ops - then - Boxed (Boxed_integer (Pint32, mode, dbg), false) - else - if Nativeint.equal hdr boxedint64_header - && String.equal ops.sym_name caml_int64_ops - then - Boxed (Boxed_integer (Pint64, mode, dbg), false) - else - No_unboxing - | Cconst_symbol (s, _) -> - begin match Cmmgen_state.structured_constant_of_sym s.sym_name with - | Some (Uconst_float _) -> - Boxed (Boxed_float (alloc_heap, Debuginfo.none), true) - | Some (Uconst_nativeint _) -> - Boxed (Boxed_integer (Pnativeint, alloc_heap, Debuginfo.none), true) - | Some (Uconst_int32 _) -> - Boxed (Boxed_integer (Pint32, alloc_heap, Debuginfo.none), true) - | Some (Uconst_int64 _) -> - Boxed (Boxed_integer (Pint64, alloc_heap, Debuginfo.none), true) - | Some (Uconst_vec128 _) -> - Boxed (Boxed_vector (Pvec128 Unknown128, alloc_heap, Debuginfo.none), true) - | _ -> - No_unboxing - end - | Cexit _ | Cop (Craise _, _, _) -> No_result - | Csequence (_, a) | Cregion a | Ctail a - | Clet (_, _, a) | Cphantom_let (_, _, a) | Clet_mut (_, _, _, a) -> - is_unboxed_number_cmm a - | Cconst_int _ - | Cconst_natint _ - | Cconst_float _ - | Cconst_vec128 _ - | Cvar _ - | Cassign _ - | Ctuple _ - | Cop _ -> No_unboxing - | Cifthenelse (_, _, a, _, b, _, kind) -> - join_unboxed_number_kind ~strict:(is_strict kind) - (is_unboxed_number_cmm a) - (is_unboxed_number_cmm b) - | Cswitch (_, _, cases, _, kind) -> - let cases = Array.map (fun (x, _) -> is_unboxed_number_cmm x) cases in - let strict = is_strict kind in - Array.fold_left (join_unboxed_number_kind ~strict) No_result cases - | Ctrywith (a, _, _, b, _, kind) -> - join_unboxed_number_kind ~strict:(is_strict kind) - (is_unboxed_number_cmm a) - (is_unboxed_number_cmm b) - | Ccatch (_, handlers, body, kind) -> - let strict = is_strict kind in - List.fold_left - (join_unboxed_number_kind ~strict) - (is_unboxed_number_cmm body) - (List.map (fun (_, _, e, _, _) -> is_unboxed_number_cmm e) handlers) - -(* Translate an expression *) - -let rec transl env e = - match e with - Uvar id -> - begin match is_unboxed_id id env with - | None -> Cvar id - | Some (unboxed_id, bn) -> box_number bn (Cvar unboxed_id) - end - | Uconst sc -> - transl_constant Debuginfo.none sc - | Uclosure { functions ; not_scanned_slots = [] ; scanned_slots = [] } -> - let sym = Compilenv.new_const_symbol() in - Cmmgen_state.add_constant sym (Const_closure (Local, functions, [])); - List.iter (fun f -> Cmmgen_state.add_function f) functions; - let dbg = - match functions with - | [] -> Debuginfo.none - | fundecl::_ -> fundecl.dbg - in - Cconst_symbol ({sym_name=sym; sym_global=Local}, dbg) - | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> - let startenv = fundecls_size functions + List.length not_scanned_slots in - let mode = - Option.get @@ - List.fold_left (fun s { mode; dbg; _ } -> - match s with - | None -> Some mode - | Some m' -> - if not (Lambda.eq_mode mode m') then - Misc.fatal_errorf "Inconsistent modes in let rec at %s" - (Debuginfo.to_string dbg); - s) None functions in - let rec transl_fundecls pos = function - [] -> - List.map (transl env) (not_scanned_slots @ scanned_slots) - | f :: rem -> - let is_last = match rem with [] -> true | _::_ -> false in - Cmmgen_state.add_function f; - let dbg = f.dbg in - let without_header = - match f.arity with - | { function_kind = Curried _ ; params_layout = ([] | [_]) } as arity -> - Cconst_symbol ({sym_name=f.label; sym_global=Local}, dbg) :: - alloc_closure_info ~arity - ~startenv:(startenv - pos) ~is_last dbg :: - transl_fundecls (pos + 3) rem - | arity -> - Cconst_symbol - ((curry_function_sym - arity.function_kind - (List.map machtype_of_layout_changing_tagged_int_to_val - arity.params_layout) - (machtype_of_layout_changing_tagged_int_to_val - arity.return_layout)), - dbg) :: - alloc_closure_info ~arity - ~startenv:(startenv - pos) ~is_last dbg :: - Cconst_symbol ({sym_name=f.label; sym_global=Local}, dbg) :: - transl_fundecls (pos + 4) rem - in - if pos = 0 - then without_header - else alloc_infix_header pos f.dbg :: without_header - in - let dbg = - match functions with - | [] -> Debuginfo.none - | fundecl::_ -> fundecl.dbg - in - (* #11482, #12481: the 'clos_vars' may be arbitrary expressions - and may invoke the GC, which would be able to observe the - partially-filled block. This is safe because 'make_alloc' - evaluates and fills fields from left to right, and does not - call a GC between the allocation and filling fields. So the - closure metadata, which comes before the closure variables, - will always have been written before a GC can happen. *) - make_alloc ~mode dbg Obj.closure_tag (transl_fundecls 0 functions) - | Uoffset(arg, offset) -> - (* produces a valid Caml value, pointing just after an infix header *) - let ptr = transl env arg in - let dbg = Debuginfo.none in - ptr_offset ptr offset dbg - | Udirect_apply(handler_code_sym, args, Some { name; enabled_at_init }, _, _, dbg) -> - let args = List.map (transl env) args in - return_unit dbg - (Cop(Cprobe { name; handler_code_sym; enabled_at_init }, args, dbg)) - | Udirect_apply(lbl, args, None, result_layout, kind, dbg) -> - let args = List.map (transl env) args in - let sym = - { sym_name = lbl; - sym_global = if Cmmgen_state.is_local_function lbl then Local else Global } - in - direct_apply sym (machtype_of_layout result_layout) args kind dbg - | Ugeneric_apply(clos, args, args_layout, result_layout, kind, dbg) -> - let clos = transl env clos in - let args = List.map (transl env) args in - if List.mem Pbottom args_layout then - (* [Extended_machtype.of_layout] will fail on Pbottom, convert it to a - sequence and remove the call, preserving the execution order. *) - List.fold_left2 (fun rest arg arg_layout -> - if arg_layout = Pbottom then - arg - else - Csequence(remove_unit arg, rest) - ) (Ctuple []) args args_layout - else - let args_type = List.map Extended_machtype.of_layout args_layout in - let return = Extended_machtype.of_layout result_layout in - generic_apply (mut_from_env env clos) clos args args_type return kind dbg - | Usend(kind, met, obj, args, args_layout, result_layout, pos, dbg) -> - let met = transl env met in - let obj = transl env obj in - let args = List.map (transl env) args in - let args_type = List.map Extended_machtype.of_layout args_layout in - let return = Extended_machtype.of_layout result_layout in - send kind met obj args args_type return pos dbg - | Ulet(str, kind, id, exp, body) -> - transl_let env str kind id exp (fun env -> transl env body) - | Uphantom_let (var, defining_expr, body) -> - let defining_expr = - match defining_expr with - | None -> None - | Some defining_expr -> - let defining_expr = - match defining_expr with - | Uphantom_const (Uconst_ref (sym, _defining_expr)) -> - Cphantom_const_symbol sym - | Uphantom_read_symbol_field { sym; field; } -> - Cphantom_read_symbol_field { sym; field; } - | Uphantom_const (Uconst_int i) -> - Cphantom_const_int (targetint_const i) - | Uphantom_var var -> Cphantom_var var - | Uphantom_read_field { var; field; } -> - Cphantom_read_field { var; field; } - | Uphantom_offset_var { var; offset_in_words; } -> - Cphantom_offset_var { var; offset_in_words; } - | Uphantom_block { tag; fields; } -> - Cphantom_block { tag; fields; } - in - Some defining_expr - in - Cphantom_let (var, defining_expr, transl env body) - | Uletrec(bindings, body) -> - transl_letrec env bindings (transl env body) - - (* Primitives *) - | Uprim(prim, args, dbg) -> - begin match (simplif_primitive prim, args) with - | (Pmake_unboxed_product _layouts, args) -> - Ctuple (List.map (transl env) args) - | (Pread_symbol sym, []) -> - Cconst_symbol (global_symbol sym, dbg) - | ((Pmakeblock _ | Pmakeufloatblock _), []) -> - assert false - | (Pmakeblock(tag, _mut, _kind, mode), args) -> - make_alloc ~mode dbg tag (List.map (transl env) args) - | (Pmakeufloatblock(_mut, mode), args) -> - make_float_alloc ~mode dbg Obj.double_array_tag - (List.map (transl env) args) - | (Pccall prim, args) -> - transl_ccall env prim args dbg - | (Pduparray (kind, _), [Uprim (Pmakearray (kind', _, _), args, _dbg)]) -> - (* We arrive here in two cases: - 1. When using Closure, all the time. - 2. When using Flambda, if a float array longer than - [Translcore.use_dup_for_constant_arrays_bigger_than] turns out - to be non-constant. - If for some reason Flambda fails to lift a constant array we - could in theory also end up here. - Note that [kind] above is unconstrained, but with the current - state of [Translcore], we will in fact only get here with - [Pfloatarray]s. *) - assert (kind = kind'); - transl_make_array dbg env kind alloc_heap args - | (Pduparray _, [arg]) -> - let prim_obj_dup = - Primitive.simple_on_values ~name:"caml_obj_dup" ~arity:1 ~alloc:true - in - transl_ccall env prim_obj_dup [arg] dbg - | (Pmakearray _, []) -> - Misc.fatal_error "Pmakearray is not allowed for an empty array" - | (Pmakearray (kind, _, mode), args) -> - transl_make_array dbg env kind mode args - | (Pbigarrayref(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) -> - let elt = - bigarray_get unsafe elt_kind layout - (transl env arg1) (List.map (transl env) argl) dbg in - begin match elt_kind with - (* TODO: local allocation of bigarray elements *) - Pbigarray_float32 | Pbigarray_float64 -> box_float dbg alloc_heap elt - | Pbigarray_complex32 | Pbigarray_complex64 -> elt - | Pbigarray_int32 -> box_int dbg Pint32 alloc_heap elt - | Pbigarray_int64 -> box_int dbg Pint64 alloc_heap elt - | Pbigarray_native_int -> box_int dbg Pnativeint alloc_heap elt - | Pbigarray_caml_int -> tag_int elt dbg - | Pbigarray_sint8 | Pbigarray_uint8 - | Pbigarray_sint16 | Pbigarray_uint16 -> tag_int elt dbg - | Pbigarray_unknown -> assert false - end - | (Pbigarrayset(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) -> - let (argidx, argnewval) = split_last argl in - return_unit dbg (bigarray_set unsafe elt_kind layout - (transl env arg1) - (List.map (transl env) argidx) - (match elt_kind with - Pbigarray_float32 | Pbigarray_float64 -> - transl_unbox_float dbg env argnewval - | Pbigarray_complex32 | Pbigarray_complex64 -> transl env argnewval - | Pbigarray_int32 -> transl_unbox_int dbg env Pint32 argnewval - | Pbigarray_int64 -> transl_unbox_int dbg env Pint64 argnewval - | Pbigarray_native_int -> - transl_unbox_int dbg env Pnativeint argnewval - | Pbigarray_caml_int -> - untag_int (transl env argnewval) dbg - | Pbigarray_sint8 | Pbigarray_uint8 - | Pbigarray_sint16 | Pbigarray_uint16 -> - ignore_high_bit_int (untag_int (transl env argnewval) dbg) - | Pbigarray_unknown -> assert false) - dbg) - | (Pbigarraydim(n), [b]) -> - let dim_ofs = 4 + n in - tag_int (Cop(mk_load_mut Word_int, - [field_address (transl env b) dim_ofs dbg], - dbg)) dbg - | (Pprobe_is_enabled {name}, []) -> - tag_int (Cop(Cprobe_is_enabled {name}, [], dbg)) dbg - | (p, [arg]) -> - transl_prim_1 env p arg dbg - | (p, [arg1; arg2]) -> - transl_prim_2 env p arg1 arg2 dbg - | (p, [arg1; arg2; arg3]) -> - transl_prim_3 env p arg1 arg2 arg3 dbg - | (Pread_symbol _, _::_::_::_::_) - | (Pbigarrayset (_, _, _, _), []) - | (Pbigarrayref (_, _, _, _), []) - | ((Pbigarraydim _ | Pduparray (_, _)), ([] | _::_::_::_::_)) - | (Pprobe_is_enabled _, _) - -> - fatal_error "Cmmgen.transl:prim, wrong arity" - | ((Pfield_computed|Psequand - | Prunstack | Pperform | Presume | Preperform - | Pdls_get - | Patomic_load _ | Patomic_exchange - | Patomic_cas | Patomic_fetch_add - | Psequor | Pnot | Pnegint | Paddint | Psubint - | Pmulint | Pandint | Porint | Pxorint | Plslint - | Plsrint | Pasrint | Pintoffloat | Pfloatofint _ - | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ - | Pmulfloat _ | Pdivfloat _ | Pstringlength | Pstringrefu - | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu - | Pbytesrefs | Pbytessets | Pisint | Pisout - | Pbswap16 | Pint_as_pointer _ | Popaque | Pfield _ - | Psetfield (_, _, _) | Psetfield_computed (_, _) - | Pfloatfield _ | Psetfloatfield (_, _) | Pduprecord (_, _) - | Pufloatfield _ | Psetufloatfield (_, _) - | Praise _ | Pdivint _ | Pmodint _ | Pintcomp _ | Poffsetint _ - | Pcompare_ints | Pcompare_floats | Pcompare_bints _ - | Poffsetref _ | Pfloatcomp _ | Punboxed_float_comp _ | Parraylength _ - | Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _ - | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ - | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ - | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ - | Pasrbint _ | Pbintcomp (_, _) | Pstring_load _ | Pbytes_load _ - | Pbytes_set _ | Pbigstring_load _ | Pbigstring_set _ - | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _ - | Punboxed_product_field _ | Pbbswap _ | Pget_header _), _) - -> - fatal_error "Cmmgen.transl:prim" - end - - (* Control structures *) - | Uswitch(arg, s, dbg, kind) -> - (* As in the bytecode interpreter, only matching against constants - can be checked *) - if Array.length s.us_index_blocks = 0 then - make_switch - (untag_int (transl env arg) dbg) - s.us_index_consts - (Array.map (fun expr -> transl env expr, dbg) s.us_actions_consts) - dbg (kind_of_layout kind) - else if Array.length s.us_index_consts = 0 then - bind "switch" (transl env arg) (fun arg -> - transl_switch dbg (kind_of_layout kind) env (get_tag arg dbg) - s.us_index_blocks s.us_actions_blocks) - else - bind "switch" (transl env arg) (fun arg -> - Cifthenelse( - Cop(Cand, [arg; Cconst_int (1, dbg)], dbg), - dbg, - transl_switch dbg (kind_of_layout kind) env - (untag_int arg dbg) s.us_index_consts s.us_actions_consts, - dbg, - transl_switch dbg (kind_of_layout kind) env - (get_tag arg dbg) s.us_index_blocks s.us_actions_blocks, - dbg, kind_of_layout kind)) - | Ustringswitch(arg,sw,d, kind) -> - let dbg = Debuginfo.none in - bind "switch" (transl env arg) - (fun arg -> - strmatch_compile dbg (kind_of_layout kind) arg (Option.map (transl env) d) - (List.map (fun (s,act) -> s,transl env act) sw)) - | Ustaticfail (nfail, args) -> - let cargs = List.map (transl env) args in - notify_catch nfail env cargs; - let traps = mk_traps env nfail in - Cexit (Lbl nfail, cargs, traps) - | Ucatch(nfail, [], body, handler, kind) -> - let dbg = Debuginfo.none in - let env_body = enter_catch_body env nfail in - make_catch (kind_of_layout kind) nfail - (transl env_body body) - (transl env handler) dbg - | Ucatch(nfail, ids, body, handler, kind) -> - let dbg = Debuginfo.none in - transl_catch (kind_of_layout kind) env nfail ids body handler dbg - | Utrywith(body, exn, handler, kind) -> - let dbg = Debuginfo.none in - let new_body = transl (incr_depth env) body in - Ctrywith(new_body, Regular, exn, transl env handler, dbg, kind_of_layout kind) - | Uifthenelse(cond, ifso, ifnot, kind) -> - let ifso_dbg = Debuginfo.none in - let ifnot_dbg = Debuginfo.none in - let dbg = Debuginfo.none in - transl_if env (kind_of_layout kind) Unknown dbg cond - ifso_dbg (transl env ifso) ifnot_dbg (transl env ifnot) - | Usequence(exp1, exp2) -> - Csequence(remove_unit(transl env exp1), transl env exp2) - | Uwhile(cond, body) -> - let dbg = Debuginfo.none in - let raise_num = next_raise_count () in - return_unit dbg - (ccatch - (raise_num, [], - create_loop(transl_if env Any Unknown dbg cond - dbg (remove_unit(transl env body)) - dbg (Cexit (Lbl raise_num,[],[])) - ) - dbg, - Ctuple [], - dbg, Any, false)) - | Ufor(id, low, high, dir, body) -> - let dbg = Debuginfo.none in - let tst = match dir with Upto -> Cgt | Downto -> Clt in - let inc = match dir with Upto -> Caddi | Downto -> Csubi in - let raise_num = next_raise_count () in - let id_prev = VP.create (V.create_local "*id_prev*") in - return_unit dbg - (Clet_mut - (id, typ_int, transl env low, - bind_nonvar "bound" (transl env high) (fun high -> - ccatch - (raise_num, [], - Cifthenelse - (Cop(Ccmpi tst, [Cvar (VP.var id); high], dbg), - dbg, - Cexit (Lbl raise_num, [], []), - dbg, - create_loop - (Csequence - (remove_unit(transl env body), - Clet(id_prev, Cvar (VP.var id), - Csequence - (Cassign(VP.var id, - Cop(inc, [Cvar (VP.var id); Cconst_int (2, dbg)], - dbg)), - Cifthenelse - (Cop(Ccmpi Ceq, [Cvar (VP.var id_prev); high], - dbg), - dbg, Cexit (Lbl raise_num,[],[]), - dbg, Ctuple [], - dbg, Any))))) - dbg, - dbg, Any), - Ctuple [], - dbg, Any, false)))) - | Uassign(id, exp) -> - let dbg = Debuginfo.none in - let cexp = transl env exp in - begin match is_unboxed_id id env with - | None -> - return_unit dbg (Cassign(id, cexp)) - | Some (unboxed_id, bn) -> - return_unit dbg (Cassign(unboxed_id, unbox_number dbg bn cexp)) - end - | Uunreachable -> - let dbg = Debuginfo.none in - Cop(mk_load_mut Word_int, [Cconst_int (0, dbg)], dbg) - | Uregion e -> - region (transl env e) - | Uexclave e -> - Ctail (transl env e) - -and transl_catch (kind : Cmm.kind_for_unboxing) env nfail ids body handler dbg = - let ids = List.map (fun (id, kind) -> (id, kind, ref No_result)) ids in - (* Translate the body, and while doing so, collect the "unboxing type" for - each argument. *) - let report args = - List.iter2 - (fun (_id, layout, u) c -> - let strict = is_strict (kind_of_layout layout) in - u := join_unboxed_number_kind ~strict !u - (is_unboxed_number_cmm c) - ) - ids args - in - let env_body = enter_catch_body (add_notify_catch nfail report env) nfail in - let body = transl env_body body in - let new_env, rewrite, ids = - List.fold_right - (fun (id, layout, u) (env, rewrite, ids) -> - match !u with - | No_unboxing | Boxed (_, true) | No_result -> - env, - (fun x -> x) :: rewrite, - (id, machtype_of_layout layout) :: ids - | Boxed (bn, false) -> - let unboxed_id = V.create_local (VP.name id) in - add_unboxed_id (VP.var id) unboxed_id bn env, - (unbox_number Debuginfo.none bn) :: rewrite, - (VP.create unboxed_id, typ_of_boxed_number bn) :: ids - ) - ids (env, [], []) - in - if env == new_env then - (* No unboxing *) - ccatch (nfail, ids, body, transl env handler, dbg, kind, false) - else - (* allocate new "nfail" to catch errors more easily *) - let new_nfail = next_raise_count () in - let body = - (* Rewrite the body to unbox the call sites *) - let rec aux e = - match Cmm.map_shallow aux e with - | Cexit (Lbl n, el, traps) when n = nfail -> - Cexit (Lbl new_nfail, List.map2 (fun f e -> f e) rewrite el, traps) - | c -> c - in - aux body - in - ccatch (new_nfail, ids, body, transl new_env handler, dbg, kind, false) - -and transl_make_array dbg env kind mode args = - match kind with - | Pgenarray -> - let func = - match (mode : Lambda.alloc_mode) with - | Alloc_heap -> "caml_make_array" - | Alloc_local -> "caml_make_array_local" - in - Cop(Cextcall { func; - builtin = false; - returns = true; - effects = Arbitrary_effects; - coeffects = Has_coeffects; - ty = typ_val; alloc = true; ty_args = []}, - [make_alloc ~mode dbg 0 (List.map (transl env) args)], dbg) - | Paddrarray | Pintarray -> - make_alloc ~mode dbg 0 (List.map (transl env) args) - | Pfloatarray -> - make_float_alloc ~mode dbg Obj.double_array_tag - (List.map (transl_unbox_float dbg env) args) - -and transl_ccall env prim args dbg = - let transl_arg native_repr arg = - match native_repr with - | Same_as_ocaml_repr sort -> (exttype_of_sort sort, transl env arg) - | Unboxed_float -> - (XFloat, transl_unbox_float dbg env arg) - | Unboxed_integer bi -> - let xty = - match bi with - | Pnativeint -> XInt - | Pint32 -> XInt32 - | Pint64 -> XInt64 in - (xty, transl_unbox_int dbg env bi arg) - | Unboxed_vector (Pvec128 _) -> - (XVec128, transl_unbox_vec128 dbg env arg) - | Untagged_int -> - (XInt, untag_int (transl env arg) dbg) - in - let rec transl_args native_repr_args args = - match native_repr_args, args with - | [], args -> - (* We don't require the two lists to be of the same length as - [default_prim] always sets the arity to [0]. *) - (List.map (fun _ -> XInt) args, List.map (transl env) args) - | _, [] -> - assert false - | (_, native_repr) :: native_repr_args, arg :: args -> - let (ty1, arg') = transl_arg native_repr arg in - let (tys, args') = transl_args native_repr_args args in - (ty1 :: tys, arg' :: args') - in - let typ_res, wrap_result = - match prim.prim_native_repr_res with - | _, Same_as_ocaml_repr sort -> (machtype_of_sort sort, fun x -> x) - (* TODO: Allow Alloc_local on suitably typed C stubs *) - | _, Unboxed_float -> (typ_float, box_float dbg alloc_heap) - | _, Unboxed_integer bi -> (typ_int, box_int dbg bi alloc_heap) - | _, Unboxed_vector (Pvec128 _) -> (typ_vec128, box_vec128 dbg alloc_heap) - | _, Untagged_int -> (typ_int, (fun i -> tag_int i dbg)) - in - let typ_args, args = transl_args prim.prim_native_repr_args args in - let op = cextcall prim args dbg typ_res typ_args true in - wrap_result op - -and transl_prim_1 env p arg dbg = - match p with - (* Generic operations *) - Popaque -> - opaque (transl env arg) dbg - (* Heap operations *) - | Pfield (n, layout, _, mut) -> - get_field env mut layout (transl env arg) n dbg - | Pfloatfield (n,mode) -> - let ptr = transl env arg in - box_float dbg mode (floatfield n ptr dbg) - | Pufloatfield n -> - get_field env Mutable Punboxed_float (transl env arg) n dbg - | Pint_as_pointer _ -> - int_as_pointer (transl env arg) dbg - (* Exceptions *) - | Praise rkind -> - raise_prim rkind (transl env arg) dbg - (* Integer operations *) - | Pnegint -> - negint (transl env arg) dbg - | Poffsetint n -> - offsetint n (transl env arg) dbg - | Poffsetref n -> - offsetref n (transl env arg) dbg - | Punbox_int bi -> - transl_unbox_int dbg env bi arg - | Pbox_int (bi, m) -> - box_int dbg bi m (transl env arg) - (* Floating-point operations *) - | Punbox_float -> - transl_unbox_float dbg env arg - | Pbox_float m -> - box_float dbg m (transl env arg) - | Pfloatofint m -> - box_float dbg m (Cop(Cfloatofint, [untag_int(transl env arg) dbg], dbg)) - | Pintoffloat -> - tag_int(Cop(Cintoffloat, [transl_unbox_float dbg env arg], dbg)) dbg - | Pnegfloat m -> - box_float dbg m (Cop(Cnegf, [transl_unbox_float dbg env arg], dbg)) - | Pabsfloat m -> - box_float dbg m (Cop(Cabsf, [transl_unbox_float dbg env arg], dbg)) - (* String operations *) - | Pstringlength | Pbyteslength -> - tag_int(string_length (transl env arg) dbg) dbg - (* Array operations *) - | Parraylength kind -> - arraylength kind (transl env arg) dbg - (* Boolean operations *) - | Pnot -> - transl_if env Any Then_false_else_true - dbg arg - dbg (Cconst_int (1, dbg)) - dbg (Cconst_int (3, dbg)) - (* Test integer/block *) - | Pisint -> - tag_int(Cop(Cand, [transl env arg; Cconst_int (1, dbg)], dbg)) dbg - (* Boxed integers *) - | Pbintofint (bi, m) -> - box_int dbg bi m (untag_int (transl env arg) dbg) - | Pintofbint bi -> - tag_int (transl_unbox_int dbg env bi arg) dbg - | Pcvtbint(bi1, bi2, m) -> - box_int dbg bi2 m (transl_unbox_int dbg env bi1 arg) - | Pnegbint (bi, m) -> - box_int dbg bi m - (Cop(Csubi, [Cconst_int (0, dbg); transl_unbox_int dbg env bi arg], - dbg)) - | Pbbswap (bi, m) -> - box_int dbg bi m (bbswap bi (transl_unbox_int dbg env bi arg) dbg) - | Pbswap16 -> - tag_int (bswap16 (ignore_high_bit_int (untag_int - (transl env arg) dbg)) dbg) dbg - | Punboxed_product_field (field, layouts) -> - let layouts = Array.of_list (List.map machtype_of_layout layouts) in - Cop (Ctuple_field (field, layouts), [transl env arg], dbg) - | Pget_header m -> - box_int dbg Pnativeint m (get_header (transl env arg) dbg) - | Pperform -> - Misc.fatal_error "Effects-related primitives not yet supported" - (* CR mshinwell: use [Runtimetags] once available - let cont = - make_alloc dbg cont_tag [int_const dbg 0] ~mode:Lambda.alloc_heap - in - (* CR mshinwell: Rc_normal may be wrong, but this code is unlikely - to be in production by then *) - Cop(Capply (typ_val, Rc_normal), - [Cconst_symbol ("caml_perform", dbg); transl env arg; cont], - dbg) - *) - | Pdls_get -> - Cop(Cdls_get, [transl env arg], dbg) - | Patomic_load {immediate_or_pointer = Immediate} -> - Cop(mk_load_atomic Word_int, [transl env arg], dbg) - | Patomic_load {immediate_or_pointer = Pointer} -> - Cop(mk_load_atomic Word_val, [transl env arg], dbg) - | (Pfield_computed | Psequand | Psequor - | Prunstack | Presume | Preperform - | Patomic_exchange | Patomic_cas | Patomic_fetch_add - | Paddint | Psubint | Pmulint | Pandint - | Porint | Pxorint | Plslint | Plsrint | Pasrint - | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ - | Pstringrefu | Pstringrefs | Pbytesrefu | Pbytessetu - | Pbytesrefs | Pbytessets | Pisout | Pread_symbol _ - | Pmakeblock (_, _, _, _) | Psetfield (_, _, _) | Psetfield_computed (_, _) - | Psetfloatfield (_, _) | Pduprecord (_, _) | Pccall _ | Pdivint _ - | Pmakeufloatblock (_, _) | Psetufloatfield (_, _) - | Pmodint _ | Pintcomp _ | Pfloatcomp _ | Punboxed_float_comp _ | Pmakearray (_, _, _) - | Pcompare_ints | Pcompare_floats | Pcompare_bints _ - | Pduparray (_, _) | Parrayrefu _ | Parraysetu _ - | Parrayrefs _ | Parraysets _ | Paddbint _ | Psubbint _ | Pmulbint _ - | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _ - | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp (_, _) - | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) - | Pbigarraydim _ | Pstring_load _ | Pbytes_load _ | Pbytes_set _ - | Pbigstring_load _ | Pbigstring_set _ | Pprobe_is_enabled _ - | Pmake_unboxed_product _ - ) - -> - fatal_errorf "Cmmgen.transl_prim_1: %a" - Printclambda_primitives.primitive p - -and transl_prim_2 env p arg1 arg2 dbg = - match p with - (* Heap operations *) - | Pfield_computed -> - addr_array_ref (transl env arg1) (transl env arg2) dbg - | Psetfield(n, ptr, init) -> - setfield n ptr init (transl env arg1) (transl env arg2) dbg - | Psetfloatfield (n, init) -> - let ptr = transl env arg1 in - let float_val = transl_unbox_float dbg env arg2 in - setfloatfield n init ptr float_val dbg - | Psetufloatfield (n, init) -> - let ptr = transl env arg1 in - let float_val = transl env arg2 in - setfloatfield n init ptr float_val dbg - (* Boolean operations *) - | Psequand -> - let dbg' = Debuginfo.none in - transl_sequand env Any Then_true_else_false - dbg arg1 - dbg' arg2 - dbg (Cconst_int (3, dbg)) - dbg' (Cconst_int (1, dbg)) - (* let id = V.create_local "res1" in - Clet(id, transl env arg1, - Cifthenelse(test_bool dbg (Cvar id), transl env arg2, Cvar id)) *) - | Psequor -> - let dbg' = Debuginfo.none in - transl_sequor env Any Then_true_else_false - dbg arg1 - dbg' arg2 - dbg (Cconst_int (3, dbg)) - dbg' (Cconst_int (1, dbg)) - (* Integer operations *) - | Paddint -> - add_int_caml (transl env arg1) (transl env arg2) dbg - | Psubint -> - sub_int_caml (transl env arg1) (transl env arg2) dbg - | Pmulint -> - mul_int_caml (transl env arg1) (transl env arg2) dbg - | Pdivint is_safe -> - div_int_caml is_safe (transl env arg1) (transl env arg2) dbg - | Pmodint is_safe -> - mod_int_caml is_safe (transl env arg1) (transl env arg2) dbg - | Pandint -> - and_int_caml (transl env arg1) (transl env arg2) dbg - | Porint -> - or_int_caml (transl env arg1) (transl env arg2) dbg - | Pxorint -> - xor_int_caml (transl env arg1) (transl env arg2) dbg - | Plslint -> - lsl_int_caml (transl env arg1) (transl env arg2) dbg - | Plsrint -> - lsr_int_caml (transl env arg1) (transl env arg2) dbg - | Pasrint -> - asr_int_caml (transl env arg1) (transl env arg2) dbg - | Pintcomp cmp -> - int_comp_caml cmp (transl env arg1) (transl env arg2) dbg - | Pcompare_ints -> - (* Compare directly on tagged ints *) - mk_compare_ints dbg (transl env arg1) (transl env arg2) - | Pcompare_bints bi -> - let a1 = transl_unbox_int dbg env bi arg1 in - let a2 = transl_unbox_int dbg env bi arg2 in - mk_compare_ints dbg a1 a2 - | Pcompare_floats -> - let a1 = transl_unbox_float dbg env arg1 in - let a2 = transl_unbox_float dbg env arg2 in - mk_compare_floats dbg a1 a2 - | Pisout -> - transl_isout (transl env arg1) (transl env arg2) dbg - (* Float operations *) - | Paddfloat m -> - box_float dbg m (Cop(Caddf, - [transl_unbox_float dbg env arg1; - transl_unbox_float dbg env arg2], - dbg)) - | Psubfloat m -> - box_float dbg m (Cop(Csubf, - [transl_unbox_float dbg env arg1; - transl_unbox_float dbg env arg2], - dbg)) - | Pmulfloat m -> - box_float dbg m (Cop(Cmulf, - [transl_unbox_float dbg env arg1; - transl_unbox_float dbg env arg2], - dbg)) - | Pdivfloat m -> - box_float dbg m (Cop(Cdivf, - [transl_unbox_float dbg env arg1; - transl_unbox_float dbg env arg2], - dbg)) - | Pfloatcomp cmp -> - tag_int(Cop(Ccmpf cmp, - [transl_unbox_float dbg env arg1; - transl_unbox_float dbg env arg2], - dbg)) dbg - | Punboxed_float_comp cmp -> - tag_int(Cop(Ccmpf cmp, - [transl env arg1; - transl env arg2], - dbg)) dbg - - (* String operations *) - | Pstringrefu | Pbytesrefu -> - stringref_unsafe (transl env arg1) (transl env arg2) dbg - | Pstringrefs | Pbytesrefs -> - stringref_safe (transl env arg1) (transl env arg2) dbg - | Pstring_load(size, unsafe, mode) | Pbytes_load(size, unsafe, mode) -> - string_load size unsafe mode (transl env arg1) (transl env arg2) dbg - | Pbigstring_load(size, unsafe, mode) -> - bigstring_load size unsafe mode (transl env arg1) (transl env arg2) dbg - - (* Array operations *) - | Parrayrefu rkind -> - arrayref_unsafe rkind (transl env arg1) (transl env arg2) dbg - | Parrayrefs rkind -> - arrayref_safe rkind (transl env arg1) (transl env arg2) dbg - - (* Boxed integers *) - | Paddbint (bi, mode) -> - box_int dbg bi mode (add_int - (transl_unbox_int_low dbg env bi arg1) - (transl_unbox_int_low dbg env bi arg2) dbg) - | Psubbint (bi, mode) -> - box_int dbg bi mode (sub_int - (transl_unbox_int_low dbg env bi arg1) - (transl_unbox_int_low dbg env bi arg2) dbg) - | Pmulbint (bi, mode) -> - box_int dbg bi mode (mul_int - (transl_unbox_int_low dbg env bi arg1) - (transl_unbox_int_low dbg env bi arg2) dbg) - | Pdivbint { size = bi; is_safe; mode } -> - box_int dbg bi mode (safe_div_bi is_safe - (transl_unbox_int dbg env bi arg1) - (transl_unbox_int dbg env bi arg2) - bi dbg) - | Pmodbint { size = bi; is_safe; mode } -> - box_int dbg bi mode (safe_mod_bi is_safe - (transl_unbox_int dbg env bi arg1) - (transl_unbox_int dbg env bi arg2) - bi dbg) - | Pandbint (bi, mode) -> - box_int dbg bi mode (and_int - (transl_unbox_int_low dbg env bi arg1) - (transl_unbox_int_low dbg env bi arg2) dbg) - | Porbint (bi, mode) -> - box_int dbg bi mode (or_int - (transl_unbox_int_low dbg env bi arg1) - (transl_unbox_int_low dbg env bi arg2) dbg) - | Pxorbint (bi, mode) -> - box_int dbg bi mode (xor_int - (transl_unbox_int_low dbg env bi arg1) - (transl_unbox_int_low dbg env bi arg2) dbg) - | Plslbint (bi, mode) -> - box_int dbg bi mode (lsl_int - (transl_unbox_int_low dbg env bi arg1) - (untag_int(transl env arg2) dbg) dbg) - | Plsrbint (bi, mode) -> - box_int dbg bi mode (lsr_int - (make_unsigned_int bi (transl_unbox_int dbg env bi arg1) - dbg) - (untag_int(transl env arg2) dbg) dbg) - | Pasrbint (bi, mode) -> - box_int dbg bi mode (asr_int - (transl_unbox_int dbg env bi arg1) - (untag_int(transl env arg2) dbg) dbg) - | Pbintcomp(bi, cmp) -> - tag_int (Cop(Ccmpi cmp, - [transl_unbox_int dbg env bi arg1; - transl_unbox_int dbg env bi arg2], dbg)) dbg - | Patomic_exchange -> - Cop (Cextcall { - func = "caml_atomic_exchange"; - builtin = false; - returns = true; - effects = Arbitrary_effects; - coeffects = Has_coeffects; - ty = typ_val; - ty_args = []; - alloc = false - }, - [transl env arg1; transl env arg2], dbg) - | Patomic_fetch_add -> - Cop (Cextcall { - func = "caml_atomic_fetch_add"; - builtin = false; - returns = true; - effects = Arbitrary_effects; - coeffects = Has_coeffects; - ty = typ_int; - ty_args = []; - alloc = false - }, - [transl env arg1; transl env arg2], dbg) - | Prunstack | Pperform | Presume | Preperform | Pdls_get - | Patomic_cas | Patomic_load _ - | Pnot | Pnegint | Pintoffloat | Pfloatofint _ | Pnegfloat _ - | Pabsfloat _ | Pstringlength | Pbyteslength | Pbytessetu | Pbytessets - | Pisint | Pbswap16 | Pint_as_pointer _ | Popaque | Pread_symbol _ - | Pmakeblock (_, _, _, _) | Pfield _ | Psetfield_computed (_, _) - | Pmakeufloatblock (_, _) | Pfloatfield _ | Pufloatfield _ - | Pduprecord (_, _) | Pccall _ | Praise _ | Poffsetint _ | Poffsetref _ - | Pmakearray (_, _, _) | Pduparray (_, _) | Parraylength _ | Parraysetu _ - | Parraysets _ | Pbintofint _ | Pintofbint _ | Pcvtbint (_, _, _) - | Pnegbint _ | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) - | Pbigarraydim _ | Pbytes_set _ | Pbigstring_set _ | Pbbswap _ - | Pprobe_is_enabled _ - | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _ - | Pmake_unboxed_product _ | Punboxed_product_field _ - | Pget_header _ - -> - fatal_errorf "Cmmgen.transl_prim_2: %a" - Printclambda_primitives.primitive p - -and transl_prim_3 env p arg1 arg2 arg3 dbg = - match p with - (* Heap operations *) - | Psetfield_computed(ptr, init) -> - setfield_computed ptr init - (transl env arg1) (transl env arg2) (transl env arg3) dbg - (* String operations *) - | Pbytessetu -> - bytesset_unsafe - (transl env arg1) (transl env arg2) (transl env arg3) dbg - | Pbytessets -> - bytesset_safe - (transl env arg1) (transl env arg2) (transl env arg3) dbg - - (* Array operations *) - | Parraysetu skind -> - let newval = - match skind with - | Pfloatarray_set -> transl_unbox_float dbg env arg3 - | _ -> transl env arg3 - in - arrayset_unsafe skind (transl env arg1) (transl env arg2) newval dbg - | Parraysets skind -> - let newval = - match skind with - | Pfloatarray_set -> transl_unbox_float dbg env arg3 - | _ -> transl env arg3 - in - arrayset_safe skind (transl env arg1) (transl env arg2) newval dbg - - | Pbytes_set(size, unsafe) -> - bytes_set size unsafe (transl env arg1) (transl env arg2) - (transl_unbox_sized size dbg env arg3) dbg - - | Pbigstring_set(size, unsafe) -> - bigstring_set size unsafe (transl env arg1) (transl env arg2) - (transl_unbox_sized size dbg env arg3) dbg - - | Patomic_cas -> - Cop (Cextcall { - func = "caml_atomic_cas"; - builtin = false; - returns = true; - effects = Arbitrary_effects; - coeffects = Has_coeffects; - ty = typ_int; - ty_args = []; - alloc = false - }, - [transl env arg1; transl env arg2; transl env arg3], dbg) - - (* Effects *) - | Presume -> - Misc.fatal_error "Effects-related primitives not yet supported" - (* - (* CR mshinwell: Rc_normal may be wrong, but this code is unlikely - to be in production by then *) - Cop (Capply (typ_val, Rc_normal), - [Cconst_symbol ("caml_resume", dbg); - transl env arg1; transl env arg2; transl env arg3], - dbg) - *) - | Prunstack -> - Misc.fatal_error "Effects-related primitives not yet supported" - (* - (* CR mshinwell: Rc_normal may be wrong, but this code is unlikely - to be in production by then *) - Cop (Capply (typ_val, Rc_normal), - [Cconst_symbol ("caml_runstack", dbg); - transl env arg1; transl env arg2; transl env arg3], - dbg) - *) - | Preperform -> - Misc.fatal_error "Effects-related primitives not yet supported" - (* - (* CR mshinwell: Rc_normal may be wrong, but this code is unlikely - to be in production by then *) - Cop (Capply (typ_val, Rc_normal), - [Cconst_symbol ("caml_reperform", dbg); - transl env arg1; transl env arg2; transl env arg3], - dbg) - *) - - | Pperform | Pdls_get - | Patomic_exchange | Patomic_fetch_add | Patomic_load _ - | Pfield_computed | Psequand | Psequor | Pnot | Pnegint | Paddint - | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint - | Pintoffloat | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ - | Pmulfloat _ | Pdivfloat _ | Pstringlength | Pstringrefu | Pstringrefs - | Pbyteslength | Pbytesrefu | Pbytesrefs | Pisint | Pisout - | Pbswap16 | Pint_as_pointer _ | Popaque | Pread_symbol _ - | Pmakeblock (_, _, _, _) - | Pfield _ | Psetfield (_, _, _) | Pfloatfield _ | Psetfloatfield (_, _) - | Pmakeufloatblock (_, _) | Pufloatfield _ | Psetufloatfield (_, _) - | Pduprecord (_, _) | Pccall _ | Praise _ | Pdivint _ | Pmodint _ | Pintcomp _ - | Pcompare_ints | Pcompare_floats | Pcompare_bints _ - | Poffsetint _ | Poffsetref _ | Pfloatcomp _ | Punboxed_float_comp _ - | Pmakearray (_, _, _) - | Pduparray (_, _) | Parraylength _ | Parrayrefu _ | Parrayrefs _ - | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ - | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _ - | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp (_, _) - | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) | Pbigarraydim _ - | Pstring_load _ | Pbytes_load _ | Pbigstring_load _ | Pbbswap _ - | Pprobe_is_enabled _ - | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _ - | Pmake_unboxed_product _ | Punboxed_product_field _ - | Pget_header _ - -> - fatal_errorf "Cmmgen.transl_prim_3: %a" - Printclambda_primitives.primitive p - -and transl_unbox_float dbg env exp = - unbox_float dbg (transl env exp) - -and transl_unbox_int dbg env bi exp = - unbox_int dbg bi (transl env exp) - -and transl_unbox_vec128 dbg env exp = - unbox_vec128 dbg (transl env exp) - -(* transl_unbox_int, but may return garbage in upper bits *) -and transl_unbox_int_low dbg env bi e = - let e = transl_unbox_int dbg env bi e in - if bi = Pint32 then low_32 dbg e else e - -and transl_unbox_sized size dbg env exp = - match (size : Clambda_primitives.memory_access_size) with - | Sixteen -> - ignore_high_bit_int (untag_int (transl env exp) dbg) - | Thirty_two -> transl_unbox_int dbg env Pint32 exp - | Sixty_four -> transl_unbox_int dbg env Pint64 exp - | One_twenty_eight _ -> transl_unbox_vec128 dbg env exp - -and transl_let_value env str (kind : Lambda.value_kind) id exp transl_body = - let dbg = Debuginfo.none in - let cexp = transl env exp in - let unboxing = - (* If [id] is a mutable variable (introduced to eliminate a local - reference) and it contains a type of unboxable numbers, then - force unboxing. Indeed, if not boxed, each assignment to the variable - might require some boxing, but such local references are often - used in loops and we really want to avoid repeated boxing. - - We conservatively mark these as Alloc_heap, although with more tracking - of allocation mode it may be possible to mark some Alloc_local *) - match str, kind with - | Mutable, Pfloatval -> - Boxed (Boxed_float (alloc_heap, dbg), false) - | Mutable, Pboxedintval bi -> - Boxed (Boxed_integer (bi, alloc_heap, dbg), false) - | _ -> - is_unboxed_number_cmm cexp - in - match unboxing with - | No_unboxing | Boxed (_, true) | No_result -> - (* N.B. [body] must still be traversed even if [exp] will never return: - there may be constant closures inside that need lifting out. *) - begin match str, kind with - | (Immutable | Immutable_unique), _ -> Clet(id, cexp, transl_body env) - | Mutable, Pintval -> Clet_mut(id, typ_int, cexp, transl_body env) - | Mutable, _ -> Clet_mut(id, typ_val, cexp, transl_body env) - end - | Boxed (boxed_number, false) -> - let unboxed_id = V.create_local (VP.name id) in - let v = VP.create unboxed_id in - let cexp = unbox_number dbg boxed_number cexp in - let body = - transl_body (add_unboxed_id (VP.var id) unboxed_id boxed_number env) in - begin match str, boxed_number with - | (Immutable | Immutable_unique), _ -> Clet (v, cexp, body) - | Mutable, bn -> Clet_mut (v, typ_of_boxed_number bn, cexp, body) - end - -and transl_let env str (layout : Lambda.layout) id exp transl_body = - match layout with - | Ptop -> - Misc.fatal_errorf "Variable %a with layout [Ptop] can't be compiled" - VP.print id - | Pbottom -> - let cexp = transl env exp in - (* N.B. [body] must still be traversed even if [exp] will never return: - there may be constant closures inside that need lifting out. *) - let _cbody : expression = transl_body env in - cexp - | Punboxed_float | Punboxed_int _ | Punboxed_vector _ | Punboxed_product _ -> - begin - let cexp = transl env exp in - let cbody = transl_body env in - match str with - | (Immutable | Immutable_unique) -> - Clet(id, cexp, cbody) - | Mutable -> - let typ = machtype_of_layout layout in - Clet_mut(id, typ, cexp, cbody) - end - | Pvalue kind -> - transl_let_value env str kind id exp transl_body - -and make_catch (kind : Cmm.kind_for_unboxing) ncatch body handler dbg = - match body with - | Cexit (Lbl nexit,[],[]) when nexit=ncatch -> handler - | _ -> ccatch (ncatch, [], body, handler, dbg, kind, false) - -and is_shareable_cont exp = - match exp with - | Cexit (_,[],[]) -> true - | _ -> false - -and make_shareable_cont (kind : Cmm.kind_for_unboxing) dbg mk exp = - if is_shareable_cont exp then mk exp - else begin - let nfail = next_raise_count () in - make_catch - kind - nfail - (mk (Cexit (Lbl nfail,[],[]))) - exp - dbg - end - -and transl_if env (kind : Cmm.kind_for_unboxing) (approx : then_else) - (dbg : Debuginfo.t) cond - (then_dbg : Debuginfo.t) then_ - (else_dbg : Debuginfo.t) else_ = - match cond with - | Uconst (Uconst_int 0) -> else_ - | Uconst (Uconst_int 1) -> then_ - | Uifthenelse (arg1, arg2, Uconst (Uconst_int 0), _) -> - (* CR mshinwell: These Debuginfos will flow through from Clambda *) - let inner_dbg = Debuginfo.none in - let ifso_dbg = Debuginfo.none in - transl_sequand env kind approx - inner_dbg arg1 - ifso_dbg arg2 - then_dbg then_ - else_dbg else_ - | Ulet(str, let_kind, id, exp, cond) -> - transl_let env str let_kind id exp (fun env -> - transl_if env kind approx dbg cond then_dbg then_ else_dbg else_) - | Uprim (Psequand, [arg1; arg2], inner_dbg) -> - transl_sequand env kind approx - inner_dbg arg1 - inner_dbg arg2 - then_dbg then_ - else_dbg else_ - | Uifthenelse (arg1, Uconst (Uconst_int 1), arg2, _) -> - let inner_dbg = Debuginfo.none in - let ifnot_dbg = Debuginfo.none in - transl_sequor env kind approx - inner_dbg arg1 - ifnot_dbg arg2 - then_dbg then_ - else_dbg else_ - | Uprim (Psequor, [arg1; arg2], inner_dbg) -> - transl_sequor env kind approx - inner_dbg arg1 - inner_dbg arg2 - then_dbg then_ - else_dbg else_ - | Uprim (Pnot, [arg], _dbg) -> - transl_if env kind (invert_then_else approx) - dbg arg - else_dbg else_ - then_dbg then_ - | Uifthenelse (Uconst (Uconst_int 1), ifso, _, _) -> - let ifso_dbg = Debuginfo.none in - transl_if env kind approx - ifso_dbg ifso - then_dbg then_ - else_dbg else_ - | Uifthenelse (Uconst (Uconst_int 0), _, ifnot, _) -> - let ifnot_dbg = Debuginfo.none in - transl_if env kind approx - ifnot_dbg ifnot - then_dbg then_ - else_dbg else_ - | Uifthenelse (cond, ifso, ifnot, _) -> - let inner_dbg = Debuginfo.none in - let ifso_dbg = Debuginfo.none in - let ifnot_dbg = Debuginfo.none in - make_shareable_cont kind then_dbg - (fun shareable_then -> - make_shareable_cont kind else_dbg - (fun shareable_else -> - mk_if_then_else - inner_dbg kind (test_bool inner_dbg (transl env cond)) - ifso_dbg (transl_if env kind approx - ifso_dbg ifso - then_dbg shareable_then - else_dbg shareable_else) - ifnot_dbg (transl_if env kind approx - ifnot_dbg ifnot - then_dbg shareable_then - else_dbg shareable_else)) - else_) - then_ - | _ -> begin - match approx with - | Then_true_else_false -> - transl env cond - | Then_false_else_true -> - mk_not dbg (transl env cond) - | Unknown -> - mk_if_then_else - dbg kind (test_bool dbg (transl env cond)) - then_dbg then_ - else_dbg else_ - end - -and transl_sequand env (kind : Cmm.kind_for_unboxing) (approx : then_else) - (arg1_dbg : Debuginfo.t) arg1 - (arg2_dbg : Debuginfo.t) arg2 - (then_dbg : Debuginfo.t) then_ - (else_dbg : Debuginfo.t) else_ = - make_shareable_cont kind else_dbg - (fun shareable_else -> - transl_if env kind Unknown - arg1_dbg arg1 - arg2_dbg (transl_if env kind approx - arg2_dbg arg2 - then_dbg then_ - else_dbg shareable_else) - else_dbg shareable_else) - else_ - -and transl_sequor env (kind : Cmm.kind_for_unboxing) (approx : then_else) - (arg1_dbg : Debuginfo.t) arg1 - (arg2_dbg : Debuginfo.t) arg2 - (then_dbg : Debuginfo.t) then_ - (else_dbg : Debuginfo.t) else_ = - make_shareable_cont kind then_dbg - (fun shareable_then -> - transl_if env kind Unknown - arg1_dbg arg1 - then_dbg shareable_then - arg2_dbg (transl_if env kind approx - arg2_dbg arg2 - then_dbg shareable_then - else_dbg else_)) - then_ - -(* This assumes that [arg] can be safely discarded if it is not used. *) -and transl_switch dbg (kind : Cmm.kind_for_unboxing) env arg index cases = match Array.length cases with -| 0 -> fatal_error "Cmmgen.transl_switch" -| 1 -> transl env cases.(0) -| _ -> - let cases = Array.map (transl env) cases in - transl_switch_clambda dbg kind arg index cases - -and transl_letrec env bindings cont = - let dbg = Debuginfo.none in - let bsz = - List.map (fun (id, exp) -> (id, exp, expr_size V.empty exp)) - bindings - in - let op_alloc prim args = - Cop(Cextcall { func = prim; ty = typ_val; alloc = true; - builtin = false; - returns = true; - effects = Arbitrary_effects; - coeffects = Has_coeffects; - ty_args = [] }, - args, dbg) in - let rec init_blocks = function - | [] -> fill_nonrec bsz - | (_, _, - (RHS_block (Alloc_local, _) | - RHS_infix {blockmode=Alloc_local; _} | - RHS_floatblock (Alloc_local, _))) :: _ -> - Misc.fatal_error "Invalid stack allocation found" - | (id, _exp, RHS_block (Alloc_heap, sz)) :: rem -> - Clet(id, op_alloc "caml_alloc_dummy" [int_const dbg sz], - init_blocks rem) - | (id, _exp, RHS_infix { blocksize; offset; blockmode=Alloc_heap }) :: rem -> - Clet(id, op_alloc "caml_alloc_dummy_infix" - [int_const dbg blocksize; int_const dbg offset], - init_blocks rem) - | (id, _exp, RHS_floatblock (Alloc_heap, sz)) :: rem -> - Clet(id, op_alloc "caml_alloc_dummy_float" [int_const dbg sz], - init_blocks rem) - | (id, _exp, RHS_nonrec) :: rem -> - Clet (id, Cconst_int (1, dbg), init_blocks rem) - and fill_nonrec = function - | [] -> fill_blocks bsz - | (_id, _exp, - (RHS_block _ | RHS_infix _ | RHS_floatblock _)) :: rem -> - fill_nonrec rem - | (id, exp, RHS_nonrec) :: rem -> - Clet(id, transl env exp, fill_nonrec rem) - and fill_blocks = function - | [] -> cont - | (id, exp, (RHS_block _ | RHS_infix _ | RHS_floatblock _)) :: rem -> - let op = - Cop(Cextcall { func = "caml_update_dummy"; ty = typ_void; - builtin = false; - returns = true; - effects = Arbitrary_effects; - coeffects = Has_coeffects; - alloc = false; ty_args = [] }, - [Cvar (VP.var id); transl env exp], dbg) in - Csequence(op, fill_blocks rem) - | (_id, _exp, RHS_nonrec) :: rem -> - fill_blocks rem - in init_blocks bsz - -(* Translate a function definition *) - -let transl_function f = - let body = f.body in - let cmm_body = - let env = create_env ~environment_param:f.env in - if !Clflags.afl_instrument then - Afl_instrument.instrument_function (transl env body) f.dbg - else - transl env body in - let fun_codegen_options = - transl_attrib f.check @ - if !Clflags.optimize_for_speed then - [] - else - [ Reduce_code_size ] - in - let params_layout = - if List.length f.params = List.length f.arity.params_layout then - f.arity.params_layout - else - f.arity.params_layout @ [Lambda.layout_function] - in - Cfunction {fun_name = global_symbol f.label; - fun_args = List.map2 (fun id ty -> (id, machtype_of_layout ty)) - f.params params_layout; - fun_body = cmm_body; - fun_codegen_options; - fun_poll = f.poll; - fun_dbg = f.dbg} - -(* Translate all function definitions *) - -let rec transl_all_functions already_translated cont = - match Cmmgen_state.next_function () with - | None -> cont, already_translated - | Some f -> - let sym = f.label in - if String.Set.mem sym already_translated then - transl_all_functions already_translated cont - else begin - transl_all_functions - (String.Set.add sym already_translated) - ((f.dbg, transl_function f) :: cont) - end - -(* Emit constant blocks *) - -let emit_constant_table symb elems = - cdefine_symbol symb @ - elems - -(* Emit all structured constants *) - -let transl_clambda_constants (constants : Clambda.preallocated_constant list) - cont = - let c = ref cont in - let emit_clambda_constant sym cst = - let cst = emit_structured_constant sym cst [] in - c := (Cdata cst) :: !c - in - List.iter - (fun { symbol; exported; definition = cst; provenance = _; } -> - let sym = - { sym_name = symbol; - sym_global = if exported then Global else Local } - in - emit_clambda_constant sym cst) - constants; - !c - -let emit_cmm_data_items_for_constants cont = - let c = ref cont in - String.Map.iter (fun sym_name (cst : Cmmgen_state.constant) -> - match cst with - | Const_closure (global, fundecls, clos_vars) -> - let cmm = - emit_constant_closure {sym_name; sym_global=global} fundecls - (List.fold_right emit_constant clos_vars []) [] - in - c := (Cdata cmm) :: !c - | Const_table (global, elems) -> - c := (Cdata (emit_constant_table {sym_name; sym_global=global} elems)) :: !c) - (Cmmgen_state.get_and_clear_constants ()); - Cdata (Cmmgen_state.get_and_clear_data_items ()) :: !c - -let transl_all_functions cont = - let rec aux already_translated cont translated_functions = - if Cmmgen_state.no_more_functions () - then cont, translated_functions - else - let translated_functions, already_translated = - transl_all_functions already_translated translated_functions - in - aux already_translated cont translated_functions - in - let cont, translated_functions = - aux String.Set.empty cont [] - in - let translated_functions = - (* Sort functions according to source position *) - List.map snd - (List.sort (fun (dbg1, _) (dbg2, _) -> - Debuginfo.compare dbg1 dbg2) translated_functions) - in - translated_functions @ cont - -(* Translate a compilation unit *) - -let compunit (ulam, preallocated_blocks, constants) = - assert (Cmmgen_state.no_more_functions ()); - let dbg = Debuginfo.none in - Cmmgen_state.set_local_structured_constants constants; - let init_code = - if !Clflags.afl_instrument then - Afl_instrument.instrument_initialiser (transl empty_env ulam) - (fun () -> dbg) - else - transl empty_env ulam in - let c1 = [Cfunction {fun_name = global_symbol (make_symbol "entry"); - fun_args = []; - fun_body = init_code; - (* This function is often large and run only once. - Compilation time matter more than runtime. - See MPR#7630 *) - fun_codegen_options = - if Config.flambda then [ - Reduce_code_size; - No_CSE; - Use_linscan_regalloc; - Ignore_assert_all Zero_alloc; - ] - else [ Reduce_code_size; - Use_linscan_regalloc; - Ignore_assert_all Zero_alloc; - ]; - fun_dbg = Debuginfo.none; - fun_poll = Default_poll }] in - let c2 = transl_clambda_constants constants c1 in - let c3 = transl_all_functions c2 in - Cmmgen_state.set_local_structured_constants []; - let c4 = emit_preallocated_blocks preallocated_blocks c3 in - let c5 = emit_cmm_data_items_for_constants c4 in - Cmmgen_state.clear_function_names (); - c5 diff --git a/backend/cmmgen.mli b/backend/cmmgen.mli deleted file mode 100644 index a954a284249..00000000000 --- a/backend/cmmgen.mli +++ /dev/null @@ -1,22 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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 from closed lambda to C-- *) - -val compunit - : Clambda.ulambda - * Clambda.preallocated_block list - * Clambda.preallocated_constant list - -> Cmm.phrase list diff --git a/backend/cmmgen_state.ml b/backend/cmmgen_state.ml index d7e1fcfbb35..cd9c58f8df7 100644 --- a/backend/cmmgen_state.ml +++ b/backend/cmmgen_state.ml @@ -19,25 +19,99 @@ module S = Misc.Stdlib.String +type ustructured_constant = + | Const_float of float + | Const_int32 of int32 + | Const_int64 of int64 + | Const_nativeint of nativeint + | Const_vec128 of { high : int64; low : int64 } + | Const_block of int * uconstant list + | Const_float_array of float list + | Const_string of string + +and uconstant = + | Const_ref of string * ustructured_constant option + | Const_int of int + +(* Comparison functions for constants. We must not use Stdlib.compare + because it compares "0.0" and "-0.0" equal. (PR#6442) *) + +let compare_floats x1 x2 = + Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2) + +let rec compare_float_lists l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | h1::t1, h2::t2 -> + let c = compare_floats h1 h2 in + if c <> 0 then c else compare_float_lists t1 t2 + +let compare_constants c1 c2 = + match c1, c2 with + | Const_ref(lbl1, _c1), Const_ref(lbl2, _c2) -> String.compare lbl1 lbl2 + (* Same labels -> same constants. + Different labels -> different constants, even if the contents + match, because of string constants that must not be + reshared. *) + | Const_int n1, Const_int n2 -> Stdlib.compare n1 n2 + | Const_ref _, _ -> -1 + | Const_int _, Const_ref _ -> 1 + +let rec compare_constant_lists l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | h1::t1, h2::t2 -> + let c = compare_constants h1 h2 in + if c <> 0 then c else compare_constant_lists t1 t2 + +let rank_structured_constant = function + | Const_float _ -> 0 + | Const_int32 _ -> 1 + | Const_int64 _ -> 2 + | Const_nativeint _ -> 3 + | Const_block _ -> 4 + | Const_float_array _ -> 5 + | Const_string _ -> 6 + | Const_vec128 _ -> 8 + +let compare_structured_constants c1 c2 = + match c1, c2 with + | Const_float x1, Const_float x2 -> compare_floats x1 x2 + | Const_int32 x1, Const_int32 x2 -> Int32.compare x1 x2 + | Const_int64 x1, Const_int64 x2 -> Int64.compare x1 x2 + | Const_nativeint x1, Const_nativeint x2 -> Nativeint.compare x1 x2 + | Const_block(t1, l1), Const_block(t2, l2) -> + let c = t1 - t2 (* no overflow possible here *) in + if c <> 0 then c else compare_constant_lists l1 l2 + | Const_float_array l1, Const_float_array l2 -> + compare_float_lists l1 l2 + | Const_string s1, Const_string s2 -> String.compare s1 s2 + | Const_vec128 { high = l0; low = l1}, + Const_vec128 { high = r0; low = r1} -> + let cmp = Int64.compare l0 r0 in + if cmp = 0 then Int64.compare l1 r1 else cmp + | _, _ -> + (* no overflow possible here *) + rank_structured_constant c1 - rank_structured_constant c2 + type constant = - | Const_closure of Cmm.is_global * Clambda.ufunction list * Clambda.uconstant list | Const_table of Cmm.is_global * Cmm.data_item list type t = { mutable constants : constant S.Map.t; mutable data_items : Cmm.data_item list list; structured_constants : - (string, Cmm.is_global * Clambda.ustructured_constant) Hashtbl.t; - functions : Clambda.ufunction Queue.t; - function_names : (Clambda.function_label, unit) Hashtbl.t; + (string, Cmm.is_global * ustructured_constant) Hashtbl.t; } let empty = { constants = S.Map.empty; data_items = []; - functions = Queue.create (); structured_constants = Hashtbl.create 16; - function_names = Hashtbl.create 16; } let state = empty @@ -48,10 +122,6 @@ let add_constant sym cst = let add_data_items items = state.data_items <- items :: state.data_items -let add_function (func : Clambda.ufunction) = - Queue.add func state.functions; - Hashtbl.add state.function_names func.label () - let get_and_clear_constants () = let constants = state.constants in state.constants <- S.Map.empty; @@ -62,31 +132,12 @@ let get_and_clear_data_items () = state.data_items <- []; data_items -let next_function () = - match Queue.take state.functions with - | exception Queue.Empty -> None - | func -> Some func - -let no_more_functions () = - Queue.is_empty state.functions - -let is_local_function name = - Hashtbl.mem state.function_names name - -let clear_function_names () = - Hashtbl.clear state.function_names - let add_structured_constant (sym : Cmm.symbol) cst = if not (Hashtbl.mem state.structured_constants sym.sym_name) then Hashtbl.replace state.structured_constants sym.sym_name (sym.sym_global, cst) -let set_local_structured_constants l = - Hashtbl.clear state.structured_constants; - List.iter - (fun (c : Clambda.preallocated_constant) -> - Hashtbl.add state.structured_constants c.symbol (Cmm.Local, c.definition) - ) - l +let clear_local_structured_constants () = + Hashtbl.clear state.structured_constants let add_global_structured_constant sym cst = if not (Hashtbl.mem state.structured_constants sym) then @@ -96,7 +147,4 @@ let get_structured_constant s = Hashtbl.find_opt state.structured_constants s let structured_constant_of_sym s = - match Compilenv.structured_constant_of_symbol s with - | None -> - Option.map snd (Hashtbl.find_opt state.structured_constants s) - | Some _ as r -> r + Option.map snd (Hashtbl.find_opt state.structured_constants s) diff --git a/backend/cmmgen_state.mli b/backend/cmmgen_state.mli index c88ab192c6d..d0ec81cae47 100644 --- a/backend/cmmgen_state.mli +++ b/backend/cmmgen_state.mli @@ -19,35 +19,44 @@ [@@@ocaml.warning "+a-4-30-40-41-42"] +type ustructured_constant = + | Const_float of float + | Const_int32 of int32 + | Const_int64 of int64 + | Const_nativeint of nativeint + | Const_vec128 of { high : int64; low : int64 } + | Const_block of int * uconstant list + | Const_float_array of float list + | Const_string of string + +and uconstant = + | Const_ref of string * ustructured_constant option + | Const_int of int + +(* Comparison functions for constants *) + +val compare_structured_constants: + ustructured_constant -> ustructured_constant -> int +val compare_constants: + uconstant -> uconstant -> int + type constant = - | Const_closure of Cmm.is_global * Clambda.ufunction list * Clambda.uconstant list | Const_table of Cmm.is_global * Cmm.data_item list val add_constant : Misc.Stdlib.String.t -> constant -> unit val add_data_items : Cmm.data_item list -> unit -val add_function : Clambda.ufunction -> unit - val get_and_clear_constants : unit -> constant Misc.Stdlib.String.Map.t val get_and_clear_data_items : unit -> Cmm.data_item list -val next_function : unit -> Clambda.ufunction option - -val no_more_functions : unit -> bool - -val is_local_function : Clambda.function_label -> bool - -val clear_function_names : unit -> unit - -val add_structured_constant : Cmm.symbol -> Clambda.ustructured_constant -> unit +val add_structured_constant : Cmm.symbol -> ustructured_constant -> unit -val set_local_structured_constants : Clambda.preallocated_constant list -> unit +val clear_local_structured_constants : unit -> unit -val add_global_structured_constant : string -> Clambda.ustructured_constant -> unit +val add_global_structured_constant : string -> ustructured_constant -> unit -val get_structured_constant : string -> (Cmm.is_global * Clambda.ustructured_constant) option +val get_structured_constant : string -> (Cmm.is_global * ustructured_constant) option -(* Also looks up using Compilenv.structured_constant_of_symbol *) -val structured_constant_of_sym : string -> Clambda.ustructured_constant option +val structured_constant_of_sym : string -> ustructured_constant option diff --git a/backend/strmatch.ml b/backend/strmatch.ml deleted file mode 100644 index 2a5fc8958cf..00000000000 --- a/backend/strmatch.ml +++ /dev/null @@ -1,399 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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 string matching from closed lambda to C-- *) - -open Lambda -open Cmm - -module V = Backend_var -module VP = Backend_var.With_provenance - -module type I = sig - val string_block_length : Cmm.expression -> Cmm.expression - val transl_switch : - Debuginfo.t -> Cmm.kind_for_unboxing -> Cmm.expression -> int -> int -> - (int * Cmm.expression) list -> Cmm.expression -> - Cmm.expression -end - -module Make(I:I) = struct - -(* Debug *) - - let dbg = false - - let mask = - let open Nativeint in - sub (shift_left one 8) one - - let pat_as_string p = - let rec digits k n p = - if n <= 0 then k - else - let d = Nativeint.to_int (Nativeint.logand mask p) in - let d = Char.escaped (Char.chr d) in - digits (d::k) (n-1) (Nativeint.shift_right_logical p 8) in - let ds = digits [] Arch.size_addr p in - let ds = - if Arch.big_endian then ds else List.rev ds in - String.concat "" ds - - let do_pp_cases chan cases = - List.iter - (fun (ps,_) -> - Printf.fprintf chan " [%s]\n" - (String.concat "; " (List.map pat_as_string ps))) - cases - - let pp_cases chan tag cases = - Printf.eprintf "%s:\n" tag ; - do_pp_cases chan cases - - let pp_match chan tag idxs cases = - Printf.eprintf - "%s: idx=[%s]\n" tag - (String.concat "; " (List.map Int.to_string idxs)) ; - do_pp_cases chan cases - -(* Utilities *) - - let gen_cell_id () = V.create_local "cell" - let gen_size_id () = V.create_local "size" - - let mk_let_cell id str ind body = - let dbg = Debuginfo.none in - let cell = - Cop(Cload {memory_chunk=Word_int; - mutability=Asttypes.Mutable; - is_atomic=false}, - [Cop(Cadda,[str;Cconst_int(Arch.size_int*ind, dbg)], dbg)], - dbg) in - Clet(id, cell, body) - - let mk_let_size id str body = - let size = I.string_block_length str in - Clet(id, size, body) - - let mk_cmp_gen cmp_op value_kind id nat ifso ifnot = - let dbg = Debuginfo.none in - let test = - Cop (Ccmpi cmp_op, [ Cvar id; Cconst_natint (nat, dbg) ], dbg) - in - Cifthenelse (test, dbg, ifso, dbg, ifnot, dbg, value_kind) - - let mk_lt = mk_cmp_gen Clt - let mk_eq = mk_cmp_gen Ceq - - module IntArg = - struct - type t = int - let compare (x:int) (y:int) = - if x < y then -1 - else if x > y then 1 - else 0 - end - - let interval m0 n = - let rec do_rec m = - if m >= n then [] - else m::do_rec (m+1) in - do_rec m0 - - -(*****************************************************) -(* Compile strings to a lists of words [native ints] *) -(*****************************************************) - - let pat_of_string str = - let len = String.length str in - let n = len / Arch.size_addr + 1 in - let get_byte i = - if i < len then int_of_char str.[i] - else if i < n * Arch.size_addr - 1 then 0 - else n * Arch.size_addr - 1 - len in - let mk_word ind = - let w = ref 0n in - let imin = ind * Arch.size_addr - and imax = (ind + 1) * Arch.size_addr - 1 in - if Arch.big_endian then - for i = imin to imax do - w := Nativeint.logor (Nativeint.shift_left !w 8) - (Nativeint.of_int (get_byte i)); - done - else - for i = imax downto imin do - w := Nativeint.logor (Nativeint.shift_left !w 8) - (Nativeint.of_int (get_byte i)); - done; - !w in - let rec mk_words ind = - if ind >= n then [] - else mk_word ind::mk_words (ind+1) in - mk_words 0 - -(*****************************) -(* Discriminating heuristics *) -(*****************************) - - module IntSet = Set.Make(IntArg) - module NativeSet = Set.Make(Nativeint) - - let rec add_one sets ps = match sets,ps with - | [],[] -> [] - | set::sets,p::ps -> - let sets = add_one sets ps in - NativeSet.add p set::sets - | _,_ -> assert false - - let count_arities cases = match cases with - | [] -> assert false - | (ps,_)::_ -> - let sets = - List.fold_left - (fun sets (ps,_) -> add_one sets ps) - (List.map (fun _ -> NativeSet.empty) ps) cases in - List.map NativeSet.cardinal sets - - let count_arities_first cases = - let set = - List.fold_left - (fun set case -> match case with - | (p::_,_) -> NativeSet.add p set - | _ -> assert false) - NativeSet.empty cases in - NativeSet.cardinal set - - let count_arities_length cases = - let set = - List.fold_left - (fun set (ps,_) -> IntSet.add (List.length ps) set) - IntSet.empty cases in - IntSet.cardinal set - - let best_col = - let rec do_rec kbest best k = function - | [] -> kbest - | x::xs -> - if x < best then - do_rec k x (k+1) xs - else - do_rec kbest best (k+1) xs in - let smallest = do_rec (-1) max_int 0 in - fun cases -> - let ars = count_arities cases in - smallest ars - - let swap_list = - let rec do_rec k xs = match xs with - | [] -> assert false - | x::xs -> - if k <= 0 then [],x,xs - else - let xs,mid,ys = do_rec (k-1) xs in - x::xs,mid,ys in - fun k xs -> - let xs,x,ys = do_rec k xs in - x::xs @ ys - - let swap k idxs cases = - if k = 0 then idxs,cases - else - let idxs = swap_list k idxs - and cases = - List.map - (fun (ps,act) -> swap_list k ps,act) - cases in - if dbg then begin - pp_match stderr "SWAP" idxs cases - end ; - idxs,cases - - let best_first idxs cases = match idxs with - | []|[_] -> idxs,cases (* optimisation: one column only *) - | _ -> - let k = best_col cases in - swap k idxs cases - -(************************************) -(* Divide according to first column *) -(************************************) - - module Divide(O:Set.OrderedType) = struct - - module OMap = Map.Make(O) - - let divide cases = - let env = - List.fold_left - (fun env (p,psact) -> - let old = - try OMap.find p env - with Not_found -> [] in - OMap.add p ((psact)::old) env) - OMap.empty cases in - let r = OMap.fold (fun key v k -> (key,v)::k) env [] in - List.rev r (* Now sorted *) - end - -(***************) -(* Compilation *) -(***************) - -(* Group by cell *) - - module DivideNative = Divide(Nativeint) - - let by_cell cases = - DivideNative.divide - (List.map - (fun case -> match case with - | (p::ps),act -> p,(ps,act) - | [],_ -> assert false) - cases) - -(* Split into two halves *) - - let rec do_split idx env = match env with - | [] -> assert false - | (midkey,_ as x)::rem -> - if idx <= 0 then [],midkey,env - else - let lt,midkey,ge = do_split (idx-1) rem in - x::lt,midkey,ge - - let split_env len env = do_split (len/2) env - -(* Switch according to one cell *) - -(* - Emit the switch, here as a comparison tree. - Argument compile_rec is to be called to compile the rest of patterns, - as match_on_cell can be called in two different contexts : - from do_compile_pats and top_compile below. - *) - let match_oncell value_kind compile_rec str default idx env = - let id = gen_cell_id () in - let rec comp_rec env = - let len = List.length env in - if len <= 3 then - List.fold_right - (fun (key,cases) ifnot -> - mk_eq value_kind id key - (compile_rec str default cases) - ifnot) - env default - else - let lt,midkey,ge = split_env len env in - mk_lt value_kind id midkey (comp_rec lt) (comp_rec ge) in - mk_let_cell (VP.create id) str idx (comp_rec env) - -(* - Recursive 'list of cells' compile function: - - choose the matched cell and switch on it - - notice: patterns (and idx) all have the same length - *) - - let rec do_compile_pats value_kind idxs str default cases = - if dbg then begin - pp_match stderr "COMPILE" idxs cases - end ; - match idxs with - | [] -> - begin match cases with - | [] -> default - | (_,e)::_ -> e - end - | _::_ -> - let idxs,cases = best_first idxs cases in - begin match idxs with - | [] -> assert false - | idx::idxs -> - match_oncell value_kind - (do_compile_pats value_kind idxs) str default idx (by_cell cases) - end - - -(* Group by size *) - - module DivideInt = Divide(IntArg) - - - let by_size cases = - DivideInt.divide - (List.map - (fun (ps,_ as case) -> List.length ps,case) - cases) -(* - Switch according to pattern size - Argument from_ind is the starting index, it can be zero - or one (when the switch on the cell 0 has already been performed. - In that latter case pattern len is string length-1 and is corrected. - *) - - let compile_by_size dbg value_kind from_ind str default cases = - let size_cases = - List.map - (fun (len,cases) -> - let len = len+from_ind in - let act = - do_compile_pats value_kind - (interval from_ind len) - str default cases in - (len,act)) - (by_size cases) in - let id = gen_size_id () in - let switch = I.transl_switch dbg value_kind (Cvar id) 1 max_int size_cases default in - mk_let_size (VP.create id) str switch - -(* - Compilation entry point: we choose to switch - either on size or on first cell, using the - 'least discriminant' heuristics. - *) - let top_compile debuginfo value_kind str default cases = - let a_len = count_arities_length cases - and a_fst = count_arities_first cases in - if a_len <= a_fst then begin - if dbg then pp_cases stderr "SIZE" cases ; - compile_by_size debuginfo value_kind 0 str default cases - end else begin - if dbg then pp_cases stderr "FIRST COL" cases ; - let compile_size_rest str default cases = - compile_by_size debuginfo value_kind 1 str default cases in - match_oncell value_kind compile_size_rest str default 0 (by_cell cases) - end - -(* Module entry point *) - - let catch dbg arg k = match arg with - | Cexit (_e,[],_traps) -> k arg - | _ -> - let e = next_raise_count () in - ccatch (e,[],k (Cexit (Lbl e,[],[])),arg,dbg, Any, false) - - let compile dbg value_kind str default cases = -(* We do not attempt to really optimise default=None *) - let cases,default = match cases,default with - | (_,e)::cases,None - | cases,Some e -> cases,e - | [],None -> assert false in - let cases = - List.rev_map - (fun (s,act) -> pat_of_string s,act) - cases in - catch dbg default (fun default -> top_compile dbg value_kind str default cases) - - end diff --git a/backend/strmatch.mli b/backend/strmatch.mli deleted file mode 100644 index cf167210f15..00000000000 --- a/backend/strmatch.mli +++ /dev/null @@ -1,33 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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 string matching from closed lambda to C-- *) - -module type I = sig - val string_block_length : Cmm.expression -> Cmm.expression - val transl_switch : - Debuginfo.t -> Cmm.kind_for_unboxing -> Cmm.expression -> int -> int -> - (int * Cmm.expression) list -> Cmm.expression -> - Cmm.expression -end - -module Make(_:I) : sig - (* Compile stringswitch (arg,cases,d) - Note: cases should not contain string duplicates *) - val compile : Debuginfo.t -> Cmm.kind_for_unboxing - -> Cmm.expression (* arg *) - -> Cmm.expression option (* d *) -> - (string * Cmm.expression) list (* cases *)-> Cmm.expression -end diff --git a/configure.ac b/configure.ac index 3da06e9e1e7..baa368b98f6 100644 --- a/configure.ac +++ b/configure.ac @@ -28,13 +28,12 @@ AC_MSG_NOTICE([Using dune executable: $dune]) AC_ARG_ENABLE([middle-end], [AS_HELP_STRING([--enable-middle-end], - [Select which middle end to use: closure, flambda or flambda2])], + [Select which middle end to use: flambda2 (default) or upstream-closure])], [AS_CASE([$enable_middle_end], - [closure], [middle_end=closure middle_end_arg=--disable-flambda], - [flambda], [middle_end=flambda middle_end_arg=--enable-flambda], + [upstream-closure], [middle_end=closure middle_end_arg=--disable-flambda], [flambda2], [middle_end=flambda2 middle_end_arg=--enable-flambda2], - [*], [AC_MSG_ERROR([Bad middle end (not closure, flambda or flambda2)])])], - [AC_MSG_ERROR([--enable-middle-end=closure|flambda|flambda2 must be provided])]) + [*], [AC_MSG_ERROR([Invalid middle end: must be flambda2 or upstream-closure])])], + [middle_end=flambda2 middle_end_arg=--enable-flambda2]) AC_ARG_ENABLE([runtime5], [AS_HELP_STRING([--enable-runtime5], diff --git a/driver/compiler_hooks.ml b/driver/compiler_hooks.ml index f27db234d76..2b32792ae99 100644 --- a/driver/compiler_hooks.ml +++ b/driver/compiler_hooks.ml @@ -19,10 +19,6 @@ type _ pass = | Lambda : Lambda.program pass | Raw_flambda2 : Flambda2_terms.Flambda_unit.t pass | Flambda2 : Flambda2_terms.Flambda_unit.t pass - | Raw_flambda1 : Flambda.program pass - | Flambda1 : Flambda.program pass - | Raw_clambda : Clambda.ulambda pass - | Clambda : Clambda.ulambda pass | Mach_polling : Mach.fundecl pass | Mach_combine : Mach.fundecl pass @@ -48,10 +44,6 @@ type t = { mutable lambda : (Lambda.program -> unit) list; mutable raw_flambda2 : (Flambda2_terms.Flambda_unit.t -> unit) list; mutable flambda2 : (Flambda2_terms.Flambda_unit.t -> unit) list; - mutable raw_flambda1 : (Flambda.program -> unit) list; - mutable flambda1 : (Flambda.program -> unit) list; - mutable raw_clambda : (Clambda.ulambda -> unit) list; - mutable clambda : (Clambda.ulambda -> unit) list; mutable mach_polling : (Mach.fundecl -> unit) list; mutable mach_combine : (Mach.fundecl -> unit) list; mutable mach_cse : (Mach.fundecl -> unit) list; @@ -75,10 +67,6 @@ let hooks : t = { lambda = []; raw_flambda2 = []; flambda2 = []; - raw_flambda1 = []; - flambda1 = []; - raw_clambda = []; - clambda = []; mach_polling = []; mach_combine = []; mach_cse = []; @@ -108,10 +96,6 @@ let register : type a. a pass -> (a -> unit) -> unit = | Lambda -> hooks.lambda <- f :: hooks.lambda | Raw_flambda2 -> hooks.raw_flambda2 <- f :: hooks.raw_flambda2 | Flambda2 -> hooks.flambda2 <- f :: hooks.flambda2 - | Raw_flambda1 -> hooks.raw_flambda1 <- f :: hooks.raw_flambda1 - | Flambda1 -> hooks.flambda1 <- f :: hooks.flambda1 - | Raw_clambda -> hooks.clambda <- f :: hooks.clambda - | Clambda -> hooks.clambda <- f :: hooks.clambda | Mach_combine -> hooks.mach_combine <- f :: hooks.mach_combine | Mach_polling -> hooks.mach_polling <- f :: hooks.mach_polling @@ -139,10 +123,6 @@ let execute : type a. a pass -> a -> unit = | Lambda -> execute_hooks hooks.lambda arg | Raw_flambda2 -> execute_hooks hooks.raw_flambda2 arg | Flambda2 -> execute_hooks hooks.flambda2 arg - | Raw_flambda1 -> execute_hooks hooks.raw_flambda1 arg - | Flambda1 -> execute_hooks hooks.flambda1 arg - | Raw_clambda -> execute_hooks hooks.raw_clambda arg - | Clambda -> execute_hooks hooks.clambda arg | Mach_polling -> execute_hooks hooks.mach_polling arg | Mach_combine -> execute_hooks hooks.mach_combine arg | Mach_cse -> execute_hooks hooks.mach_cse arg @@ -169,10 +149,6 @@ let clear : type a. a pass -> unit = | Lambda -> hooks.lambda <- [] | Raw_flambda2 -> hooks.raw_flambda2 <- [] | Flambda2 -> hooks.flambda2 <- [] - | Raw_flambda1 -> hooks.raw_flambda1 <- [] - | Flambda1 -> hooks.flambda1 <- [] - | Raw_clambda -> hooks.raw_clambda <- [] - | Clambda -> hooks.clambda <- [] | Mach_polling -> hooks.mach_polling <- [] | Mach_combine -> hooks.mach_combine <- [] | Mach_cse -> hooks.mach_cse <- [] diff --git a/driver/compiler_hooks.mli b/driver/compiler_hooks.mli index bbcc202ee19..16179076b16 100644 --- a/driver/compiler_hooks.mli +++ b/driver/compiler_hooks.mli @@ -32,10 +32,6 @@ type _ pass = | Lambda : Lambda.program pass | Raw_flambda2 : Flambda2_terms.Flambda_unit.t pass | Flambda2 : Flambda2_terms.Flambda_unit.t pass - | Raw_flambda1 : Flambda.program pass - | Flambda1 : Flambda.program pass - | Raw_clambda : Clambda.ulambda pass - | Clambda : Clambda.ulambda pass | Mach_polling : Mach.fundecl pass | Mach_combine : Mach.fundecl pass diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 07ae088bd24..14b5d668d72 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -68,7 +68,7 @@ let emit unix i = Asmgen.compile_implementation_linear unix i.output_prefix ~progname:i.source_file -let implementation unix ~backend ~(flambda2 : flambda2) ~start_from ~source_file +let implementation unix ~(flambda2 : flambda2) ~start_from ~source_file ~output_prefix ~keep_symbol_tables = let backend info ({ structure; coercion; _ } : Typedtree.implementation) = Compilenv.reset info.module_name; @@ -78,13 +78,7 @@ let implementation unix ~backend ~(flambda2 : flambda2) ~start_from ~source_file else Set_individual_fields in let pipeline : Asmgen.pipeline = - if Config.flambda2 then Direct_to_cmm (flambda2 ~keep_symbol_tables) - else - let middle_end = - if Config.flambda then Flambda_middle_end.lambda_to_clambda - else Closure_middle_end.lambda_to_clambda - in - Via_clambda { middle_end; backend; } + Direct_to_cmm (flambda2 ~keep_symbol_tables) in if not (Config.flambda || Config.flambda2) then Clflags.set_oclassic (); compile info typed ~unix ~transl_style ~pipeline diff --git a/driver/optcompile.mli b/driver/optcompile.mli index 1e808002b38..b8c311df7e3 100644 --- a/driver/optcompile.mli +++ b/driver/optcompile.mli @@ -19,7 +19,6 @@ val interface: source_file:string -> output_prefix:string -> unit val implementation : (module Compiler_owee.Unix_intf.S) - -> backend:(module Backend_intf.S) -> flambda2:( ppf_dump:Format.formatter -> prefixname:string -> diff --git a/driver/optmaindriver.ml b/driver/optmaindriver.ml index 530510cc53c..14ed67d0e75 100644 --- a/driver/optmaindriver.ml +++ b/driver/optmaindriver.ml @@ -15,22 +15,6 @@ open Clflags -module Backend = struct - (* See backend_intf.mli. *) - - let really_import_approx = Import_approx.really_import_approx - let import_symbol = Import_approx.import_symbol - - let size_int = Arch.size_int - let big_endian = Arch.big_endian - - let max_sensible_number_of_arguments = - (* The "-1" is to allow for a potential closure environment parameter. *) - Proc.max_arguments_for_tailcalls - 1 -end - -let backend = (module Backend : Backend_intf.S) - let usage = "Usage: ocamlopt \nOptions are:" module Options = Flambda_backend_args.Make_optcomp_options @@ -83,7 +67,7 @@ let main unix argv ppf ~flambda2 = begin try Compenv.process_deferred_actions (ppf, - Optcompile.implementation unix ~backend ~flambda2, + Optcompile.implementation unix ~flambda2, Optcompile.interface, ".cmx", ".cmxa"); @@ -128,7 +112,7 @@ let main unix argv ppf ~flambda2 = Compmisc.with_ppf_dump ~file_prefix:target (fun ppf_dump -> Asmpackager.package_files unix ~ppf_dump (Compmisc.initial_env ()) - (Compenv.get_objfiles ~with_ocamlparam:false) target ~backend + (Compenv.get_objfiles ~with_ocamlparam:false) target ~flambda2); Warnings.check_fatal (); end diff --git a/dune b/dune index e33eb2380d7..96203ed2753 100755 --- a/dune +++ b/dune @@ -45,12 +45,6 @@ (copy_files# middle_end/*.ml{,i}) -(copy_files# middle_end/closure/*.ml{,i}) - -(copy_files# middle_end/flambda/*.ml{,i}) - -(copy_files# middle_end/flambda/base_types/*.ml{,i}) - (copy_files# ocaml/driver/opterrors.ml{,i}) (copy_files# ocaml/file_formats/cmxs_format.mli) @@ -70,12 +64,9 @@ (instrumentation (backend bisect_ppx)) (modules_without_implementation - backend_intf branch_relaxation_intf cmx_format cmxs_format - inlining_decision_intf - simplify_boxed_integer_ops_intf x86_ast) (modules ;; To match the Makefiles, ocamloptcomp needs to include ocamlmiddleend. @@ -83,89 +74,8 @@ cmx_format cmxs_format ;; middle_end/ - backend_intf - backend_var backend_var - clambda - clambda_primitives - clambda_layout compilenv - mangling - convert_primitives - internal_variable_names - printclambda - printclambda_primitives - semantics_of_primitives - symbol_utils - variable - ;; middle_end/closure/ - closure - closure_middle_end - ;; middle_end/flambda/base_types/ - closure_element - closure_id - closure_origin - export_id - id_types - mutable_variable - set_of_closures_id - set_of_closures_origin - static_exception - tag - var_within_closure - ;; middle_end/flambda/ - alias_analysis - allocated_const - augment_specialised_args - build_export_info - closure_conversion - closure_conversion_aux - closure_offsets - effect_analysis - export_info - extract_projections - find_recursive_functions - flambda - flambda_invariants - flambda_iterators - flambda_middle_end - flambda_to_clambda - flambda_utils - freshening - import_approx - inconstant_idents - initialize_symbol_to_let_symbol - inline_and_simplify - inline_and_simplify_aux - inlining_cost - inlining_decision - inlining_decision_intf - inlining_stats - inlining_stats_types - inlining_transforms - invariant_params - lift_code - lift_constants - lift_let_to_initialize_symbol - parameter - pass_wrapper - projection - ref_to_variables - remove_free_vars_equal_to_args - remove_unused_arguments - remove_unused_closure_vars - remove_unused_program_constructs - share_constants - simple_value_approx - simplify_boxed_integer_ops - simplify_boxed_integer_ops_intf - simplify_common - simplify_primitives - traverse_for_exported_symbols - un_anf - unbox_closures - unbox_free_vars_of_closures - unbox_specialised_args ;; asmcomp/ afl_instrument arch @@ -181,7 +91,6 @@ cmm_builtins cmm_invariants cmm - cmmgen cmmgen_state coloring comballoc @@ -224,7 +133,6 @@ spill split string_table - strmatch symbol_entry symbol_table x86_ast diff --git a/file_formats/cmx_format.mli b/file_formats/cmx_format.mli index ef686fab74c..45351c52ca8 100644 --- a/file_formats/cmx_format.mli +++ b/file_formats/cmx_format.mli @@ -32,13 +32,9 @@ open Misc of these infos *) type export_info = - | Clambda of Clambda.value_approximation - | Flambda1 of Export_info.t | Flambda2 of Flambda2_cmx.Flambda_cmx_format.t option type export_info_raw = - | Clambda_raw of Clambda.value_approximation - | Flambda1_raw of Export_info.t | Flambda2_raw of Flambda2_cmx.Flambda_cmx_format.raw option (* Declare machtype here to avoid depending on [Cmm]. *) diff --git a/middle_end/backend_intf.mli b/middle_end/backend_intf.mli deleted file mode 100644 index 3d2fcba9b97..00000000000 --- a/middle_end/backend_intf.mli +++ /dev/null @@ -1,42 +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"] - -(** Knowledge that the middle end needs about the backend. *) - -module type S = sig - (** If the given approximation is that of a symbol (Value_symbol) or an - external (Value_extern), attempt to find a more informative - approximation from a previously-written compilation artifact. In the - native code backend, for example, this might consult a .cmx file. *) - val really_import_approx : Simple_value_approx.t -> Simple_value_approx.t - - val import_symbol : Symbol.t -> Simple_value_approx.t - - (** The natural size of an integer on the target architecture - (cf. [Arch.size_int] in the native code backend). *) - val size_int : int - - (** [true] iff the target architecture is big endian. *) - val big_endian : bool - - (** The maximum number of arguments that is reasonable for a function - to have. This should be fewer than the threshold that causes non-self - tail call optimization to be inhibited (in particular, if it would - entail passing arguments on the stack; see [Selectgen]). *) - val max_sensible_number_of_arguments : int -end diff --git a/middle_end/clambda.ml b/middle_end/clambda.ml deleted file mode 100644 index 2c87efdc443..00000000000 --- a/middle_end/clambda.ml +++ /dev/null @@ -1,240 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(* A variant of the "lambda" code with direct / indirect calls explicit - and closures explicit too *) - -open Asttypes -open Lambda - -type function_label = string -type arity = { - function_kind : Lambda.function_kind ; - params_layout : Lambda.layout list ; - return_layout : Lambda.layout ; -} -type apply_kind = Lambda.region_close * Lambda.alloc_mode - -type ustructured_constant = - | Uconst_float of float - | Uconst_int32 of int32 - | Uconst_int64 of int64 - | Uconst_nativeint of nativeint - | Uconst_vec128 of { high : int64; low : int64 } - | Uconst_block of int * uconstant list - | Uconst_float_array of float list - | Uconst_string of string - | Uconst_closure of ufunction list * string * uconstant list - -and uconstant = - | Uconst_ref of string * ustructured_constant option - | Uconst_int of int - -and uphantom_defining_expr = - | Uphantom_const of uconstant - | Uphantom_var of Backend_var.t - | Uphantom_offset_var of { var : Backend_var.t; offset_in_words : int; } - | Uphantom_read_field of { var : Backend_var.t; field : int; } - | Uphantom_read_symbol_field of { sym : string; field : int; } - | Uphantom_block of { tag : int; fields : Backend_var.t list; } - -and ulambda = - Uvar of Backend_var.t - | Uconst of uconstant - | Udirect_apply of - function_label * ulambda list * Lambda.probe * Lambda.layout * apply_kind * Debuginfo.t - | Ugeneric_apply of - ulambda * ulambda list * Lambda.layout list * Lambda.layout * apply_kind * Debuginfo.t - | Uclosure of { - functions : ufunction list ; - not_scanned_slots : ulambda list ; - scanned_slots : ulambda list ; - } - | Uoffset of ulambda * int - | Ulet of mutable_flag * layout * Backend_var.With_provenance.t - * ulambda * ulambda - | Uphantom_let of Backend_var.With_provenance.t - * uphantom_defining_expr option * ulambda - | Uletrec of (Backend_var.With_provenance.t * ulambda) list * ulambda - | Uprim of Clambda_primitives.primitive * ulambda list * Debuginfo.t - | Uswitch of ulambda * ulambda_switch * Debuginfo.t * layout - | Ustringswitch of - ulambda * - (string * ulambda) list * - ulambda option * - layout - | Ustaticfail of int * ulambda list - | Ucatch of - int * - (Backend_var.With_provenance.t * layout) list * - ulambda * - ulambda * - layout - | Utrywith of - ulambda * - Backend_var.With_provenance.t * - ulambda * - layout - | Uifthenelse of ulambda * ulambda * ulambda * layout - | Usequence of ulambda * ulambda - | Uwhile of ulambda * ulambda - | Ufor of Backend_var.With_provenance.t * ulambda * ulambda - * direction_flag * ulambda - | Uassign of Backend_var.t * ulambda - | Usend of - meth_kind * ulambda * ulambda * ulambda list - * Lambda.layout list * Lambda.layout * apply_kind * Debuginfo.t - | Uunreachable - | Uregion of ulambda - | Uexclave of ulambda - -and ufunction = { - label : function_label; - arity : arity; - params : Backend_var.With_provenance.t list; - body : ulambda; - dbg : Debuginfo.t; - env : Backend_var.t option; - poll : poll_attribute; - mode : Lambda.alloc_mode; - check : Lambda.check_attribute; -} - -and ulambda_switch = - { us_index_consts: int array; - us_actions_consts : ulambda array; - us_index_blocks: int array; - us_actions_blocks: ulambda array} - -(* Description of known functions *) - -type function_description = - { fun_label: function_label; (* Label of direct entry point *) - fun_arity: arity; (* Number of (curried/tupled) arguments *) - mutable fun_closed: bool; (* True if environment not used *) - mutable fun_inline: (Backend_var.With_provenance.t list * ulambda) option; - mutable fun_float_const_prop: bool; (* Can propagate FP consts *) - fun_poll: poll_attribute; (* Error on poll/alloc/call *) - fun_region: bool; (* If false, may locally allocate - in caller's region *) - fun_argmodes: Lambda.alloc_mode list; - fun_retmode: Lambda.alloc_mode; - } - -(* Approximation of values *) - -type value_approximation = - Value_closure of alloc_mode * function_description * value_approximation - | Value_tuple of alloc_mode * value_approximation array - | Value_unknown - | Value_const of uconstant - | Value_global_field of string * int - -(* Preallocated globals *) - -type usymbol_provenance = { - original_idents : Ident.t list; - module_path : Path.t; -} - -type uconstant_block_field = - | Uconst_field_ref of string - | Uconst_field_int of int - -type preallocated_block = { - symbol : string; - exported : bool; - tag : int; - fields : uconstant_block_field option list; - provenance : usymbol_provenance option; -} - -type preallocated_constant = { - symbol : string; - exported : bool; - definition : ustructured_constant; - provenance : usymbol_provenance option; -} - -type with_constants = - ulambda * preallocated_block list * preallocated_constant list - -(* Comparison functions for constants. We must not use Stdlib.compare - because it compares "0.0" and "-0.0" equal. (PR#6442) *) - -let compare_floats x1 x2 = - Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2) - -let rec compare_float_lists l1 l2 = - match l1, l2 with - | [], [] -> 0 - | [], _::_ -> -1 - | _::_, [] -> 1 - | h1::t1, h2::t2 -> - let c = compare_floats h1 h2 in - if c <> 0 then c else compare_float_lists t1 t2 - -let compare_constants c1 c2 = - match c1, c2 with - | Uconst_ref(lbl1, _c1), Uconst_ref(lbl2, _c2) -> String.compare lbl1 lbl2 - (* Same labels -> same constants. - Different labels -> different constants, even if the contents - match, because of string constants that must not be - reshared. *) - | Uconst_int n1, Uconst_int n2 -> Stdlib.compare n1 n2 - | Uconst_ref _, _ -> -1 - | Uconst_int _, Uconst_ref _ -> 1 - -let rec compare_constant_lists l1 l2 = - match l1, l2 with - | [], [] -> 0 - | [], _::_ -> -1 - | _::_, [] -> 1 - | h1::t1, h2::t2 -> - let c = compare_constants h1 h2 in - if c <> 0 then c else compare_constant_lists t1 t2 - -let rank_structured_constant = function - | Uconst_float _ -> 0 - | Uconst_int32 _ -> 1 - | Uconst_int64 _ -> 2 - | Uconst_nativeint _ -> 3 - | Uconst_block _ -> 4 - | Uconst_float_array _ -> 5 - | Uconst_string _ -> 6 - | Uconst_closure _ -> 7 - | Uconst_vec128 _ -> 8 - -let compare_structured_constants c1 c2 = - match c1, c2 with - | Uconst_float x1, Uconst_float x2 -> compare_floats x1 x2 - | Uconst_int32 x1, Uconst_int32 x2 -> Int32.compare x1 x2 - | Uconst_int64 x1, Uconst_int64 x2 -> Int64.compare x1 x2 - | Uconst_nativeint x1, Uconst_nativeint x2 -> Nativeint.compare x1 x2 - | Uconst_block(t1, l1), Uconst_block(t2, l2) -> - let c = t1 - t2 (* no overflow possible here *) in - if c <> 0 then c else compare_constant_lists l1 l2 - | Uconst_float_array l1, Uconst_float_array l2 -> - compare_float_lists l1 l2 - | Uconst_string s1, Uconst_string s2 -> String.compare s1 s2 - | Uconst_closure (_,lbl1,_), Uconst_closure (_,lbl2,_) -> - String.compare lbl1 lbl2 - | Uconst_vec128 { high = l0; low = l1}, - Uconst_vec128 { high = r0; low = r1} -> - let cmp = Int64.compare l0 r0 in - if cmp = 0 then Int64.compare l1 r1 else cmp - | _, _ -> - (* no overflow possible here *) - rank_structured_constant c1 - rank_structured_constant c2 diff --git a/middle_end/clambda.mli b/middle_end/clambda.mli deleted file mode 100644 index 1a805c93be5..00000000000 --- a/middle_end/clambda.mli +++ /dev/null @@ -1,188 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(* A variant of the "lambda" code with direct / indirect calls explicit - and closures explicit too *) - -open Asttypes -open Lambda - -type function_label = string -type arity = { - function_kind : Lambda.function_kind ; - params_layout : Lambda.layout list ; - return_layout : Lambda.layout ; -} -type apply_kind = Lambda.region_close * Lambda.alloc_mode - -type ustructured_constant = - | Uconst_float of float - | Uconst_int32 of int32 - | Uconst_int64 of int64 - | Uconst_nativeint of nativeint - | Uconst_vec128 of { high : int64; low : int64 } - | Uconst_block of int * uconstant list - | Uconst_float_array of float list - | Uconst_string of string - | Uconst_closure of ufunction list * string * uconstant list - -and uconstant = - | Uconst_ref of string * ustructured_constant option - | Uconst_int of int - -and uphantom_defining_expr = - | Uphantom_const of uconstant - (** The phantom-let-bound variable is a constant. *) - | Uphantom_var of Backend_var.t - (** The phantom-let-bound variable is an alias for another variable. *) - | Uphantom_offset_var of { var : Backend_var.t; offset_in_words : int; } - (** The phantom-let-bound-variable's value is defined by adding the given - number of words to the pointer contained in the given identifier. *) - | Uphantom_read_field of { var : Backend_var.t; field : int; } - (** The phantom-let-bound-variable's value is found by adding the given - number of words to the pointer contained in the given identifier, then - dereferencing. *) - | Uphantom_read_symbol_field of { sym : string; field : int; } - (** As for [Uphantom_read_var_field], but with the pointer specified by - a symbol. *) - | Uphantom_block of { tag : int; fields : Backend_var.t list; } - (** The phantom-let-bound variable points at a block with the given - structure. *) - -and ulambda = - Uvar of Backend_var.t - | Uconst of uconstant - | Udirect_apply of - function_label * ulambda list * Lambda.probe * Lambda.layout * apply_kind * Debuginfo.t - | Ugeneric_apply of - ulambda * ulambda list * Lambda.layout list * Lambda.layout * apply_kind * Debuginfo.t - | Uclosure of { - functions : ufunction list ; - not_scanned_slots : ulambda list ; - scanned_slots : ulambda list - } - | Uoffset of ulambda * int - | Ulet of mutable_flag * layout * Backend_var.With_provenance.t - * ulambda * ulambda - | Uphantom_let of Backend_var.With_provenance.t - * uphantom_defining_expr option * ulambda - | Uletrec of (Backend_var.With_provenance.t * ulambda) list * ulambda - | Uprim of Clambda_primitives.primitive * ulambda list * Debuginfo.t - | Uswitch of ulambda * ulambda_switch * Debuginfo.t * Lambda.layout - | Ustringswitch of - ulambda * - (string * ulambda) list * - ulambda option * - Lambda.layout - | Ustaticfail of int * ulambda list - | Ucatch of - int * - (Backend_var.With_provenance.t * layout) list * - ulambda * - ulambda * - Lambda.layout - | Utrywith of - ulambda * - Backend_var.With_provenance.t * - ulambda * - Lambda.layout - | Uifthenelse of ulambda * ulambda * ulambda * Lambda.layout - | Usequence of ulambda * ulambda - | Uwhile of ulambda * ulambda - | Ufor of Backend_var.With_provenance.t * ulambda * ulambda - * direction_flag * ulambda - | Uassign of Backend_var.t * ulambda - | Usend of - meth_kind * ulambda * ulambda * ulambda list - * Lambda.layout list * Lambda.layout * apply_kind * Debuginfo.t - | Uunreachable - | Uregion of ulambda - | Uexclave of ulambda - -and ufunction = { - label : function_label; - arity : arity; - params : Backend_var.With_provenance.t list; - body : ulambda; - dbg : Debuginfo.t; - env : Backend_var.t option; - poll : poll_attribute; - mode : Lambda.alloc_mode; - check : Lambda.check_attribute; -} - -and ulambda_switch = - { us_index_consts: int array; - us_actions_consts: ulambda array; - us_index_blocks: int array; - us_actions_blocks: ulambda array} - -(* Description of known functions *) - -type function_description = - { fun_label: function_label; (* Label of direct entry point *) - fun_arity: arity; (* Number of (curried/tupled) arguments *) - mutable fun_closed: bool; (* True if environment not used *) - mutable fun_inline: (Backend_var.With_provenance.t list * ulambda) option; - mutable fun_float_const_prop: bool; (* Can propagate FP consts *) - fun_poll: poll_attribute; (* Behaviour for polls *) - fun_region: bool; (* If false, may locally allocate - in caller's region *) - fun_argmodes: Lambda.alloc_mode list; - fun_retmode: Lambda.alloc_mode; - } - -(* Approximation of values *) - -type value_approximation = - Value_closure of alloc_mode * function_description * value_approximation - | Value_tuple of alloc_mode * value_approximation array - | Value_unknown - | Value_const of uconstant - | Value_global_field of string * int - -(* Comparison functions for constants *) - -val compare_structured_constants: - ustructured_constant -> ustructured_constant -> int -val compare_constants: - uconstant -> uconstant -> int - -type usymbol_provenance = { - original_idents : Ident.t list; - module_path : Path.t; -} - -type uconstant_block_field = - | Uconst_field_ref of string - | Uconst_field_int of int - -type preallocated_block = { - symbol : string; - exported : bool; - tag : int; - fields : uconstant_block_field option list; - provenance : usymbol_provenance option; -} - -type preallocated_constant = { - symbol : string; - exported : bool; - definition : ustructured_constant; - provenance : usymbol_provenance option; -} - -type with_constants = - ulambda * preallocated_block list * preallocated_constant list diff --git a/middle_end/clambda_layout.ml b/middle_end/clambda_layout.ml deleted file mode 100644 index eb42d032d25..00000000000 --- a/middle_end/clambda_layout.ml +++ /dev/null @@ -1,136 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* *) -(* Copyright 2023 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. *) -(* *) -(**************************************************************************) - -type atom = - | Value - | Value_int - | Unboxed_float - | Unboxed_int of Lambda.boxed_integer - | Unboxed_vector of Lambda.boxed_vector - -let rec fold_left_layout (f : 'acc -> 'e -> atom -> 'acc) (acc : 'acc) - (expr : Clambda.ulambda) (layout : Clambda_primitives.layout) : 'acc = - match layout with - | Ptop -> Misc.fatal_error "[Ptop] can't be stored in a closure." - | Pbottom -> - Misc.fatal_error - "[Pbottom] should have been eliminated as dead code and not stored in a \ - closure." - | Punboxed_float -> f acc expr Unboxed_float - | Punboxed_int bi -> f acc expr (Unboxed_int bi) - | Punboxed_vector bv -> f acc expr (Unboxed_vector bv) - | Pvalue Pintval -> f acc expr Value_int - | Pvalue _ -> f acc expr Value - | Punboxed_product layouts -> - List.fold_left - (fun acc (field, layout) -> - let expr : Clambda.ulambda = - Uprim (Punboxed_product_field (field, layouts), [expr], Debuginfo.none) - in - fold_left_layout f acc expr layout) - acc - (List.mapi (fun i v -> i, v) layouts) - -type ('visible, 'invisible) decomposition' = - | Gc_visible of ('visible * atom) - | Gc_invisible of ('invisible * atom) - | Product of ('visible, 'invisible) decomposition' array - -type decomposition = - | Atom of - { offset : int; - layout : atom - } - | Product of decomposition array - -let print_atom ppf = function - | Value -> Format.fprintf ppf "val" - | Value_int -> Format.fprintf ppf "int" - | Unboxed_float -> Format.fprintf ppf "#float" - | Unboxed_int Pint32 -> Format.fprintf ppf "unboxed_int32" - | Unboxed_int Pint64 -> Format.fprintf ppf "unboxed_int64" - | Unboxed_int Pnativeint -> Format.fprintf ppf "unboxed_nativeint" - | Unboxed_vector (Pvec128 _) -> Format.fprintf ppf "unboxed_vec128" - -let equal_decomposition = ( = ) - -let rec print_decomposition ppf dec = - match dec with - | Atom { offset; layout } -> - Format.fprintf ppf "(%d: %a)" offset print_atom layout - | Product a -> - Format.fprintf ppf "@[[%a]@]" - (Format.pp_print_list ~pp_sep:Format.pp_print_space print_decomposition) - (Array.to_list a) - -let rec decompose (layout : Lambda.layout) : _ decomposition' = - match layout with - | Ptop -> Misc.fatal_error "[Ptop] can't be stored in a closure." - | Pbottom -> - Misc.fatal_error - "[Pbottom] should have been eliminated as dead code and not stored in a \ - closure." - | Punboxed_float -> Gc_invisible ((), Unboxed_float) - | Punboxed_int bi -> Gc_invisible ((), Unboxed_int bi) - | Punboxed_vector bv -> Gc_invisible ((), Unboxed_vector bv) - | Pvalue Pintval -> Gc_invisible ((), Value_int) - | Pvalue _ -> Gc_visible ((), Value) - | Punboxed_product l -> Product (Array.of_list (List.map decompose l)) - -let rec solidify (dec : (int, int) decomposition') : decomposition = - match dec with - | Gc_visible (offset, layout) -> Atom { offset; layout } - | Gc_invisible (offset, layout) -> Atom { offset; layout } - | Product a -> Product (Array.map solidify a) - -let rec fold_decompose (f1 : 'acc -> 'a -> atom -> 'acc * 'b) - (f2 : 'acc -> 'c -> atom -> 'acc * 'd) (acc : 'acc) - (d : ('a, 'c) decomposition') : 'acc * ('b, 'd) decomposition' = - match d with - | Gc_visible (v, layout) -> - let acc, v = f1 acc v layout in - acc, Gc_visible (v, layout) - | Gc_invisible (v, layout) -> - let acc, v = f2 acc v layout in - acc, Gc_invisible (v, layout) - | Product elts -> - let acc, elts = Array.fold_left_map (fold_decompose f1 f2) acc elts in - acc, Product elts - -let atom_size (layout : atom) = - match layout with - | Value | Value_int | Unboxed_float | Unboxed_int _ -> 1 - | Unboxed_vector (Pvec128 _) -> 2 - -let assign_invisible_offsets init_pos (var, dec) = - let f_visible acc () _layout = acc, () in - let f_invisible acc () layout = acc + atom_size layout, acc in - let acc, dec = fold_decompose f_visible f_invisible init_pos dec in - acc, (var, dec) - -let assign_visible_offsets init_pos (var, dec) = - let f_visible acc () layout = acc + atom_size layout, acc in - let f_invisible acc off _layout = acc, off in - let acc, dec = fold_decompose f_visible f_invisible init_pos dec in - acc, (var, solidify dec) - -let decompose_free_vars ~base_offset ~free_vars = - let free_vars = List.map (fun (var, kind) -> var, decompose kind) free_vars in - let base_offset, free_vars = - List.fold_left_map assign_invisible_offsets base_offset free_vars - in - let _base_offset, free_vars = - List.fold_left_map assign_visible_offsets base_offset free_vars - in - free_vars diff --git a/middle_end/clambda_layout.mli b/middle_end/clambda_layout.mli deleted file mode 100644 index 79d94d0b8cc..00000000000 --- a/middle_end/clambda_layout.mli +++ /dev/null @@ -1,43 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* *) -(* Copyright 2023 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. *) -(* *) -(**************************************************************************) - -type atom = - | Value - | Value_int - | Unboxed_float - | Unboxed_int of Lambda.boxed_integer - | Unboxed_vector of Lambda.boxed_vector - -val fold_left_layout : - ('acc -> Clambda.ulambda -> atom -> 'acc) -> - 'acc -> - Clambda.ulambda -> - Clambda_primitives.layout -> - 'acc - -type decomposition = - | Atom of - { offset : int; - layout : atom - } - | Product of decomposition array - -val equal_decomposition : decomposition -> decomposition -> bool - -val print_decomposition : Format.formatter -> decomposition -> unit - -val decompose_free_vars : - base_offset:int -> - free_vars:('a * Clambda_primitives.layout) list -> - ('a * decomposition) list diff --git a/middle_end/clambda_primitives.ml b/middle_end/clambda_primitives.ml deleted file mode 100644 index 7d83894e78c..00000000000 --- a/middle_end/clambda_primitives.ml +++ /dev/null @@ -1,299 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -type mutable_flag = Lambda.mutable_flag - -type immediate_or_pointer = Lambda.immediate_or_pointer - -type initialization_or_assignment = Lambda.initialization_or_assignment - -type is_safe = Lambda.is_safe - -type boxed = - | Boxed - | Unboxed - -type memory_access_size = - | Sixteen - | Thirty_two - | Sixty_four - | One_twenty_eight of { aligned : bool } - -type alloc_mode = Lambda.alloc_mode - -type modify_mode = Lambda.modify_mode - -type primitive = - | Pread_symbol of string - (* Operations on heap blocks *) - | Pmakeblock of int * mutable_flag * block_shape * alloc_mode - | Pmakeufloatblock of mutable_flag * alloc_mode - | Pfield of int * layout * immediate_or_pointer * mutable_flag - | Pfield_computed - | Psetfield of int * immediate_or_pointer * initialization_or_assignment - | Psetfield_computed of immediate_or_pointer * initialization_or_assignment - | Pfloatfield of int * alloc_mode - | Psetfloatfield of int * initialization_or_assignment - | Pufloatfield of int - | Psetufloatfield of int * initialization_or_assignment - | Pduprecord of Types.record_representation * int - (* Context switches *) - | Prunstack - | Pperform - | Presume - | Preperform - (* External call *) - | Pccall of Primitive.description - (* Exceptions *) - | Praise of raise_kind - (* Boolean operations *) - | Psequand | Psequor | Pnot - (* Integer operations *) - | Pnegint | Paddint | Psubint | Pmulint - | Pdivint of is_safe | Pmodint of is_safe - | Pandint | Porint | Pxorint - | Plslint | Plsrint | Pasrint - | Pintcomp of integer_comparison - | Pcompare_ints | Pcompare_floats | Pcompare_bints of boxed_integer - | Poffsetint of int - | Poffsetref of int - (* Float operations *) - | Pintoffloat | Pfloatofint of alloc_mode - | Pnegfloat of alloc_mode | Pabsfloat of alloc_mode - | Paddfloat of alloc_mode | Psubfloat of alloc_mode - | Pmulfloat of alloc_mode | Pdivfloat of alloc_mode - | Pfloatcomp of float_comparison - | Punboxed_float_comp of float_comparison - (* String operations *) - | Pstringlength | Pstringrefu | Pstringrefs - | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets - (* Array operations *) - | Pmakearray of array_kind * mutable_flag * alloc_mode - | Pduparray of array_kind * mutable_flag - (** For [Pduparray], the argument must be an immutable array. - The arguments of [Pduparray] give the kind and mutability of the - array being *produced* by the duplication. *) - | Parraylength of array_kind - | Parrayrefu of array_ref_kind - | Parraysetu of array_set_kind - | Parrayrefs of array_ref_kind - | Parraysets of array_set_kind - (* Test if the argument is a block or an immediate integer *) - | Pisint - (* Test if the (integer) argument is outside an interval *) - | Pisout - (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *) - | Pbintofint of boxed_integer * alloc_mode - | Pintofbint of boxed_integer - | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*) - * alloc_mode - | Pnegbint of boxed_integer * alloc_mode - | Paddbint of boxed_integer * alloc_mode - | Psubbint of boxed_integer * alloc_mode - | Pmulbint of boxed_integer * alloc_mode - | Pdivbint of { size : boxed_integer; is_safe : is_safe; mode: alloc_mode } - | Pmodbint of { size : boxed_integer; is_safe : is_safe; mode: alloc_mode } - | Pandbint of boxed_integer * alloc_mode - | Porbint of boxed_integer * alloc_mode - | Pxorbint of boxed_integer * alloc_mode - | Plslbint of boxed_integer * alloc_mode - | Plsrbint of boxed_integer * alloc_mode - | Pasrbint of boxed_integer * alloc_mode - | Pbintcomp of boxed_integer * integer_comparison - (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) - | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout - | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout - (* size of the nth dimension of a big array *) - | Pbigarraydim of int - (* load/set 16,32,64 bits from a string: (unsafe)*) - | Pstring_load of (memory_access_size * is_safe * alloc_mode) - | Pbytes_load of (memory_access_size * is_safe * alloc_mode) - | Pbytes_set of (memory_access_size * is_safe) - (* load/set 16,32,64 bits from a - (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *) - | Pbigstring_load of (memory_access_size * is_safe * alloc_mode) - | Pbigstring_set of (memory_access_size * is_safe) - (* byte swap *) - | Pbswap16 - | Pbbswap of boxed_integer * alloc_mode - (* Integer to external pointer *) - | Pint_as_pointer of alloc_mode - (* Atomic operations *) - | Patomic_load of {immediate_or_pointer : immediate_or_pointer} - | Patomic_exchange - | Patomic_cas - | Patomic_fetch_add - (* Inhibition of optimisation *) - | Popaque - (* Probes *) - | Pprobe_is_enabled of { name : string } - | Punbox_float - | Pbox_float of alloc_mode - | Punbox_int of boxed_integer - | Pbox_int of boxed_integer * alloc_mode - | Pmake_unboxed_product of layout list - | Punboxed_product_field of int * (layout list) - | Pget_header of alloc_mode - (* Fetch domain-local state *) - | Pdls_get - -and integer_comparison = Lambda.integer_comparison = - Ceq | Cne | Clt | Cgt | Cle | Cge - -and float_comparison = Lambda.float_comparison = - CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge - -and array_kind = Lambda.array_kind = - Pgenarray | Paddrarray | Pintarray | Pfloatarray - -and array_ref_kind = Lambda.array_ref_kind = - | Pgenarray_ref of alloc_mode - | Paddrarray_ref - | Pintarray_ref - | Pfloatarray_ref of alloc_mode - -and array_set_kind = Lambda.array_set_kind = - | Pgenarray_set of modify_mode - | Paddrarray_set of modify_mode - | Pintarray_set - | Pfloatarray_set - -and value_kind = Lambda.value_kind = - (* CR mshinwell: Pfloatval should be renamed to Pboxedfloatval *) - Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval - | Pvariant of { - consts : int list; - non_consts : (int * value_kind list) list; - } - | Parrayval of array_kind - | Pboxedvectorval of boxed_vector - -and layout = Lambda.layout = - | Ptop - | Pvalue of value_kind - | Punboxed_float - | Punboxed_int of boxed_integer - | Punboxed_vector of boxed_vector - | Punboxed_product of layout list - | Pbottom - -and block_shape = Lambda.block_shape -and boxed_integer = Primitive.boxed_integer = - Pnativeint | Pint32 | Pint64 - -and vec128_type = Lambda.vec128_type = - | Unknown128 - | Int8x16 - | Int16x8 - | Int32x4 - | Int64x2 - | Float32x4 - | Float64x2 - -and boxed_vector = Lambda.boxed_vector = - | Pvec128 of vec128_type - -and bigarray_kind = Lambda.bigarray_kind = - Pbigarray_unknown - | Pbigarray_float32 | Pbigarray_float64 - | Pbigarray_sint8 | Pbigarray_uint8 - | Pbigarray_sint16 | Pbigarray_uint16 - | Pbigarray_int32 | Pbigarray_int64 - | Pbigarray_caml_int | Pbigarray_native_int - | Pbigarray_complex32 | Pbigarray_complex64 - -and bigarray_layout = Lambda.bigarray_layout = - Pbigarray_unknown_layout - | Pbigarray_c_layout - | Pbigarray_fortran_layout - -and raise_kind = Lambda.raise_kind = - | Raise_regular - | Raise_reraise - | Raise_notrace - -let equal (x: primitive) (y: primitive) = x = y - -let result_layout (p : primitive) = - match p with - | Psetfield _ | Psetfield_computed _ | Psetfloatfield _ | Poffsetref _ - | Psetufloatfield _ - | Pbytessetu | Pbytessets | Parraysetu _ | Parraysets _ | Pbigarrayset _ - -> Lambda.layout_unit - | Pmakeblock _ | Pmakearray _ | Pduprecord _ - | Pmakeufloatblock _ - | Pduparray _ | Pbigarraydim _ -> Lambda.layout_block - | Pfield _ | Pfield_computed -> Lambda.layout_field - | Punboxed_product_field (field, layouts) -> (Array.of_list layouts).(field) - | Pmake_unboxed_product layouts -> Lambda.layout_unboxed_product layouts - | Pfloatfield _ | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ - | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ - | Pbox_float _ -> Lambda.layout_boxed_float - | Pufloatfield _ | Punbox_float -> Punboxed_float - | Pccall { prim_native_repr_res = _, repr_res } -> Lambda.layout_of_native_repr repr_res - | Praise _ -> Lambda.layout_bottom - | Psequor | Psequand | Pnot - | Pnegint | Paddint | Psubint | Pmulint - | Pdivint _ | Pmodint _ - | Pandint | Porint | Pxorint - | Plslint | Plsrint | Pasrint - | Pintcomp _ - | Pcompare_ints | Pcompare_floats | Pcompare_bints _ - | Poffsetint _ | Pintoffloat | Pfloatcomp _ | Punboxed_float_comp _ - | Pstringlength | Pstringrefu | Pstringrefs - | Pbyteslength | Pbytesrefu | Pbytesrefs - | Parraylength _ | Pisint | Pisout | Pintofbint _ - | Pbintcomp _ - | Pprobe_is_enabled _ | Pbswap16 - -> Lambda.layout_int - | Parrayrefu array_ref_kind | Parrayrefs array_ref_kind -> - Lambda.array_ref_kind_result_layout array_ref_kind - | Pbintofint (bi, _) | Pcvtbint (_,bi,_) - | Pnegbint (bi, _) | Paddbint (bi, _) | Psubbint (bi, _) - | Pmulbint (bi, _) | Pdivbint {size = bi} | Pmodbint {size = bi} - | Pandbint (bi, _) | Porbint (bi, _) | Pxorbint (bi, _) - | Plslbint (bi, _) | Plsrbint (bi, _) | Pasrbint (bi, _) - | Pbbswap (bi, _) | Pbox_int (bi, _) -> - Lambda.layout_boxedint bi - | Punbox_int bi -> Punboxed_int bi - | Pbigarrayref (_, _, kind, _) -> - begin match kind with - | Pbigarray_unknown -> Lambda.layout_any_value - | Pbigarray_float32 | Pbigarray_float64 -> Lambda.layout_boxed_float - | Pbigarray_sint8 | Pbigarray_uint8 - | Pbigarray_sint16 | Pbigarray_uint16 - | Pbigarray_caml_int -> Lambda.layout_int - | Pbigarray_int32 -> Lambda.layout_boxedint Pint32 - | Pbigarray_int64 -> Lambda.layout_boxedint Pint64 - | Pbigarray_native_int -> Lambda.layout_boxedint Pnativeint - | Pbigarray_complex32 | Pbigarray_complex64 -> - Lambda.layout_block - end - | Pint_as_pointer _ -> - (* CR ncourant: use an unboxed int64 here when it exists *) - Lambda.layout_any_value - | Pget_header _ -> Lambda.layout_boxedint Pnativeint - | Prunstack | Presume | Pperform | Preperform -> - (* CR mshinwell/ncourant: to be thought about later *) - Misc.fatal_error "Effects-related primitives are not yet supported" - | Patomic_load { immediate_or_pointer = Immediate } -> Lambda.layout_int - | Patomic_load { immediate_or_pointer = Pointer } -> Lambda.layout_any_value - | Patomic_exchange - | Patomic_cas - | Patomic_fetch_add - | Pdls_get - | Popaque | Pread_symbol _ - | Pstring_load _ | Pbytes_load _ | Pbytes_set _ | Pbigstring_load _ - | Pbigstring_set _ -> Lambda.layout_any_value diff --git a/middle_end/clambda_primitives.mli b/middle_end/clambda_primitives.mli deleted file mode 100644 index 6278918fb38..00000000000 --- a/middle_end/clambda_primitives.mli +++ /dev/null @@ -1,234 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -type mutable_flag = Lambda.mutable_flag - -type immediate_or_pointer = Lambda.immediate_or_pointer - -type initialization_or_assignment = Lambda.initialization_or_assignment - -type is_safe = Lambda.is_safe - -type boxed = - | Boxed - | Unboxed - -type memory_access_size = - | Sixteen - | Thirty_two - | Sixty_four - | One_twenty_eight of { aligned : bool } - -type alloc_mode = Lambda.alloc_mode - -type modify_mode = Lambda.modify_mode - -type primitive = - | Pread_symbol of string - (* Operations on heap blocks *) - | Pmakeblock of int * mutable_flag * block_shape * alloc_mode - | Pmakeufloatblock of mutable_flag * alloc_mode - | Pfield of int * layout * immediate_or_pointer * mutable_flag - | Pfield_computed - | Psetfield of int * immediate_or_pointer * initialization_or_assignment - | Psetfield_computed of immediate_or_pointer * initialization_or_assignment - | Pfloatfield of int * alloc_mode - | Psetfloatfield of int * initialization_or_assignment - | Pufloatfield of int - | Psetufloatfield of int * initialization_or_assignment - | Pduprecord of Types.record_representation * int - (* Context switches *) - | Prunstack - | Pperform - | Presume - | Preperform - (* External call *) - | Pccall of Primitive.description - (* Exceptions *) - | Praise of raise_kind - (* Boolean operations *) - | Psequand | Psequor | Pnot - (* Integer operations *) - | Pnegint | Paddint | Psubint | Pmulint - | Pdivint of is_safe | Pmodint of is_safe - | Pandint | Porint | Pxorint - | Plslint | Plsrint | Pasrint - | Pintcomp of integer_comparison - | Pcompare_ints | Pcompare_floats | Pcompare_bints of boxed_integer - | Poffsetint of int - | Poffsetref of int - (* Float operations *) - | Pintoffloat | Pfloatofint of alloc_mode - | Pnegfloat of alloc_mode | Pabsfloat of alloc_mode - | Paddfloat of alloc_mode | Psubfloat of alloc_mode - | Pmulfloat of alloc_mode | Pdivfloat of alloc_mode - | Pfloatcomp of float_comparison - | Punboxed_float_comp of float_comparison - (* String operations *) - | Pstringlength | Pstringrefu | Pstringrefs - | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets - (* Array operations *) - | Pmakearray of array_kind * mutable_flag * alloc_mode - (** For [Pmakearray], the list of arguments must not be empty. The empty - array should be represented by a distinguished constant in the middle - end. *) - | Pduparray of array_kind * mutable_flag - (** For [Pduparray], the argument must be an immutable array. - The arguments of [Pduparray] give the kind and mutability of the - array being *produced* by the duplication. *) - | Parraylength of array_kind - | Parrayrefu of array_ref_kind - | Parraysetu of array_set_kind - | Parrayrefs of array_ref_kind - | Parraysets of array_set_kind - (* Test if the argument is a block or an immediate integer *) - | Pisint - (* Test if the (integer) argument is outside an interval *) - | Pisout - (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *) - | Pbintofint of boxed_integer * alloc_mode - | Pintofbint of boxed_integer - | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*) - * alloc_mode - | Pnegbint of boxed_integer * alloc_mode - | Paddbint of boxed_integer * alloc_mode - | Psubbint of boxed_integer * alloc_mode - | Pmulbint of boxed_integer * alloc_mode - | Pdivbint of { size : boxed_integer; is_safe : is_safe; mode: alloc_mode } - | Pmodbint of { size : boxed_integer; is_safe : is_safe; mode: alloc_mode } - | Pandbint of boxed_integer * alloc_mode - | Porbint of boxed_integer * alloc_mode - | Pxorbint of boxed_integer * alloc_mode - | Plslbint of boxed_integer * alloc_mode - | Plsrbint of boxed_integer * alloc_mode - | Pasrbint of boxed_integer * alloc_mode - | Pbintcomp of boxed_integer * integer_comparison - (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) - | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout - | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout - (* size of the nth dimension of a big array *) - | Pbigarraydim of int - (* load/set 16,32,64 bits from a string: (unsafe)*) - | Pstring_load of (memory_access_size * is_safe * alloc_mode) - | Pbytes_load of (memory_access_size * is_safe * alloc_mode) - | Pbytes_set of (memory_access_size * is_safe) - (* load/set 16,32,64 bits from a - (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *) - | Pbigstring_load of (memory_access_size * is_safe * alloc_mode) - | Pbigstring_set of (memory_access_size * is_safe) - (* byte swap *) - | Pbswap16 - | Pbbswap of boxed_integer * alloc_mode - (* Integer to external pointer *) - | Pint_as_pointer of alloc_mode - (* Atomic operations *) - | Patomic_load of {immediate_or_pointer : immediate_or_pointer} - | Patomic_exchange - | Patomic_cas - | Patomic_fetch_add - (* Inhibition of optimisation *) - | Popaque - (* Probes *) - | Pprobe_is_enabled of { name : string } - | Punbox_float - | Pbox_float of alloc_mode - | Punbox_int of boxed_integer - | Pbox_int of boxed_integer * alloc_mode - | Pmake_unboxed_product of layout list - | Punboxed_product_field of int * (layout list) - | Pget_header of alloc_mode - (* Fetch domain-local state *) - | Pdls_get - - -and integer_comparison = Lambda.integer_comparison = - Ceq | Cne | Clt | Cgt | Cle | Cge - -and float_comparison = Lambda.float_comparison = - CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge - -and array_kind = Lambda.array_kind = - Pgenarray | Paddrarray | Pintarray | Pfloatarray - -and array_ref_kind = Lambda.array_ref_kind = - | Pgenarray_ref of alloc_mode - | Paddrarray_ref - | Pintarray_ref - | Pfloatarray_ref of alloc_mode - -and array_set_kind = Lambda.array_set_kind = - | Pgenarray_set of modify_mode - | Paddrarray_set of modify_mode - | Pintarray_set - | Pfloatarray_set - -and value_kind = Lambda.value_kind = - (* CR mshinwell: Pfloatval should be renamed to Pboxedfloatval *) - Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval - | Pvariant of { - consts : int list; - non_consts : (int * value_kind list) list; - } - | Parrayval of array_kind - | Pboxedvectorval of boxed_vector - -and layout = Lambda.layout = - | Ptop - | Pvalue of value_kind - | Punboxed_float - | Punboxed_int of boxed_integer - | Punboxed_vector of boxed_vector - | Punboxed_product of layout list - | Pbottom - -and block_shape = Lambda.block_shape - -and boxed_integer = Primitive.boxed_integer = - Pnativeint | Pint32 | Pint64 - -and vec128_type = Lambda.vec128_type = - | Unknown128 - | Int8x16 - | Int16x8 - | Int32x4 - | Int64x2 - | Float32x4 - | Float64x2 - -and boxed_vector = Lambda.boxed_vector = - | Pvec128 of vec128_type - -and bigarray_kind = Lambda.bigarray_kind = - Pbigarray_unknown - | Pbigarray_float32 | Pbigarray_float64 - | Pbigarray_sint8 | Pbigarray_uint8 - | Pbigarray_sint16 | Pbigarray_uint16 - | Pbigarray_int32 | Pbigarray_int64 - | Pbigarray_caml_int | Pbigarray_native_int - | Pbigarray_complex32 | Pbigarray_complex64 - -and bigarray_layout = Lambda.bigarray_layout = - Pbigarray_unknown_layout - | Pbigarray_c_layout - | Pbigarray_fortran_layout - -and raise_kind = Lambda.raise_kind = - | Raise_regular - | Raise_reraise - | Raise_notrace - -val equal : primitive -> primitive -> bool - -val result_layout : primitive -> Lambda.layout diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml deleted file mode 100644 index aca0f5af029..00000000000 --- a/middle_end/closure/closure.ml +++ /dev/null @@ -1,1882 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(* Introduction of closures, uncurrying, recognition of direct calls *) - -open Misc -open Primitive -open Lambda -open Switch -open Clambda -module P = Clambda_primitives - -module Int = Numbers.Int -module Storer = - Switch.Store - (struct - type t = lambda - type key = lambda - let make_key = Lambda.make_key - let compare_key = Stdlib.compare - end) - -module V = Backend_var -module VP = Backend_var.With_provenance - -(* The current backend *) - -let no_phantom_lets () = - Misc.fatal_error "Closure does not support phantom let generation" - -(* Auxiliary for accessing globals. We change the name of the global - to the name of the corresponding asm symbol. This is done here - and no longer in Cmmgen so that approximations stored in .cmx files - contain the right names if the -for-pack option is active. *) - -let getsymbol dbg symbol = - let symbol = Symbol.linkage_name symbol |> Linkage_name.to_string in - Uprim (P.Pread_symbol symbol, [], dbg) - -let getglobal dbg cu = - getsymbol dbg (Symbol.for_compilation_unit cu) - -let getpredef dbg id = - getsymbol dbg (Symbol.for_predef_ident id) - -let region ulam = - let is_trivial = - match ulam with - | Uvar _ | Uconst _ -> true - | _ -> false - in - if is_trivial then ulam - else Uregion ulam - -let exclave ulam = - let is_trivial = - match ulam with - | Uvar _ | Uconst _ -> true - | _ -> false - in - if is_trivial then ulam - else Uexclave ulam - -(* Check if a variable occurs in a [clambda] term. *) - -let occurs_var var u = - let rec occurs = function - Uvar v -> v = var - | Uconst _ -> false - | Udirect_apply(_lbl, args, _, _, _, _) -> List.exists occurs args - | Ugeneric_apply(funct, args, _, _, _, _) -> - occurs funct || List.exists occurs args - | Uclosure { functions = _ ; not_scanned_slots ; scanned_slots } -> - List.exists occurs not_scanned_slots || List.exists occurs scanned_slots - | Uoffset(u, _ofs) -> occurs u - | Ulet(_str, _kind, _id, def, body) -> occurs def || occurs body - | Uphantom_let _ -> no_phantom_lets () - | Uletrec(decls, body) -> - List.exists (fun (_id, u) -> occurs u) decls || occurs body - | Uprim(_p, args, _) -> List.exists occurs args - | Uswitch(arg, s, _dbg, _kind) -> - occurs arg || - occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks - | Ustringswitch(arg,sw,d, _kind) -> - occurs arg || - List.exists (fun (_,e) -> occurs e) sw || - (match d with None -> false | Some d -> occurs d) - | Ustaticfail (_, args) -> List.exists occurs args - | Ucatch(_, _, body, hdlr, _) -> occurs body || occurs hdlr - | Utrywith(body, _exn, hdlr, _kind) -> occurs body || occurs hdlr - | Uifthenelse(cond, ifso, ifnot, _kind) -> - occurs cond || occurs ifso || occurs ifnot - | Usequence(u1, u2) -> occurs u1 || occurs u2 - | Uwhile(cond, body) -> occurs cond || occurs body - | Ufor(_id, lo, hi, _dir, body) -> occurs lo || occurs hi || occurs body - | Uassign(id, u) -> id = var || occurs u - | Usend(_, met, obj, args, _, _, _, _) -> - occurs met || occurs obj || List.exists occurs args - | Uunreachable -> false - | Uregion e -> occurs e - | Uexclave e -> occurs e - and occurs_array a = - try - for i = 0 to Array.length a - 1 do - if occurs a.(i) then raise Exit - done; - false - with Exit -> - true - in occurs u - -(* Determine whether the estimated size of a clambda term is below - some threshold *) - -let prim_size prim args = - let open Clambda_primitives in - match prim with - | Pread_symbol _ -> 1 - | Pmakeblock _ -> 5 + List.length args - | Pfield _ -> 1 - | Psetfield(_f, isptr, init) -> - begin match init with - | Root_initialization -> 1 (* never causes a write barrier hit *) - | Assignment _ | Heap_initialization -> - match isptr with - | Pointer -> 4 - | Immediate -> 1 - end - | Pfloatfield _ -> 1 - | Psetfloatfield _ -> 1 - | Pduprecord _ -> 10 + List.length args - | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args - | Praise _ -> 4 - | Pstringlength -> 5 - | Pbyteslength -> 5 - | Pstringrefs -> 6 - | Pbytesrefs | Pbytessets -> 6 - | Pmakearray _ -> 5 + List.length args - | Parraylength kind -> if kind = Pgenarray then 6 else 2 - | Parrayrefu kind -> (match kind with Pgenarray_ref _ -> 12 | _ -> 2) - | Parraysetu kind -> (match kind with Pgenarray_set _ -> 16 | _ -> 4) - | Parrayrefs kind -> (match kind with Pgenarray_ref _ -> 18 | _ -> 8) - | Parraysets kind -> (match kind with Pgenarray_set _ -> 22 | _ -> 10) - | Pbigarrayref(_, ndims, _, _) -> 4 + ndims * 6 - | Pbigarrayset(_, ndims, _, _) -> 4 + ndims * 6 - | Pprobe_is_enabled _ -> 4 (* Pgetglobal and a comparison *) - | _ -> 2 (* arithmetic and comparisons *) - -(* Very raw approximation of switch cost *) - -let lambda_smaller lam threshold = - let size = ref 0 in - let rec lambda_size lam = - if !size > threshold then raise Exit; - match lam with - Uvar _ -> () - | Uconst _ -> incr size - | Udirect_apply(_, args, None, _, _, _) -> - size := !size + 4; lambda_list_size args - | Udirect_apply _ -> () - (* We aim for probe points to not affect inlining decisions. - Actual cost is either 1, 5 or 6 bytes, depending on their kind, - on x86-64. *) - | Ugeneric_apply(fn, args, _, _, _, _) -> - size := !size + 6; lambda_size fn; lambda_list_size args - | Uclosure _ -> - raise Exit (* inlining would duplicate function definitions *) - | Uoffset(lam, _ofs) -> - incr size; lambda_size lam - | Ulet(_str, _kind, _id, lam, body) -> - lambda_size lam; lambda_size body - | Uphantom_let _ -> no_phantom_lets () - | Uletrec _ -> - raise Exit (* usually too large *) - | Uprim(prim, args, _) -> - size := !size + prim_size prim args; - lambda_list_size args - | Uswitch(lam, cases, _dbg, _kind) -> - if Array.length cases.us_actions_consts > 1 then size := !size + 5 ; - if Array.length cases.us_actions_blocks > 1 then size := !size + 5 ; - lambda_size lam; - lambda_array_size cases.us_actions_consts ; - lambda_array_size cases.us_actions_blocks - | Ustringswitch (lam,sw,d, _kind) -> - lambda_size lam ; - (* as ifthenelse *) - List.iter - (fun (_,lam) -> - size := !size+2 ; - lambda_size lam) - sw ; - Option.iter lambda_size d - | Ustaticfail (_,args) -> lambda_list_size args - | Ucatch(_, _, body, handler, _kind) -> - incr size; lambda_size body; lambda_size handler - | Utrywith(body, _id, handler, _kind) -> - size := !size + 8; lambda_size body; lambda_size handler - | Uifthenelse(cond, ifso, ifnot, _kind) -> - size := !size + 2; - lambda_size cond; lambda_size ifso; lambda_size ifnot - | Usequence(lam1, lam2) -> - lambda_size lam1; lambda_size lam2 - | Uwhile(cond, body) -> - size := !size + 2; lambda_size cond; lambda_size body - | Ufor(_id, low, high, _dir, body) -> - size := !size + 4; lambda_size low; lambda_size high; lambda_size body - | Uassign(_id, lam) -> - incr size; lambda_size lam - | Usend(_, met, obj, args, _, _, _, _) -> - size := !size + 8; - lambda_size met; lambda_size obj; lambda_list_size args - | Uunreachable -> () - | Uregion e -> - size := !size + 2; - lambda_size e - | Uexclave e -> - lambda_size e - and lambda_list_size l = List.iter lambda_size l - and lambda_array_size a = Array.iter lambda_size a in - try - lambda_size lam; !size <= threshold - with Exit -> - false - -let is_pure_prim p = - let open Semantics_of_primitives in - match Semantics_of_primitives.for_primitive p with - | (No_effects | Only_generative_effects), _ -> true - | Arbitrary_effects, _ -> false - -(* Check if a clambda term is ``pure'', - that is without side-effects *and* not containing function definitions - (Pure terms may still read mutable state) *) - -let rec is_pure = function - Uvar _ -> true - | Uconst _ -> true - | Uprim(p, args, _) -> is_pure_prim p && List.for_all is_pure args - | Uoffset(arg, _) -> is_pure arg - | Ulet(Immutable, _, _var, def, body) -> - is_pure def && is_pure body - | Uregion body -> is_pure body - | Uexclave body -> is_pure body - | _ -> false - -(* Simplify primitive operations on known arguments *) - -let make_const c = (Uconst c, Value_const c) -let make_const_ref c = - make_const(Uconst_ref(Compilenv.new_structured_constant ~shared:true c, - Some c)) -let make_const_int n = make_const (Uconst_int n) -let make_const_bool b = make_const_int(if b then 1 else 0) - -let make_integer_comparison cmp x y = - let open Clambda_primitives in - make_const_bool - (match cmp with - Ceq -> x = y - | Cne -> x <> y - | Clt -> x < y - | Cgt -> x > y - | Cle -> x <= y - | Cge -> x >= y) - -let make_float_comparison cmp x y = - make_const_bool - (match cmp with - | CFeq -> x = y - | CFneq -> not (x = y) - | CFlt -> x < y - | CFnlt -> not (x < y) - | CFgt -> x > y - | CFngt -> not (x > y) - | CFle -> x <= y - | CFnle -> not (x <= y) - | CFge -> x >= y - | CFnge -> not (x >= y)) - -let make_const_float n = make_const_ref (Uconst_float n) -let make_const_natint n = make_const_ref (Uconst_nativeint n) -let make_const_int32 n = make_const_ref (Uconst_int32 n) -let make_const_int64 n = make_const_ref (Uconst_int64 n) - -(* The [fpc] parameter is true if constant propagation of - floating-point computations is allowed *) - -let simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg = - let module B = (val backend : Backend_intf.S) in - let open Clambda_primitives in - let default = (Uprim(p, args, dbg), Value_unknown) in - match approxs with - (* int (or enumerated type) *) - | [ Value_const(Uconst_int n1) ] -> - begin match p with - | Pnot -> make_const_bool (n1 = 0) - | Pnegint -> make_const_int (- n1) - | Poffsetint n -> make_const_int (n + n1) - | Pfloatofint _ when fpc -> make_const_float (float_of_int n1) - | Pbintofint (Pnativeint,_) -> make_const_natint (Nativeint.of_int n1) - | Pbintofint (Pint32,_) -> make_const_int32 (Int32.of_int n1) - | Pbintofint (Pint64,_) -> make_const_int64 (Int64.of_int n1) - | Pbswap16 -> make_const_int (((n1 land 0xff) lsl 8) - lor ((n1 land 0xff00) lsr 8)) - | _ -> default - end - (* int (or enumerated type), int (or enumerated type) *) - | [ Value_const(Uconst_int n1); - Value_const(Uconst_int n2) ] -> - begin match p with - | Psequand -> make_const_bool (n1 <> 0 && n2 <> 0) - | Psequor -> make_const_bool (n1 <> 0 || n2 <> 0) - | Paddint -> make_const_int (n1 + n2) - | Psubint -> make_const_int (n1 - n2) - | Pmulint -> make_const_int (n1 * n2) - | Pdivint _ when n2 <> 0 -> make_const_int (n1 / n2) - | Pmodint _ when n2 <> 0 -> make_const_int (n1 mod n2) - | Pandint -> make_const_int (n1 land n2) - | Porint -> make_const_int (n1 lor n2) - | Pxorint -> make_const_int (n1 lxor n2) - | Plslint when 0 <= n2 && n2 < 8 * B.size_int -> - make_const_int (n1 lsl n2) - | Plsrint when 0 <= n2 && n2 < 8 * B.size_int -> - make_const_int (n1 lsr n2) - | Pasrint when 0 <= n2 && n2 < 8 * B.size_int -> - make_const_int (n1 asr n2) - | Pintcomp c -> make_integer_comparison c n1 n2 - | _ -> default - end - (* float *) - | [Value_const(Uconst_ref(_, Some (Uconst_float n1)))] when fpc -> - begin match p with - | Pintoffloat -> make_const_int (int_of_float n1) - | Pnegfloat _ -> make_const_float (-. n1) - | Pabsfloat _ -> make_const_float (abs_float n1) - | _ -> default - end - (* float, float *) - | [Value_const(Uconst_ref(_, Some (Uconst_float n1))); - Value_const(Uconst_ref(_, Some (Uconst_float n2)))] when fpc -> - begin match p with - | Paddfloat _ -> make_const_float (n1 +. n2) - | Psubfloat _ -> make_const_float (n1 -. n2) - | Pmulfloat _ -> make_const_float (n1 *. n2) - | Pdivfloat _ -> make_const_float (n1 /. n2) - | Pfloatcomp c -> make_float_comparison c n1 n2 - | _ -> default - end - (* nativeint *) - | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n)))] -> - begin match p with - | Pintofbint Pnativeint -> make_const_int (Nativeint.to_int n) - | Pcvtbint(Pnativeint, Pint32, _) -> make_const_int32 (Nativeint.to_int32 n) - | Pcvtbint(Pnativeint, Pint64, _) -> make_const_int64 (Int64.of_nativeint n) - | Pnegbint (Pnativeint,_) -> make_const_natint (Nativeint.neg n) - | _ -> default - end - (* nativeint, nativeint *) - | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1))); - Value_const(Uconst_ref(_, Some (Uconst_nativeint n2)))] -> - begin match p with - | Paddbint (Pnativeint,_) -> make_const_natint (Nativeint.add n1 n2) - | Psubbint (Pnativeint,_) -> make_const_natint (Nativeint.sub n1 n2) - | Pmulbint (Pnativeint,_) -> make_const_natint (Nativeint.mul n1 n2) - | Pdivbint {size=Pnativeint} when n2 <> 0n -> - make_const_natint (Nativeint.div n1 n2) - | Pmodbint {size=Pnativeint} when n2 <> 0n -> - make_const_natint (Nativeint.rem n1 n2) - | Pandbint (Pnativeint,_) -> make_const_natint (Nativeint.logand n1 n2) - | Porbint (Pnativeint,_) -> make_const_natint (Nativeint.logor n1 n2) - | Pxorbint (Pnativeint,_) -> make_const_natint (Nativeint.logxor n1 n2) - | Pbintcomp(Pnativeint, c) -> make_integer_comparison c n1 n2 - | _ -> default - end - (* nativeint, int *) - | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1))); - Value_const(Uconst_int n2)] -> - begin match p with - | Plslbint (Pnativeint,_) when 0 <= n2 && n2 < 8 * B.size_int -> - make_const_natint (Nativeint.shift_left n1 n2) - | Plsrbint (Pnativeint,_) when 0 <= n2 && n2 < 8 * B.size_int -> - make_const_natint (Nativeint.shift_right_logical n1 n2) - | Pasrbint (Pnativeint,_) when 0 <= n2 && n2 < 8 * B.size_int -> - make_const_natint (Nativeint.shift_right n1 n2) - | _ -> default - end - (* int32 *) - | [Value_const(Uconst_ref(_, Some (Uconst_int32 n)))] -> - begin match p with - | Pintofbint Pint32 -> make_const_int (Int32.to_int n) - | Pcvtbint(Pint32, Pnativeint,_) -> make_const_natint (Nativeint.of_int32 n) - | Pcvtbint(Pint32, Pint64,_) -> make_const_int64 (Int64.of_int32 n) - | Pnegbint(Pint32,_) -> make_const_int32 (Int32.neg n) - | _ -> default - end - (* int32, int32 *) - | [Value_const(Uconst_ref(_, Some (Uconst_int32 n1))); - Value_const(Uconst_ref(_, Some (Uconst_int32 n2)))] -> - begin match p with - | Paddbint(Pint32,_) -> make_const_int32 (Int32.add n1 n2) - | Psubbint(Pint32,_) -> make_const_int32 (Int32.sub n1 n2) - | Pmulbint(Pint32,_) -> make_const_int32 (Int32.mul n1 n2) - | Pdivbint {size=Pint32} when n2 <> 0l -> - make_const_int32 (Int32.div n1 n2) - | Pmodbint {size=Pint32} when n2 <> 0l -> - make_const_int32 (Int32.rem n1 n2) - | Pandbint(Pint32,_) -> make_const_int32 (Int32.logand n1 n2) - | Porbint(Pint32,_) -> make_const_int32 (Int32.logor n1 n2) - | Pxorbint(Pint32,_) -> make_const_int32 (Int32.logxor n1 n2) - | Pbintcomp(Pint32, c) -> make_integer_comparison c n1 n2 - | _ -> default - end - (* int32, int *) - | [Value_const(Uconst_ref(_, Some (Uconst_int32 n1))); - Value_const(Uconst_int n2)] -> - begin match p with - | Plslbint(Pint32,_) when 0 <= n2 && n2 < 32 -> - make_const_int32 (Int32.shift_left n1 n2) - | Plsrbint(Pint32,_) when 0 <= n2 && n2 < 32 -> - make_const_int32 (Int32.shift_right_logical n1 n2) - | Pasrbint(Pint32,_) when 0 <= n2 && n2 < 32 -> - make_const_int32 (Int32.shift_right n1 n2) - | _ -> default - end - (* int64 *) - | [Value_const(Uconst_ref(_, Some (Uconst_int64 n)))] -> - begin match p with - | Pintofbint Pint64 -> make_const_int (Int64.to_int n) - | Pcvtbint(Pint64, Pint32,_) -> make_const_int32 (Int64.to_int32 n) - | Pcvtbint(Pint64, Pnativeint,_) -> make_const_natint (Int64.to_nativeint n) - | Pnegbint(Pint64,_) -> make_const_int64 (Int64.neg n) - | _ -> default - end - (* int64, int64 *) - | [Value_const(Uconst_ref(_, Some (Uconst_int64 n1))); - Value_const(Uconst_ref(_, Some (Uconst_int64 n2)))] -> - begin match p with - | Paddbint(Pint64,_) -> make_const_int64 (Int64.add n1 n2) - | Psubbint(Pint64,_) -> make_const_int64 (Int64.sub n1 n2) - | Pmulbint(Pint64,_) -> make_const_int64 (Int64.mul n1 n2) - | Pdivbint {size=Pint64} when n2 <> 0L -> - make_const_int64 (Int64.div n1 n2) - | Pmodbint {size=Pint64} when n2 <> 0L -> - make_const_int64 (Int64.rem n1 n2) - | Pandbint(Pint64,_) -> make_const_int64 (Int64.logand n1 n2) - | Porbint(Pint64,_) -> make_const_int64 (Int64.logor n1 n2) - | Pxorbint(Pint64,_) -> make_const_int64 (Int64.logxor n1 n2) - | Pbintcomp(Pint64, c) -> make_integer_comparison c n1 n2 - | _ -> default - end - (* int64, int *) - | [Value_const(Uconst_ref(_, Some (Uconst_int64 n1))); - Value_const(Uconst_int n2)] -> - begin match p with - | Plslbint(Pint64,_) when 0 <= n2 && n2 < 64 -> - make_const_int64 (Int64.shift_left n1 n2) - | Plsrbint(Pint64,_) when 0 <= n2 && n2 < 64 -> - make_const_int64 (Int64.shift_right_logical n1 n2) - | Pasrbint(Pint64,_) when 0 <= n2 && n2 < 64 -> - make_const_int64 (Int64.shift_right n1 n2) - | _ -> default - end - (* TODO: Pbbswap *) - (* Catch-all *) - | _ -> - default - -let field_approx n = function - | Value_tuple (_,a) when n < Array.length a -> a.(n) - | Value_const (Uconst_ref(_, Some (Uconst_block(_, l)))) - when n < List.length l -> - Value_const (List.nth l n) - | _ -> Value_unknown - -let simplif_prim_pure ~backend fpc p (args, approxs) dbg = - let open Clambda_primitives in - match p, args, approxs with - (* Block construction *) - | Pmakeblock(tag, Immutable, _kind, mode), _, _ -> - let field = function - | Value_const c -> c - | _ -> raise Exit - in - begin try - let cst = Uconst_block (tag, List.map field approxs) in - let name = - Compilenv.new_structured_constant cst ~shared:true - in - make_const (Uconst_ref (name, Some cst)) - with Exit -> - (Uprim(p, args, dbg), Value_tuple (mode, Array.of_list approxs)) - end - (* Field access *) - | Pfield (n, _, _, _), _, - [ Value_const(Uconst_ref(_, Some (Uconst_block(_, l)))) ] - when n < List.length l -> - make_const (List.nth l n) - | Pfield (n, _, _, _), [ Uprim(P.Pmakeblock _, ul, _) ], [approx] - when n < List.length ul -> - (* This case is particularly useful for removing allocations - for optional parameters *) - (List.nth ul n, field_approx n approx) - (* Strings *) - | (Pstringlength | Pbyteslength), - _, - [ Value_const(Uconst_ref(_, Some (Uconst_string s))) ] -> - make_const_int (String.length s) - (* Kind test *) - | Pisint, [ Uprim(P.Pmakeblock _, _, _) ], _ -> - (* This case is particularly useful for removing allocations - for optional parameters *) - make_const_bool false - | Pisint, _, [a1] -> - begin match a1 with - | Value_const(Uconst_int _) -> make_const_bool true - | Value_const(Uconst_ref _) -> make_const_bool false - | Value_closure _ | Value_tuple _ -> make_const_bool false - | _ -> (Uprim(p, args, dbg), Value_unknown) - end - (* Catch-all *) - | _ -> - simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg - -let simplif_prim ~backend fpc p (args, approxs as args_approxs) dbg = - if List.for_all is_pure args - then simplif_prim_pure ~backend fpc p args_approxs dbg - else - (* XXX : always return the same approxs as simplif_prim_pure? *) - let approx = - match p with - | P.Pmakeblock(_, Immutable, _kind, mode) -> - Value_tuple (mode, Array.of_list approxs) - | _ -> - Value_unknown - in - (Uprim(p, args, dbg), approx) - -(* Substitute variables in a [ulambda] term (a body of an inlined function) - and perform some more simplifications on integer primitives. - Also perform alpha-conversion on let-bound identifiers to avoid - clashes with locally-generated identifiers, and refresh raise counts - in order to avoid clashes with inlined code from other modules. - The variables must not be assigned in the term. - This is used to substitute "trivial" arguments for parameters - during inline expansion, and also for the translation of let rec - over functions. *) - -let approx_ulam = function - Uconst c -> Value_const c - | _ -> Value_unknown - -let find_action idxs acts tag = - if 0 <= tag && tag < Array.length idxs then begin - let idx = idxs.(tag) in - assert(0 <= idx && idx < Array.length acts); - Some acts.(idx) - end else - (* Can this happen? *) - None - -let subst_debuginfo loc dbg = - if !Clflags.debug then - Debuginfo.inline loc dbg - else - dbg - -let rec substitute loc ((backend, fpc) as st) sb rn ulam = - match ulam with - Uvar v -> - begin try V.Map.find v sb with Not_found -> ulam end - | Uconst _ -> ulam - | Udirect_apply(lbl, args, probe, return_layout, kind, dbg) -> - let dbg = subst_debuginfo loc dbg in - Udirect_apply(lbl, List.map (substitute loc st sb rn) args, - probe, return_layout, kind, dbg) - | Ugeneric_apply(fn, args, args_layout, return_layout, kind, dbg) -> - let dbg = subst_debuginfo loc dbg in - Ugeneric_apply(substitute loc st sb rn fn, - List.map (substitute loc st sb rn) args, - args_layout, return_layout, kind, dbg) - | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> - (* Question: should we rename function labels as well? Otherwise, - there is a risk that function labels are not globally unique. - This should not happen in the current system because: - - Inlined function bodies contain no Uclosure nodes - (cf. function [lambda_smaller]) - - When we substitute offsets for idents bound by let rec - in [close], case [Lletrec], we discard the original - let rec body and use only the substituted term. *) - let subst = substitute loc st sb rn in - Uclosure { - functions ; - not_scanned_slots = List.map subst not_scanned_slots ; - scanned_slots = List.map subst scanned_slots - } - | Uoffset(u, ofs) -> Uoffset(substitute loc st sb rn u, ofs) - | Ulet(str, kind, id, u1, u2) -> - let id' = VP.rename id in - Ulet(str, kind, id', substitute loc st sb rn u1, - substitute loc st - (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2) - | Uphantom_let _ -> no_phantom_lets () - | Uletrec(bindings, body) -> - let bindings1 = - List.map (fun (id, rhs) -> - (VP.var id, VP.rename id, rhs)) bindings - in - let sb' = - List.fold_right (fun (id, id', _) s -> - V.Map.add id (Uvar (VP.var id')) s) - bindings1 sb - in - Uletrec( - List.map - (fun (_id, id', rhs) -> (id', substitute loc st sb' rn rhs)) - bindings1, - substitute loc st sb' rn body) - | Uprim(p, args, dbg) -> - let sargs = List.map (substitute loc st sb rn) args in - let dbg = subst_debuginfo loc dbg in - let (res, _) = - simplif_prim ~backend fpc p (sargs, List.map approx_ulam sargs) dbg in - res - | Uswitch(arg, sw, dbg, kind) -> - let sarg = substitute loc st sb rn arg in - let action = - (* Unfortunately, we cannot easily deal with the - case of a constructed block (makeblock) bound to a local - identifier. This would require to keep track of - local let bindings (at least their approximations) - in this substitute function. - *) - match sarg with - | Uconst (Uconst_ref (_, Some (Uconst_block (tag, _)))) -> - find_action sw.us_index_blocks sw.us_actions_blocks tag - | Uconst (Uconst_int tag) -> - find_action sw.us_index_consts sw.us_actions_consts tag - | _ -> None - in - begin match action with - | Some u -> substitute loc st sb rn u - | None -> - Uswitch(sarg, - { sw with - us_actions_consts = - Array.map (substitute loc st sb rn) sw.us_actions_consts; - us_actions_blocks = - Array.map (substitute loc st sb rn) sw.us_actions_blocks; - }, - dbg, - kind) - end - | Ustringswitch(arg,sw,d,kind) -> - Ustringswitch - (substitute loc st sb rn arg, - List.map (fun (s,act) -> s,substitute loc st sb rn act) sw, - Option.map (substitute loc st sb rn) d, - kind) - | Ustaticfail (nfail, args) -> - let nfail = - match rn with - | Some rn -> - begin try - Int.Map.find nfail rn - with Not_found -> - fatal_errorf "Closure.split_list: invalid nfail (%d)" nfail - end - | None -> nfail in - Ustaticfail (nfail, List.map (substitute loc st sb rn) args) - | Ucatch(nfail, ids, u1, u2, kind) -> - let nfail, rn = - match rn with - | Some rn -> - let new_nfail = next_raise_count () in - new_nfail, Some (Int.Map.add nfail new_nfail rn) - | None -> nfail, rn in - let ids' = List.map (fun (id, k) -> VP.rename id, k) ids in - let sb' = - List.fold_right2 - (fun (id, _) (id', _) s -> - V.Map.add (VP.var id) (Uvar (VP.var id')) s - ) - ids ids' sb - in - Ucatch(nfail, ids', substitute loc st sb rn u1, - substitute loc st sb' rn u2, - kind) - | Utrywith(u1, id, u2, kind) -> - let id' = VP.rename id in - Utrywith(substitute loc st sb rn u1, id', - substitute loc st - (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2, kind) - | Uifthenelse(u1, u2, u3, kind) -> - begin match substitute loc st sb rn u1 with - Uconst (Uconst_int n) -> - if n <> 0 then - substitute loc st sb rn u2 - else - substitute loc st sb rn u3 - | su1 -> - Uifthenelse(su1, substitute loc st sb rn u2, - substitute loc st sb rn u3, kind) - end - | Usequence(u1, u2) -> - Usequence(substitute loc st sb rn u1, substitute loc st sb rn u2) - | Uwhile(u1, u2) -> - Uwhile(substitute loc st sb rn u1, substitute loc st sb rn u2) - | Ufor(id, u1, u2, dir, u3) -> - let id' = VP.rename id in - Ufor(id', substitute loc st sb rn u1, substitute loc st sb rn u2, dir, - substitute loc st - (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u3) - | Uassign(id, u) -> - let id' = - try - match V.Map.find id sb with Uvar i -> i | _ -> assert false - with Not_found -> - id in - Uassign(id', substitute loc st sb rn u) - | Usend(k, u1, u2, ul, args_layout, result_layout, pos, dbg) -> - let dbg = subst_debuginfo loc dbg in - Usend(k, substitute loc st sb rn u1, substitute loc st sb rn u2, - List.map (substitute loc st sb rn) ul, args_layout, result_layout, pos, dbg) - | Uunreachable -> - Uunreachable - | Uregion e -> - region (substitute loc st sb rn e) - | Uexclave e -> - exclave (substitute loc st sb rn e) - -type env = { - backend : (module Backend_intf.S); - cenv : ulambda V.Map.t; - fenv : value_approximation V.Map.t; - mutable_vars : V.Set.t; - kinds: layout V.Map.t; - catch_env : int Int.Map.t; -} - -(* Perform an inline expansion: - - If [f p = body], substitute [f a] by [let p = a in body]. - - Under certain conditions, further simplifications are possible (we use the - terminology of [Semantics_of_primitives], applied to terms of the Clambda - language): - - - [f a] is equivalent to [body[a/p]] if [a] has no effects and no coeffects. - However, we only want to do this rewriting if [body[a/p]] does not increase - the size of [body]. Since this is hard to decide in general, as an - approximation, only consider the case when [a] is an immutable variable or - a constant. - - - [f a] is equivalent to [body] if [p] does not occur in [body] and [a] has - only generative effects. - - - In general [f a] is equivalent to [a; body] if [p] does not occur in - [body]. -*) - -(* Approximates "no effects and no coeffects" *) -let rec is_substituable ~mutable_vars = function - | Uvar v -> not (V.Set.mem v mutable_vars) - | Uconst _ -> true - | Uoffset(arg, _) -> is_substituable ~mutable_vars arg - | _ -> false - -(* Approximates "only generative effects" *) -let is_erasable = function - | Uclosure _ -> true - | u -> is_pure u - -let bind_params { backend; mutable_vars; _ } loc fdesc params args funct body = - let fpc = fdesc.fun_float_const_prop in - let rec aux subst pl al body = - match (pl, al) with - ([], []) -> substitute (Debuginfo.from_location loc) (backend, fpc) - subst (Some Int.Map.empty) body - | (p1 :: pl, (layout1, a1) :: al) -> - if is_substituable ~mutable_vars a1 then - aux (V.Map.add (VP.var p1) a1 subst) pl al body - else begin - let p1' = VP.rename p1 in - let u1, u2, layout = - let p1_name = VP.name p1 in - match a1 with - | Uprim(P.Pmakeblock(0, Immutable, kind, mode), [a], dbg) - when String.starts_with ~prefix:"*opt*" p1_name -> - (* This parameter corresponds to an optional parameter, - and although it is used twice pushing the expression down - actually allows us to remove the allocation as it will - appear once under a Pisint primitive and once under a Pfield - primitive (see [simplif_prim_pure]) *) - a, Uprim(P.Pmakeblock(0, Immutable, kind, mode), - [Uvar (VP.var p1')], dbg), - Lambda.layout_field - | _ -> - a1, Uvar (VP.var p1'), layout1 - in - let body' = aux (V.Map.add (VP.var p1) u2 subst) pl al body in - if occurs_var (VP.var p1) body then - Ulet(Immutable, layout, p1', u1, body') - else if is_erasable a1 then body' - else Usequence(a1, body') - end - | (_, _) -> assert false - in - (* Reverse parameters and arguments to preserve right-to-left - evaluation order (PR#2910). *) - let params, args = List.rev params, List.rev args in - let params, args, body = - (* Ensure funct is evaluated after args *) - match params with - | my_closure :: params when not fdesc.fun_closed -> - (params @ [my_closure]), (args @ [Lambda.layout_function, funct]), body - | _ -> - params, args, (if is_pure funct then body else Usequence (funct, body)) - in - aux V.Map.empty params args body - -let warning_if_forced_inlined ~loc ~attribute warning = - if attribute = Always_inlined then - Location.prerr_warning (Debuginfo.Scoped_location.to_location loc) - (Warnings.Inlining_impossible warning) - -let fail_if_probe ~(probe : Lambda.probe) msg = - match probe with - | None -> () - | Some {name} -> - Misc.fatal_errorf "Closure probe %s handler: %s" name msg - -(* Generate a direct application *) - -let direct_apply env fundesc ufunct uargs pos result_layout mode ~probe ~loc ~attribute = - match fundesc.fun_inline, attribute with - | _, Never_inlined - | None, _ -> - let dbg = Debuginfo.from_location loc in - let kind = (pos, mode) in - warning_if_forced_inlined ~loc ~attribute - "Function information unavailable"; - if not fundesc.fun_closed then begin - fail_if_probe ~probe "Not closed" - end; - begin match probe, attribute with - | None, _ -> () - | Some _, Never_inlined -> () - | Some _, _ -> - fail_if_probe ~probe "Erroneously marked to be inlined" - end; - if fundesc.fun_closed && is_pure ufunct then - Udirect_apply(fundesc.fun_label, List.map snd uargs, probe, result_layout, kind, dbg) - else if not fundesc.fun_closed && - is_substituable ~mutable_vars:env.mutable_vars ufunct then - Udirect_apply(fundesc.fun_label, List.map snd uargs @ [ufunct], probe, result_layout, kind, dbg) - else begin - let args = List.map (fun (layout, arg) -> - if is_substituable ~mutable_vars:env.mutable_vars arg then - layout, None, arg - else - let id = V.create_local "arg" in - layout, Some (VP.create id, arg), Uvar id) uargs in - let app_args = List.map (fun (_, _, arg) -> arg) args in - List.fold_left (fun app (layout,binding,_) -> - match binding with - | None -> app - | Some (v, e) -> Ulet(Immutable, layout, v, e, app)) - (if fundesc.fun_closed then - Usequence (ufunct, - Udirect_apply (fundesc.fun_label, app_args, - probe, result_layout, kind, dbg)) - else - let clos = V.create_local "clos" in - Ulet(Immutable, Lambda.layout_function, VP.create clos, ufunct, - Udirect_apply(fundesc.fun_label, app_args @ [Uvar clos], - probe, result_layout, kind, dbg))) - args - end - | Some(params, body), _ -> - let body = - match pos with - | Rc_normal | Rc_nontail -> body - | Rc_close_at_apply -> exclave body - in - bind_params env loc fundesc params uargs ufunct body - -(* Add [Value_integer] info to the approximation of an application *) - -let strengthen_approx appl approx = - match approx_ulam appl with - (Value_const _) as intapprox -> - intapprox - | _ -> approx - -(* If a term has approximation Value_integer and is pure, - replace it by an integer constant *) - -let check_constant_result ulam approx = - match approx with - Value_const c when is_pure ulam -> make_const c - | Value_global_field (id, i) when is_pure ulam -> - begin match ulam with - | Uprim(P.Pfield _, [Uprim(P.Pread_symbol _, _, _)], _) -> (ulam, approx) - | _ -> - let glb = - Uprim(P.Pread_symbol id, [], Debuginfo.none) - in - Uprim(P.Pfield (i, Lambda.layout_any_value, Pointer, Immutable), - [glb], Debuginfo.none), approx - end - | _ -> (ulam, approx) - -(* Evaluate an expression with known value for its side effects only, - or discard it if it's pure *) - -let sequence_constant_expr ulam1 (ulam2, approx2 as res2) = - if is_pure ulam1 then res2 else (Usequence(ulam1, ulam2), approx2) - -(* Maintain the approximation of the global structure being defined *) - -let global_approx = ref([||] : value_approximation array) - -(* Maintain the nesting depth for functions *) - -let function_nesting_depth = ref 0 -let excessive_function_nesting_depth = 5 - -(* Uncurry an expression and explicitate closures. - Also return the approximation of the expression. - The approximation environment [fenv] maps idents to approximations. - Idents not bound in [fenv] approximate to [Value_unknown]. - The closure environment [cenv] maps idents to [ulambda] terms. - It is used to substitute environment accesses for free identifiers. *) - -exception NotClosed - -let close_approx_var { fenv; cenv } id = - let approx = try V.Map.find id fenv with Not_found -> Value_unknown in - match approx with - Value_const c -> make_const c - | approx -> - let subst = try V.Map.find id cenv with Not_found -> Uvar id in - (subst, approx) - -let close_var env id = - let (ulam, _app) = close_approx_var env id in ulam - -(* Auxiliaries for compiling functions *) - -let rec split_list n l = - if n <= 0 then ([], l) else begin - match l with - [] -> fatal_error "Closure.split_list" - | a::l -> let (l1, l2) = split_list (n-1) l in (a::l1, l2) - end - -let split_closure_fv env kinds fv = - let (not_scanned_fv, scanned_fv) = - List.fold_left (fun acc id -> - let kind = V.Map.find id kinds in - let f (not_scanned_fv, scanned_fv) expr (atom : Clambda_layout.atom) = - match atom with - | Value -> not_scanned_fv, ((expr, atom) :: scanned_fv) - | Value_int | Unboxed_float | Unboxed_int _ | Unboxed_vector _ -> - ((expr, atom) :: not_scanned_fv, scanned_fv) - in - Clambda_layout.fold_left_layout f acc (close_var env id) kind) - ([],[]) fv - in - (List.rev not_scanned_fv, List.rev scanned_fv) - -let layout_of_atom (atom : Closure_offsets.layout_atom) : Lambda.layout = - match atom with - | Value -> Pvalue Pgenval - | Value_int -> Pvalue Pintval - | Unboxed_float -> Punboxed_float - | Unboxed_int bi -> Punboxed_int bi - | Unboxed_vector bv -> Punboxed_vector bv - -let load_env_field ~base_offset - ~closure (parts : Clambda_layout.decomposition) : Clambda.ulambda = - let rec rebuild (parts : Closure_offsets.parts) : Clambda.ulambda * Clambda_primitives.layout = - match parts with - | Atom { offset = var_offset; layout } -> - let pos = var_offset + base_offset in - let layout = layout_of_atom layout in - Uprim (Pfield (pos, layout, Pointer, Mutable), [closure], Debuginfo.none), - layout - | Product parts -> - let parts = Array.to_list @@ Array.map rebuild parts in - let parts, layouts = List.split parts in - Uprim (Pmake_unboxed_product layouts, parts, Debuginfo.none), - Punboxed_product layouts - in - let expr, _layout = rebuild parts in - expr - -let add_to_closure_env env_param base_offset fv = - List.fold_left (fun cenv (id, decomp) -> - let expr = - load_env_field ~base_offset ~closure:(Uvar env_param) - decomp - in - V.Map.add id expr cenv) - V.Map.empty fv - -let compute_expr_layout kinds lambda = - let find_kind id = Ident.Map.find_opt id kinds in - compute_expr_layout find_kind lambda - -let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) lam = - let module B = (val backend : Backend_intf.S) in - match lam with - | Lvar id -> - close_approx_var env id - | Lmutvar id -> (Uvar id, Value_unknown) - | Lconst cst -> - let str ?(shared = true) cst = - let name = - Compilenv.new_structured_constant cst ~shared - in - Uconst_ref (name, Some cst) - in - let rec transl = function - | Const_base(Const_int n) -> Uconst_int n - | Const_base(Const_char c) -> Uconst_int (Char.code c) - | Const_block (tag, fields) -> - str (Uconst_block (tag, List.map transl fields)) - | Const_float_block sl -> - str (Uconst_float_array (List.map float_of_string sl)) - | Const_float_array sl -> - (* constant float arrays are really immutable *) - str (Uconst_float_array (List.map float_of_string sl)) - | Const_immstring s -> - str (Uconst_string s) - | Const_base (Const_string (s, _, _)) -> - (* Strings (even literal ones) must be assumed to be mutable... - except when OCaml has been configured with - -safe-string. Passing -safe-string at compilation - time is not enough, since the unit could be linked - with another one compiled without -safe-string, and - that one could modify our string literal. *) - str ~shared:true (Uconst_string s) - | Const_base(Const_float x) -> str (Uconst_float (float_of_string x)) - | Const_base(Const_unboxed_float _) -> - (* CR alanechang: implement unboxed float constants in closure *) - Misc.fatal_error "Unboxed float constants are not supported in closure. Consider using flambda2." - | Const_base(Const_int32 x) -> str (Uconst_int32 x) - | Const_base(Const_int64 x) -> str (Uconst_int64 x) - | Const_base(Const_nativeint x) -> str (Uconst_nativeint x) - in - make_const (transl cst) - | Lfunction _ as funct -> - close_one_function env (Ident.create_local "fun") funct - - (* We convert [f a] to [let a' = a in let f' = f in fun b c -> f' a' b c] - when fun_arity > nargs *) - | Lapply{ap_func = funct; ap_args = args; ap_region_close=pos; ap_mode=mode; - ap_probe = probe; ap_loc = loc; - ap_inlined = attribute; ap_result_layout} -> - let nargs = List.length args in - if nargs = 0 && probe = None then - Misc.fatal_errorf "Closure: 0-ary application at %a" - Location.print_loc (Debuginfo.Scoped_location.to_location loc); - begin match (close env funct, close_list env args) with - ((ufunct, Value_closure(_, - ({fun_arity={ - function_kind = Tupled ; - params_layout; _}} as fundesc), - approx_res)), - [Uprim(P.Pmakeblock _, uargs, _)]) - when List.length uargs = List.length params_layout -> - let app = - direct_apply env ~loc ~attribute fundesc ufunct (List.combine params_layout uargs) - pos ap_result_layout mode ~probe in - (app, strengthen_approx app approx_res) - | ((ufunct, Value_closure(_, - ({fun_arity={ - function_kind = Curried _ ; - params_layout ; _}} as fundesc), - approx_res)), uargs) - when nargs = List.length params_layout -> - let app = - direct_apply env ~loc ~attribute fundesc ufunct (List.combine params_layout uargs) - pos ap_result_layout mode ~probe in - (app, strengthen_approx app approx_res) - - | ((ufunct, (Value_closure( - clos_mode, - ({fun_arity={ function_kind = Curried {nlocal} ; - params_layout ; _ }} as fundesc), - _) as fapprox)), uargs) - when nargs < List.length params_layout -> - let (first_layouts, rem_layouts) = split_list nargs params_layout in - let (_, rem_modes) = split_list nargs fundesc.fun_argmodes in - let first_args = List.map2 (fun arg kind -> - (V.create_local "arg", arg, kind) ) uargs first_layouts in - let kinds = - List.fold_left (fun kinds (arg, _, kind) -> V.Map.add arg kind kinds) - kinds first_args - in - let new_clos_mode, kind = - (* If the closure has a local suffix, and we've supplied - enough args to hit it, then the closure must be local - (because the args or closure might be). *) - let nparams = List.length params_layout in - assert (nparams >= nlocal); - let heap_params = nparams - nlocal in - if nargs <= heap_params then - alloc_heap, Curried {nlocal} - else - let supplied_local_args = nargs - heap_params in - alloc_local, Curried {nlocal = nlocal - supplied_local_args} - in - if is_local_mode clos_mode then assert (is_local_mode new_clos_mode); - let final_args = - List.map2 (fun kind mode -> { - name = V.create_local "arg"; - layout = kind; - attributes = Lambda.default_param_attribute; - mode = mode - }) rem_layouts rem_modes - in - let rec iter args body = - match args with - [] -> body - | (arg1, arg2, kind) :: args -> - iter args - (Ulet (Immutable, kind, VP.create arg1, arg2, body)) - in - let internal_args = - (List.map (fun (arg1, _arg2, _) -> Lvar arg1) first_args) - @ (List.map (fun p -> Lvar p.name ) final_args) - in - let funct_var = V.create_local "funct" in - let fenv = V.Map.add funct_var fapprox fenv in - let kinds = V.Map.add funct_var Lambda.layout_function kinds in - let ret_mode = if fundesc.fun_region then alloc_heap else alloc_local in - let (new_fun, approx) = - close { backend; fenv; cenv; mutable_vars; kinds; catch_env } - (lfunction - ~kind - ~return:ap_result_layout - ~params:final_args - ~body:(Lapply{ - ap_loc=loc; - ap_func=(Lvar funct_var); - ap_args=internal_args; - ap_result_layout=ap_result_layout; - ap_region_close=Rc_normal; - ap_mode=ret_mode; - ap_tailcall=Default_tailcall; - ap_inlined=Default_inlined; - ap_specialised=Default_specialise; - ap_probe=None; - }) - ~loc - ~mode:new_clos_mode - ~ret_mode:fundesc.fun_retmode - ~region:fundesc.fun_region - ~attr:default_function_attribute) - in - let new_fun = - iter first_args - (Ulet (Immutable, Lambda.layout_function, VP.create funct_var, ufunct, new_fun)) - in - warning_if_forced_inlined ~loc ~attribute "Partial application"; - fail_if_probe ~probe "Partial application"; - (new_fun, approx) - - | ((ufunct, Value_closure(_, ({fun_arity = { - function_kind = Curried _; params_layout ; _}} as fundesc), - _approx_res)), uargs) - when nargs > List.length params_layout -> - let nparams = List.length params_layout in - let args_kinds = List.map (compute_expr_layout kinds) args in - let args = List.map (fun arg -> V.create_local "arg", arg) uargs in - (* CR mshinwell: Edit when Lapply has kinds *) - let kinds = - List.fold_left2 (fun kinds (var, _) kind -> V.Map.add var kind kinds) - kinds args args_kinds - in - let first_kinds, rem_kinds = split_list nparams args_kinds in - let (first_args, rem_args) = split_list nparams args in - let first_args = List.map (fun (id, _) -> Uvar id) first_args in - let rem_args = List.map (fun (id, _) -> Uvar id) rem_args in - let dbg = Debuginfo.from_location loc in - warning_if_forced_inlined ~loc ~attribute "Over-application"; - fail_if_probe ~probe "Over-application"; - let mode' = if fundesc.fun_region then alloc_heap else alloc_local in - let body = - Ugeneric_apply(direct_apply { env with kinds } ~loc ~attribute - fundesc ufunct (List.combine first_kinds first_args) - Rc_normal Lambda.layout_function mode' - ~probe, - rem_args, - rem_kinds, - ap_result_layout, - (Rc_normal, mode), dbg) - in - let body = - match mode, fundesc.fun_region with - | Alloc_heap, false -> region body - | _ -> body - in - let body = - match pos with - | Rc_normal | Rc_nontail -> body - | Rc_close_at_apply -> exclave body - in - let result = - List.fold_left2 (fun body (id, defining_expr) kind -> - Ulet (Immutable, kind, VP.create id, defining_expr, body)) - body - args args_kinds - in - result, Value_unknown - | ((ufunct, _), uargs) -> - let dbg = Debuginfo.from_location loc in - warning_if_forced_inlined ~loc ~attribute "Unknown function"; - fail_if_probe ~probe "Unknown function"; - (Ugeneric_apply(ufunct, uargs, - List.map (compute_expr_layout kinds) args, - ap_result_layout, (pos, mode), dbg), Value_unknown) - end - | Lsend(kind, met, obj, args, pos, mode, loc, result_layout) -> - let (umet, _) = close env met in - let (uobj, _) = close env obj in - let dbg = Debuginfo.from_location loc in - let args_layout = List.map (compute_expr_layout kinds) args in - (Usend(kind, umet, uobj, close_list env args, args_layout, result_layout, (pos,mode), dbg), - Value_unknown) - | Llet(str, kind, id, lam, body) -> - let (ulam, alam) = close_named env id lam in - let kinds = V.Map.add id kind kinds in - begin match alam with - | Value_const _ - when str = Alias || is_pure ulam -> - close { - backend; - fenv = (V.Map.add id alam fenv); - cenv; - mutable_vars; - kinds; - catch_env - } - body - | _ -> - let (ubody, abody) = - close - { backend; - fenv = (V.Map.add id alam fenv); - cenv; - mutable_vars; - kinds; - catch_env - } - body - in - (Ulet(Immutable, kind, VP.create id, ulam, ubody), abody) - end - | Lmutlet(kind, id, lam, body) -> - let (ulam, _) = close_named env id lam in - let kinds = V.Map.add id kind kinds in - let env = {env with mutable_vars = V.Set.add id env.mutable_vars} in - let (ubody, abody) = close { env with kinds } body in - (Ulet(Mutable, kind, VP.create id, ulam, ubody), abody) - | Lletrec(defs, body) -> - if List.for_all - (function (_id, Lfunction _) -> true | _ -> false) - defs - then begin - (* Simple case: only function definitions *) - let (clos, infos) = close_functions env defs in - let clos_ident = V.create_local "clos" in - let fenv_body = - List.fold_right - (fun (id, _pos, approx) fenv -> V.Map.add id approx fenv) - infos fenv in - let kinds_body = - List.fold_right - (fun (id, _pos, _approx) kinds -> V.Map.add id Lambda.layout_function kinds) - infos (V.Map.add clos_ident Lambda.layout_function kinds) - in - let (ubody, approx) = - close - { backend; - fenv = fenv_body; - cenv; - mutable_vars; - kinds = kinds_body; - catch_env - } - body - in - let sb = - List.fold_right - (fun (id, pos, _approx) sb -> - V.Map.add id (Uoffset(Uvar clos_ident, pos)) sb) - infos V.Map.empty in - (Ulet(Immutable, Lambda.layout_function, VP.create clos_ident, clos, - substitute Debuginfo.none (backend, !Clflags.float_const_prop) sb - None ubody), - approx) - end else begin - (* General case: recursive definition of values *) - let kinds = - List.fold_left (fun kinds (id, _) -> V.Map.add id Lambda.layout_letrec kinds) - kinds defs - in - let rec clos_defs = function - [] -> ([], fenv) - | (id, lam) :: rem -> - let (udefs, fenv_body) = clos_defs rem in - let (ulam, approx) = close_named { env with kinds } id lam in - ((VP.create id, ulam) :: udefs, V.Map.add id approx fenv_body) in - let (udefs, fenv_body) = clos_defs defs in - let (ubody, approx) = - close { backend; fenv = fenv_body; cenv; mutable_vars; kinds; catch_env } body in - (Uletrec(udefs, ubody), approx) - end - (* Compile-time constants *) - | Lprim(Pctconst c, [arg], _loc) -> - let cst, approx = - match c with - | Big_endian -> make_const_bool B.big_endian - | Word_size -> make_const_int (8*B.size_int) - | Int_size -> make_const_int (8*B.size_int - 1) - | Max_wosize -> make_const_int ((1 lsl ((8*B.size_int) - 10)) - 1 ) - | Ostype_unix -> make_const_bool (Sys.os_type = "Unix") - | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32") - | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin") - | Backend_type -> - make_const_int 0 (* tag 0 is the same as Native here *) - | Runtime5 -> make_const_bool Config.runtime5 - in - let arg, _approx = close env arg in - let id = Ident.create_local "dummy" in - Ulet(Immutable, Lambda.layout_unit, VP.create id, arg, cst), approx - | Lprim(Pignore, [arg], _loc) -> - let expr, approx = make_const_int 0 in - Usequence(fst (close env arg), expr), approx - | Lprim(( Pbytes_to_string | Pbytes_of_string | Pobj_magic _ | - Parray_of_iarray | Parray_to_iarray ), - [arg], _loc) -> - close env arg - | Lprim(Pgetglobal cu, [], loc) -> - let dbg = Debuginfo.from_location loc in - check_constant_result (getglobal dbg cu) - (Compilenv.global_approx cu) - | Lprim(Pgetpredef id, [], loc) -> - let dbg = Debuginfo.from_location loc in - getpredef dbg id, Value_unknown - | Lprim(Pfield (n, ptr, mut), [lam], loc) -> - let (ulam, approx) = close env lam in - let dbg = Debuginfo.from_location loc in - let mut : Lambda.mutable_flag = - match mut with - | Reads_agree -> Immutable - | Reads_vary -> Mutable - in - check_constant_result - (Uprim(P.Pfield (n, Lambda.layout_any_value, ptr, mut), [ulam], dbg)) - (field_approx n approx) - | Lprim(Psetfield(n, is_ptr, init), - [Lprim(Pgetglobal cu, [], _); lam], loc)-> - let (ulam, approx) = close env lam in - if approx <> Value_unknown then - (!global_approx).(n) <- approx; - let dbg = Debuginfo.from_location loc in - (Uprim(P.Psetfield(n, is_ptr, init), [getglobal dbg cu; ulam], dbg), - Value_unknown) - | Lprim(Praise k, [arg], loc) -> - let (ulam, _approx) = close env arg in - let dbg = Debuginfo.from_location loc in - (Uprim(P.Praise k, [ulam], dbg), - Value_unknown) - | Lprim (Pmakearray _, [], _loc) -> make_const_ref (Uconst_block (0, [])) - | Lprim(p, args, loc) -> - let p = Convert_primitives.convert p in - let dbg = Debuginfo.from_location loc in - simplif_prim ~backend !Clflags.float_const_prop - p (close_list_approx env args) dbg - | Lswitch(arg, sw, dbg, kind) -> - let fn env fail = - let (uarg, _) = close env arg in - let const_index, const_actions, fconst = - close_switch env sw.sw_consts sw.sw_numconsts fail - and block_index, block_actions, fblock = - close_switch env sw.sw_blocks sw.sw_numblocks fail in - let ulam = - Uswitch - (uarg, - {us_index_consts = const_index; - us_actions_consts = const_actions; - us_index_blocks = block_index; - us_actions_blocks = block_actions}, - Debuginfo.from_location dbg, - kind) - in - (fconst kind (fblock kind ulam),Value_unknown) in -(* NB: failaction might get copied, thus it should be some Lstaticraise *) - let fail = sw.sw_failaction in - begin match fail with - | None|Some (Lstaticraise (_,_)) -> fn env fail - | Some lamfail -> - if - (sw.sw_numconsts - List.length sw.sw_consts) + - (sw.sw_numblocks - List.length sw.sw_blocks) > 1 - then - let i = next_raise_count () in - let body_env = { env with catch_env = Int.Map.add i i catch_env } in - let ubody,_ = fn body_env (Some (Lstaticraise (i,[]))) - and uhandler,_ = close env lamfail in - Ucatch (i,[],ubody,uhandler,kind),Value_unknown - else fn env fail - end - | Lstringswitch(arg,sw,d,_, kind) -> - let uarg,_ = close env arg in - let usw = - List.map - (fun (s,act) -> - let uact,_ = close env act in - s,uact) - sw in - let ud = - Option.map - (fun d -> - let ud,_ = close env d in - ud) d in - Ustringswitch (uarg,usw,ud,kind),Value_unknown - | Lstaticraise (i, args) -> - let new_i = - match Int.Map.find i catch_env with - | new_i -> new_i - | exception Not_found -> - Misc.fatal_errorf "Static raise %d out of the scope of its handler" i - in - (Ustaticfail (new_i, close_list env args), Value_unknown) - | Lstaticcatch(body, (i, vars), handler, kind) -> - let new_i = Lambda.next_raise_count () in - let body_env = { env with catch_env = Int.Map.add i new_i catch_env } in - let (ubody, _) = close body_env body in - let kinds = - List.fold_left (fun kinds (var, k) -> V.Map.add var k kinds) kinds vars - in - let (uhandler, _) = close { env with kinds } handler in - let vars = List.map (fun (var, k) -> VP.create var, k) vars in - (Ucatch(new_i, vars, ubody, uhandler, kind), Value_unknown) - | Ltrywith(body, id, handler, kind) -> - let (ubody, _) = close env body in - let (uhandler, _) = - close { env with kinds = V.Map.add id Lambda.layout_block kinds } handler - in - (Utrywith(ubody, VP.create id, uhandler, kind), Value_unknown) - | Lifthenelse(arg, ifso, ifnot, kind) -> - begin match close env arg with - (uarg, Value_const (Uconst_int n)) -> - sequence_constant_expr uarg - (close env (if n = 0 then ifnot else ifso)) - | (uarg, _ ) -> - let (uifso, _) = close env ifso in - let (uifnot, _) = close env ifnot in - (Uifthenelse(uarg, uifso, uifnot, kind), Value_unknown) - end - | Lsequence(lam1, lam2) -> - let (ulam1, _) = close env lam1 in - let (ulam2, approx) = close env lam2 in - (Usequence(ulam1, ulam2), approx) - | Lwhile {wh_cond; wh_body} -> - let (ucond, _) = close env wh_cond in - let (ubody, _) = close env wh_body in - (Uwhile(ucond, ubody), Value_unknown) - | Lfor {for_id; for_from; for_to; for_dir; for_body} -> - let (ulo, _) = close env for_from in - let (uhi, _) = close env for_to in - let (ubody, _) = - close { env with kinds = V.Map.add for_id Lambda.layout_int kinds } for_body - in - (Ufor(VP.create for_id, ulo, uhi, for_dir, ubody), Value_unknown) - | Lassign(id, lam) -> - let (ulam, _) = close env lam in - (Uassign(id, ulam), Value_unknown) - | Levent(lam, _) -> - close env lam - | Lifused _ -> - assert false - | Lregion (lam, _) -> - let ulam, approx = close env lam in - region ulam, approx - | Lexclave lam -> - let ulam, approx = close env lam in - exclave ulam, approx - -and close_list env = function - [] -> [] - | lam :: rem -> - let (ulam, _) = close env lam in - ulam :: close_list env rem - -and close_list_approx env = function - [] -> ([], []) - | lam :: rem -> - let (ulam, approx) = close env lam in - let (ulams, approxs) = close_list_approx env rem in - (ulam :: ulams, approx :: approxs) - -and close_named env id = function - Lfunction _ as funct -> - close_one_function env id funct - | lam -> - close env lam - -(* Build a shared closure for a set of mutually recursive functions *) - -and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_defs = - let fun_defs = - List.flatten - (List.map - (function - | (id, Lfunction{kind; params; return; body; attr; - loc; mode; ret_mode; region}) -> - Simplif.split_default_wrapper ~id ~kind ~params ~mode ~ret_mode ~region - ~body ~attr ~loc ~return - | _ -> assert false - ) - fun_defs) - in - let inline_attribute = match fun_defs with - | [_, Lfunction{attr = { inline; }}] -> inline - | _ -> Default_inline (* recursive functions can't be inlined *) - in - (* Update and check nesting depth *) - incr function_nesting_depth; - let initially_closed = - !function_nesting_depth < excessive_function_nesting_depth in - (* Determine the free variables of the functions *) - let fv = - V.Set.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in - let free_vars = List.map (fun id -> id, V.Map.find id kinds) fv in - (* Build the function descriptors for the functions. - Initially all functions are assumed not to need their environment - parameter. *) - let uncurried_defs = - List.map - (function - (id, Lfunction( - {kind; params; return; body; attr; loc; mode; region; ret_mode})) -> - let attrib = attr.check in - let label = - Symbol_utils.for_fun_ident ~compilation_unit:None loc id - |> Symbol.linkage_name - |> Linkage_name.to_string - in - let fundesc = - {fun_label = label; - fun_arity = { - function_kind = kind ; - params_layout = List.map (fun p -> p.layout) params ; - return_layout = return - }; - fun_closed = initially_closed; - fun_inline = None; - fun_float_const_prop = !Clflags.float_const_prop; - fun_poll = attr.poll; - fun_region = region; - fun_argmodes = List.map (fun (p : Lambda.lparam) -> p.mode) params; - fun_retmode = ret_mode; - } in - let dbg = Debuginfo.from_location loc in - (id, List.map (fun (p : Lambda.lparam) -> let No_attributes = p.attributes in (p.name, p.layout, p.mode)) params, - return, body, mode, attrib, fundesc, dbg) - | (_, _) -> fatal_error "Closure.close_functions") - fun_defs in - (* Build an approximate fenv for compiling the functions *) - let fenv_rec = - List.fold_right - (fun (id, _params, _return, _body, mode, _attrib, fundesc, _dbg) fenv -> - V.Map.add id (Value_closure(mode, fundesc, Value_unknown)) fenv) - uncurried_defs fenv in - let kinds_rec = - List.fold_right - (fun (id, _params, _return, _body, _mode, _attrib, _fundesc, _dbg) - kinds -> - V.Map.add id Lambda.layout_function kinds) - uncurried_defs kinds in - (* Determine the offsets of each function's closure in the shared block *) - let env_pos = ref (-1) in - let clos_offsets = - List.map - (fun (_id, _params, _return, _body, _mode, _attrib, fundesc, _dbg) -> - let pos = !env_pos + 1 in - env_pos := !env_pos + 1 + - (match fundesc.fun_arity with - | { function_kind = Curried _; params_layout = ([] | [_]); _} -> 2 - | _ -> 3); - pos) - uncurried_defs in - let fv_pos = !env_pos in - (* This reference will be set to false if the hypothesis that a function - does not use its environment parameter is invalidated. *) - let useless_env = ref initially_closed in - (* Translate each function definition *) - let clos_fundef (id, params, _return, body, mode, check, fundesc, dbg) - env_pos = - let env_param = V.create_local "env" in - let decomposition = - Clambda_layout.decompose_free_vars - ~base_offset:0 - ~free_vars - in - let cenv_fv = - add_to_closure_env env_param (fv_pos - env_pos) decomposition - in - let cenv_body = - List.fold_right2 - (fun (id, _params, _return, _body, _mode, _attrib, _fundesc, _dbg) pos env -> - V.Map.add id (Uoffset(Uvar env_param, pos - env_pos)) env) - uncurried_defs clos_offsets cenv_fv - in - let kinds_body = - List.fold_right - (fun (id, kind, _) kinds -> V.Map.add id kind kinds) - params (V.Map.add env_param Lambda.layout_function kinds_rec) - in - let (ubody, approx) = - close - { backend; - fenv = fenv_rec; - cenv = cenv_body; - mutable_vars; - kinds = kinds_body; - catch_env - } - body - in - if !useless_env && occurs_var env_param ubody then raise NotClosed; - let fun_params = - if !useless_env - then params - else params @ [env_param, Lambda.layout_function, alloc_heap] - in - let f = - { - label = fundesc.fun_label; - arity = fundesc.fun_arity; - params = List.map (fun (var, _, _) -> VP.create var) fun_params; - body = ubody; - dbg; - env = Some env_param; - poll = fundesc.fun_poll; - mode; - check; - } - in - (* give more chance of function with default parameters (i.e. - their wrapper functions) to be inlined *) - let n = - List.fold_left - (fun n (id, _, _) -> - n + if String.starts_with (V.name id) ~prefix:"*opt*" then 8 else 1) - 0 - fun_params - in - let threshold = - match inline_attribute with - | Default_inline -> - let inline_threshold = - Clflags.Float_arg_helper.get ~key:0 !Clflags.inline_threshold - in - let magic_scale_constant = 8. in - int_of_float (inline_threshold *. magic_scale_constant) + n - | Always_inline | Available_inline -> max_int - | Never_inline -> min_int - | Unroll _ -> assert false - in - let fun_params = List.map (fun (var, _, _) -> VP.create var) fun_params in - if lambda_smaller ubody threshold - then fundesc.fun_inline <- Some(fun_params, ubody); - - (f, (id, env_pos, Value_closure(mode, fundesc, approx))) in - (* Translate all function definitions. *) - let clos_info_list = - if initially_closed then begin - let snap = Compilenv.snapshot () in - try List.map2 clos_fundef uncurried_defs clos_offsets - with NotClosed -> - (* If the hypothesis that the environment parameters are useless has been - invalidated, then set [fun_closed] to false in all descriptions and - recompile *) - Compilenv.backtrack snap; (* PR#6337 *) - List.iter - (fun (_id, _params, _return, _body, _mode, _attrib, fundesc, _dbg) -> - fundesc.fun_closed <- false; - fundesc.fun_inline <- None; - ) - uncurried_defs; - useless_env := false; - List.map2 clos_fundef uncurried_defs clos_offsets - end else - (* Excessive closure nesting: assume environment parameter is used *) - List.map2 clos_fundef uncurried_defs clos_offsets - in - (* Update nesting depth *) - decr function_nesting_depth; - (* Return the Uclosure node and the list of all identifiers defined, - with offsets and approximations. *) - let (clos, infos) = List.split clos_info_list in - let env = { backend; cenv; fenv; mutable_vars; kinds; catch_env } in - let not_scanned_fv, scanned_fv = split_closure_fv env kinds fv in - let not_scanned_fv, scanned_fv = - if !useless_env then [], [] else not_scanned_fv, scanned_fv in - (Uclosure { - functions = clos; - not_scanned_slots = List.map (fun (expr, _kind) -> expr) not_scanned_fv; - scanned_slots = List.map (fun (expr, _kind) -> expr) scanned_fv - }, - infos) - -(* Same, for one non-recursive function *) - -and close_one_function env id funct = - match close_functions env [id, funct] with - | (clos, (i, _, approx) :: _) when id = i -> (clos, approx) - | _ -> fatal_error "Closure.close_one_function" - -(* Close a switch *) - -and close_switch env cases num_keys default = - let ncases = List.length cases in - let index = Array.make num_keys 0 - and store = Storer.mk_store () in - - (* First default case *) - begin match default with - | Some def when ncases < num_keys -> - assert (store.act_store () def = 0) - | _ -> () - end ; - (* Then all other cases *) - List.iter - (fun (key,lam) -> - index.(key) <- store.act_store () lam) - cases ; - - (* Explicit sharing with catch/exit, as switcher compilation may - later unshare *) - let acts = store.act_get_shared () in - let hs = ref (fun _ e -> e) in - - (* Compile actions *) - let actions = - Array.map - (function - | Single lam|Shared (Lstaticraise (_,[]) as lam) -> - let ulam,_ = close env lam in - ulam - | Shared lam -> - let ulam,_ = close env lam in - let i = next_raise_count () in -(* - let string_of_lambda e = - Printlambda.lambda Format.str_formatter e ; - Format.flush_str_formatter () in - Printf.eprintf "SHARE CLOSURE %i [%s]\n%s\n" i - (string_of_lambda arg) - (string_of_lambda lam) ; -*) - let ohs = !hs in - hs := (fun kind e -> Ucatch (i,[],ohs kind e,ulam, kind)) ; - Ustaticfail (i,[])) - acts in - match actions with - | [| |] -> [| |], [| |], !hs (* May happen when default is None *) - | _ -> index, actions, !hs - - -(* Collect exported symbols for structured constants *) - -let collect_exported_structured_constants a = - let rec approx = function - | Value_closure (_, fd, a) -> - approx a; - begin match fd.fun_inline with - | Some (_, u) -> ulam u - | None -> () - end - | Value_tuple (_,a) -> Array.iter approx a - | Value_const c -> const c - | Value_unknown | Value_global_field _ -> () - and const = function - | Uconst_ref (s, (Some c)) -> - Compilenv.add_exported_constant s; - structured_constant c - | Uconst_ref (_s, None) -> assert false (* Cannot be generated *) - | Uconst_int _ -> () - and structured_constant = function - | Uconst_block (_, ul) -> List.iter const ul - | Uconst_float _ | Uconst_int32 _ - | Uconst_int64 _ | Uconst_nativeint _ | Uconst_vec128 _ - | Uconst_float_array _ | Uconst_string _ -> () - | Uconst_closure _ -> assert false (* Cannot be generated *) - and ulam = function - | Uvar _ -> () - | Uconst c -> const c - | Udirect_apply (_, ul, _, _, _, _) -> List.iter ulam ul - | Ugeneric_apply (u, ul, _, _, _, _) -> ulam u; List.iter ulam ul - | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> - List.iter (fun f -> ulam f.body) functions; - List.iter ulam not_scanned_slots; - List.iter ulam scanned_slots - | Uoffset(u, _) -> ulam u - | Ulet (_str, _kind, _, u1, u2) -> ulam u1; ulam u2 - | Uphantom_let _ -> no_phantom_lets () - | Uletrec (l, u) -> List.iter (fun (_, u) -> ulam u) l; ulam u - | Uprim (_, ul, _) -> List.iter ulam ul - | Uswitch (u, sl, _dbg, _kind) -> - ulam u; - Array.iter ulam sl.us_actions_consts; - Array.iter ulam sl.us_actions_blocks - | Ustringswitch (u,sw,d, _kind) -> - ulam u ; - List.iter (fun (_,act) -> ulam act) sw ; - Option.iter ulam d - | Ustaticfail (_, ul) -> List.iter ulam ul - | Ucatch (_, _, u1, u2, _) - | Utrywith (u1, _, u2, _) - | Usequence (u1, u2) - | Uwhile (u1, u2) -> ulam u1; ulam u2 - | Uifthenelse (u1, u2, u3, _) - | Ufor (_, u1, u2, _, u3) -> ulam u1; ulam u2; ulam u3 - | Uassign (_, u) -> ulam u - | Usend (_, u1, u2, ul, _, _, _, _) -> ulam u1; ulam u2; List.iter ulam ul - | Uunreachable -> () - | Uregion u -> ulam u - | Uexclave u -> ulam u - in - approx a - -let reset () = - global_approx := [||]; - function_nesting_depth := 0 - -(* The entry point *) - -let intro ~backend ~size lam = - reset (); - let id = - Symbol.for_current_unit () - |> Symbol.linkage_name - |> Linkage_name.to_string - in - global_approx := Array.init size (fun i -> Value_global_field (id, i)); - Compilenv.set_global_approx(Value_tuple (alloc_heap, !global_approx)); - let (ulam, _approx) = - close { backend; fenv = V.Map.empty; - cenv = V.Map.empty; mutable_vars = V.Set.empty; - kinds = V.Map.empty; catch_env = Int.Map.empty } lam - in - let opaque = - !Clflags.opaque - || Env.is_imported_opaque - (Compilation_unit.get_current_exn () - |> Compilation_unit.name) - in - if opaque - then Compilenv.set_global_approx(Value_unknown) - else collect_exported_structured_constants (Value_tuple (alloc_heap, !global_approx)); - global_approx := [||]; - ulam diff --git a/middle_end/closure/closure.mli b/middle_end/closure/closure.mli deleted file mode 100644 index 92c74732b23..00000000000 --- a/middle_end/closure/closure.mli +++ /dev/null @@ -1,24 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(* Introduction of closures, uncurrying, recognition of direct calls *) - -val intro - : backend:(module Backend_intf.S) - -> size:int - -> Lambda.lambda - -> Clambda.ulambda - -val reset : unit -> unit diff --git a/middle_end/closure/closure_middle_end.ml b/middle_end/closure/closure_middle_end.ml deleted file mode 100644 index 21cedc87a53..00000000000 --- a/middle_end/closure/closure_middle_end.ml +++ /dev/null @@ -1,72 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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"] - -let raw_clambda_dump_if ppf - ((ulambda, _, structured_constants) : Clambda.with_constants) = - if !Clflags.dump_rawclambda || !Clflags.dump_clambda then - begin - Format.fprintf ppf "@.clambda:@."; - Printclambda.clambda ppf ulambda; - List.iter (fun { Clambda. symbol; definition; _ } -> - Format.fprintf ppf "%s:@ %a@." - symbol - Printclambda.structured_constant definition) - structured_constants - end; - if !Clflags.dump_cmm then Format.fprintf ppf "@.cmm:@." - -let lambda_to_clambda ~backend ~filename:_ ~prefixname:_ ~ppf_dump - (lambda : Lambda.program) = - let clambda = - Closure.intro ~backend ~size:lambda.main_module_block_size lambda.code - in - let provenance : Clambda.usymbol_provenance = - let current_unit_ident = - Compilation_unit.get_current_exn () - |> Compilation_unit.name - |> Compilation_unit.Name.to_string - |> Ident.create_persistent - in - { original_idents = []; - (* CR-someday lmaurer: Properly construct a [Path.t] from the module name - with its pack prefix. *) - module_path = Path.Pident current_unit_ident; - } - in - let symbol = - Symbol.for_current_unit () - |> Symbol.linkage_name - |> Linkage_name.to_string - in - let preallocated_block = - Clambda.{ - symbol; - exported = true; - tag = 0; - fields = List.init lambda.main_module_block_size (fun _ -> None); - provenance = Some provenance; - } - in - let constants = Compilenv.structured_constants () in - Compilenv.clear_structured_constants (); - let clambda_and_constants = - clambda, [preallocated_block], constants - in - Compiler_hooks.execute Compiler_hooks.Raw_clambda clambda; - Compiler_hooks.execute Compiler_hooks.Clambda clambda; - raw_clambda_dump_if ppf_dump clambda_and_constants; - clambda_and_constants diff --git a/middle_end/closure/closure_middle_end.mli b/middle_end/closure/closure_middle_end.mli deleted file mode 100644 index e0ebb1decf1..00000000000 --- a/middle_end/closure/closure_middle_end.mli +++ /dev/null @@ -1,22 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -val lambda_to_clambda - : backend:(module Backend_intf.S) - -> filename:string - -> prefixname:string - -> ppf_dump:Format.formatter - -> Lambda.program - -> Clambda.with_constants diff --git a/middle_end/compilenv.ml b/middle_end/compilenv.ml index faed8936e17..5b6c4cbff04 100644 --- a/middle_end/compilenv.ml +++ b/middle_end/compilenv.ml @@ -37,59 +37,20 @@ exception Error of error let global_infos_table = (CU.Name.Tbl.create 17 : unit_infos option CU.Name.Tbl.t) -let export_infos_table = - (CU.Name.Tbl.create 10 : Export_info.t CU.Name.Tbl.t) let reset_info_tables () = - CU.Name.Tbl.reset global_infos_table; - CU.Name.Tbl.reset export_infos_table - -let imported_sets_of_closures_table = - (Set_of_closures_id.Tbl.create 10 - : Simple_value_approx.function_declarations option - Set_of_closures_id.Tbl.t) - -module CstMap = - Map.Make(struct - type t = Clambda.ustructured_constant - let compare = Clambda.compare_structured_constants - (* PR#6442: it is incorrect to use Stdlib.compare on values of type t - because it compares "0.0" and "-0.0" equal. *) - end) - -module SymMap = Misc.Stdlib.String.Map -module String = Misc.Stdlib.String - -type structured_constants = - { - strcst_shared: string CstMap.t; - strcst_all: Clambda.ustructured_constant SymMap.t; - } - -let structured_constants_empty = - { - strcst_shared = CstMap.empty; - strcst_all = SymMap.empty; - } - -let structured_constants = ref structured_constants_empty + CU.Name.Tbl.reset global_infos_table +module String = Misc.Stdlib.String let exported_constants = Hashtbl.create 17 -let merged_environment = ref Export_info.empty - let cached_checks = Checks.create () let cache_checks c = Checks.merge c ~into:cached_checks let default_ui_export_info = - if Config.flambda then - Cmx_format.Flambda1 Export_info.empty - else if Config.flambda2 then - Cmx_format.Flambda2 None - else - Cmx_format.Clambda Value_unknown + Cmx_format.Flambda2 None let current_unit = { ui_unit = CU.dummy; @@ -103,7 +64,6 @@ let current_unit = let reset compilation_unit = CU.Name.Tbl.clear global_infos_table; - Set_of_closures_id.Tbl.clear imported_sets_of_closures_table; Checks.reset cached_checks; CU.set_current (Some compilation_unit); current_unit.ui_unit <- compilation_unit; @@ -115,10 +75,7 @@ let reset compilation_unit = current_unit.ui_force_link <- !Clflags.link_everything; Checks.reset current_unit.ui_checks; Hashtbl.clear exported_constants; - structured_constants := structured_constants_empty; - current_unit.ui_export_info <- default_ui_export_info; - merged_environment := Export_info.empty; - CU.Name.Tbl.clear export_infos_table + current_unit.ui_export_info <- default_ui_export_info let current_unit_infos () = current_unit @@ -139,8 +96,6 @@ let read_unit_info filename = let sections = File_sections.create uir.uir_section_toc filename ic ~first_section_offset in let export_info = match uir.uir_export_info with - | Clambda_raw info -> Clambda info - | Flambda1_raw info -> Flambda1 info | Flambda2_raw None -> Flambda2 None | Flambda2_raw (Some info) -> Flambda2 (Some (Flambda2_cmx.Flambda_cmx_format.from_raw ~sections info)) @@ -231,69 +186,12 @@ let cache_unit_info ui = cache_checks ui.ui_checks; CU.Name.Tbl.add global_infos_table (CU.name ui.ui_unit) (Some ui) -(* Return the approximation of a global identifier *) - -let get_clambda_approx ui = - assert(not Config.flambda); - match ui.ui_export_info with - | Flambda1 _ | Flambda2 _ -> assert false - | Clambda approx -> approx - -let toplevel_approx : - (CU.t, Clambda.value_approximation) Hashtbl.t = Hashtbl.create 16 - -let record_global_approx_toplevel () = - Hashtbl.add toplevel_approx - current_unit.ui_unit - (get_clambda_approx current_unit) - -let global_approx comp_unit = - try Hashtbl.find toplevel_approx comp_unit - with Not_found -> - match get_global_info comp_unit with - | None -> Clambda.Value_unknown - | Some ui -> get_clambda_approx ui - -(* Register the approximation of the module being compiled *) - -let set_global_approx approx = - assert(not Config.flambda); - current_unit.ui_export_info <- Clambda approx - -(* Exporting and importing cross module information (Flambda only) *) - -let get_flambda_export_info ui = - assert(Config.flambda); - match ui.ui_export_info with - | Clambda _ | Flambda2 _ -> assert false - | Flambda1 ei -> ei - -let set_export_info export_info = - assert(Config.flambda); - current_unit.ui_export_info <- Flambda1 export_info +(* Exporting cross-module information *) let flambda2_set_export_info export_info = assert(Config.flambda2); current_unit.ui_export_info <- Flambda2 (Some export_info) -let approx_for_global comp_unit = - if CU.equal comp_unit CU.predef_exn - then invalid_arg "approx_for_global with predef_exn compilation unit"; - let accessible_comp_unit = which_cmx_file comp_unit in - let cmx_name = CU.name accessible_comp_unit in - match CU.Name.Tbl.find export_infos_table cmx_name with - | otherwise -> Some otherwise - | exception Not_found -> - match get_unit_info accessible_comp_unit with - | None -> None - | Some ui -> - let exported = get_flambda_export_info ui in - CU.Name.Tbl.add export_infos_table cmx_name exported; - merged_environment := Export_info.merge !merged_environment exported; - Some exported - -let approx_env () = !merged_environment - (* Record that a currying function or application function is needed *) let need_curry_fun kind arity result = @@ -342,8 +240,6 @@ let ensure_sharing_between_cmi_and_cmx_imports cmi_imports cmx_imports = let write_unit_info info filename = let raw_export_info, sections = match info.ui_export_info with - | Clambda info -> Clambda_raw info, File_sections.empty - | Flambda1 info -> Flambda1_raw info, File_sections.empty | Flambda2 None -> Flambda2_raw None, File_sections.empty | Flambda2 (Some info) -> let info, sections = Flambda2_cmx.Flambda_cmx_format.to_raw info in @@ -375,65 +271,11 @@ let save_unit_info filename = current_unit.ui_imports_cmi <- Env.imports(); write_unit_info current_unit filename -let snapshot () = !structured_constants -let backtrack s = structured_constants := s - let new_const_symbol () = Symbol.for_new_const_in_current_unit () |> Symbol.linkage_name |> Linkage_name.to_string -let new_structured_constant cst ~shared = - let {strcst_shared; strcst_all} = !structured_constants in - if shared then - try - CstMap.find cst strcst_shared - with Not_found -> - let lbl = new_const_symbol() in - structured_constants := - { - strcst_shared = CstMap.add cst lbl strcst_shared; - strcst_all = SymMap.add lbl cst strcst_all; - }; - lbl - else - let lbl = new_const_symbol() in - structured_constants := - { - strcst_shared; - strcst_all = SymMap.add lbl cst strcst_all; - }; - lbl - -let add_exported_constant s = - Hashtbl.replace exported_constants s () - -let clear_structured_constants () = - structured_constants := structured_constants_empty - -let structured_constant_of_symbol s = - SymMap.find_opt s (!structured_constants).strcst_all - -let structured_constants () = - let provenance : Clambda.usymbol_provenance = - { original_idents = []; - module_path = - (* CR-someday lmaurer: Properly construct a [Path.t] from the module name - with its pack prefix. *) - Path.Pident (Ident.create_persistent (Compilation_unit.Name.to_string ( - Compilation_unit.name (Compilation_unit.get_current_exn ())))); - } - in - SymMap.bindings (!structured_constants).strcst_all - |> List.map - (fun (symbol, definition) -> - { - Clambda.symbol; - exported = Hashtbl.mem exported_constants symbol; - definition; - provenance = Some provenance; - }) - let require_global global_ident = ignore (get_global_info global_ident : Cmx_format.unit_infos option) diff --git a/middle_end/compilenv.mli b/middle_end/compilenv.mli index d366279f720..8748531385b 100644 --- a/middle_end/compilenv.mli +++ b/middle_end/compilenv.mli @@ -21,14 +21,6 @@ open Cmx_format -(* CR-soon mshinwell: this is a bit ugly - mshinwell: deferred CR, this has been addressed in the export info - improvement feature. -*) -val imported_sets_of_closures_table - : Simple_value_approx.function_declarations option Set_of_closures_id.Tbl.t - (* flambda-only *) - val reset : Compilation_unit.t -> unit (* Reset the environment and record the name of the unit being compiled (including any associated -for-pack prefix). *) @@ -38,28 +30,8 @@ val reset_info_tables: unit -> unit val current_unit_infos: unit -> unit_infos (* Return the infos for the unit being compiled *) -val global_approx: Compilation_unit.t -> Clambda.value_approximation - (* Return the approximation for the given global identifier - clambda-only *) -val set_global_approx: Clambda.value_approximation -> unit - (* Record the approximation of the unit being compiled - clambda-only *) -val record_global_approx_toplevel: unit -> unit - (* Record the current approximation for the current toplevel phrase - clambda-only *) - -val set_export_info: Export_info.t -> unit - (* Record the information of the unit being compiled - flambda-only *) -val approx_env: unit -> Export_info.t - (* Returns all the information loaded from external compilation units - flambda-only *) -val approx_for_global: Compilation_unit.t -> Export_info.t option - (* Loads the exported information declaring the compilation_unit - flambda-only *) - val get_global_export_info : Compilation_unit.t -> Cmx_format.export_info option - (* Middle-end-agnostic means of getting the export info found in the + (* Means of getting the export info found in the .cmx file of the given unit. *) val get_unit_export_info @@ -86,26 +58,6 @@ val cache_checks : Checks.t -> unit val new_const_symbol : unit -> string -val new_structured_constant: - Clambda.ustructured_constant -> - shared:bool -> (* can be shared with another structurally equal constant *) - string -val structured_constants: - unit -> Clambda.preallocated_constant list -val clear_structured_constants: unit -> unit - -val structured_constant_of_symbol: - string -> Clambda.ustructured_constant option - -val add_exported_constant: string -> unit - (* clambda-only *) -type structured_constants - (* clambda-only *) -val snapshot: unit -> structured_constants - (* clambda-only *) -val backtrack: structured_constants -> unit - (* clambda-only *) - val read_unit_info: string -> unit_infos * Digest.t (* Read infos and MD5 from a [.cmx] file. *) val write_unit_info: unit_infos -> string -> unit diff --git a/middle_end/convert_primitives.ml b/middle_end/convert_primitives.ml deleted file mode 100644 index 93ecaae363b..00000000000 --- a/middle_end/convert_primitives.ml +++ /dev/null @@ -1,210 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2017 OCamlPro SAS *) -(* Copyright 2017 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"] - -let convert_unsafety is_unsafe : Clambda_primitives.is_safe = - if is_unsafe then - Unsafe - else - Safe - -let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = - match prim with - | Pmakeblock (tag, mutability, shape, mode) -> - Pmakeblock (tag, mutability, shape, mode) - | Pmakefloatblock (mutability, mode) -> - Pmakearray (Pfloatarray, mutability, mode) - | Pmakeufloatblock (mutability, mode) -> - Pmakeufloatblock (mutability, mode) - | Pfield (field, imm_or_ptr, sem) -> - let sem : Lambda.mutable_flag = - match sem with - | Reads_agree -> Immutable - | Reads_vary -> Mutable - in - Pfield (field, Pvalue Pgenval, imm_or_ptr, sem) - | Pfield_computed _sem -> Pfield_computed - | Psetfield (field, imm_or_pointer, init_or_assign) -> - Psetfield (field, imm_or_pointer, init_or_assign) - | Psetfield_computed (imm_or_pointer, init_or_assign) -> - Psetfield_computed (imm_or_pointer, init_or_assign) - | Pfloatfield (field, _sem, mode) -> Pfloatfield (field, mode) - | Psetfloatfield (field, init_or_assign) -> - Psetfloatfield (field, init_or_assign) - | Pufloatfield (field, _sem) -> Pufloatfield field - | Psetufloatfield (field, init_or_assign) -> - Psetufloatfield (field, init_or_assign) - | Pduprecord (repr, size) -> Pduprecord (repr, size) - | Pmake_unboxed_product layouts -> Pmake_unboxed_product layouts - | Punboxed_product_field (field, layouts) -> - Punboxed_product_field (field, layouts) - | Prunstack -> Prunstack - | Pperform -> Pperform - | Presume -> Presume - | Preperform -> Preperform - | Pccall prim -> Pccall prim - | Praise kind -> Praise kind - | Psequand -> Psequand - | Psequor -> Psequor - | Pnot -> Pnot - | Pnegint -> Pnegint - | Paddint -> Paddint - | Psubint -> Psubint - | Pmulint -> Pmulint - | Pdivint is_safe -> Pdivint is_safe - | Pmodint is_safe -> Pmodint is_safe - | Pandint -> Pandint - | Porint -> Porint - | Pxorint -> Pxorint - | Plslint -> Plslint - | Plsrint -> Plsrint - | Pasrint -> Pasrint - | Pintcomp comp -> Pintcomp comp - | Pcompare_ints -> Pcompare_ints - | Pcompare_floats -> Pcompare_floats - | Pcompare_bints bi -> Pcompare_bints bi - | Poffsetint offset -> Poffsetint offset - | Poffsetref offset -> Poffsetref offset - | Pintoffloat -> Pintoffloat - | Pfloatofint m -> Pfloatofint m - | Pnegfloat m -> Pnegfloat m - | Pabsfloat m -> Pabsfloat m - | Paddfloat m -> Paddfloat m - | Psubfloat m -> Psubfloat m - | Pmulfloat m -> Pmulfloat m - | Pdivfloat m -> Pdivfloat m - | Pfloatcomp comp -> Pfloatcomp comp - | Punboxed_float_comp comp -> Punboxed_float_comp comp - | Pstringlength -> Pstringlength - | Pstringrefu -> Pstringrefu - | Pstringrefs -> Pstringrefs - | Pbyteslength -> Pbyteslength - | Pbytesrefu -> Pbytesrefu - | Pbytessetu -> Pbytessetu - | Pbytesrefs -> Pbytesrefs - | Pbytessets -> Pbytessets - | Pmakearray (kind, mutability, mode) -> Pmakearray (kind, mutability, mode) - | Pduparray (kind, mutability) -> Pduparray (kind, mutability) - | Parraylength kind -> Parraylength kind - | Parrayrefu rkind -> Parrayrefu rkind - | Parraysetu skind -> Parraysetu skind - | Parrayrefs rkind -> Parrayrefs rkind - | Parraysets skind -> Parraysets skind - | Pisint _ -> Pisint - | Pisout -> Pisout - | Pcvtbint (src, dest, m) -> Pcvtbint (src, dest, m) - | Pnegbint (bi,m) -> Pnegbint (bi,m) - | Paddbint (bi,m) -> Paddbint (bi,m) - | Psubbint (bi,m) -> Psubbint (bi,m) - | Pmulbint (bi,m) -> Pmulbint (bi,m) - | Pbintofint (bi,m) -> Pbintofint (bi,m) - | Pintofbint bi -> Pintofbint bi - | Pandbint (bi,m) -> Pandbint (bi,m) - | Porbint (bi,m) -> Porbint (bi,m) - | Pxorbint (bi,m) -> Pxorbint (bi,m) - | Plslbint (bi,m) -> Plslbint (bi,m) - | Plsrbint (bi,m) -> Plsrbint (bi,m) - | Pasrbint (bi,m) -> Pasrbint (bi,m) - | Pbbswap (bi,m) -> Pbbswap (bi,m) - | Pdivbint { size; is_safe; mode } -> Pdivbint { size; is_safe; mode } - | Pmodbint { size; is_safe; mode } -> Pmodbint { size; is_safe; mode } - | Pbintcomp (bi, comp) -> Pbintcomp (bi, comp) - | Pbigarrayref (safe, dims, kind, layout) -> - Pbigarrayref (safe, dims, kind, layout) - | Pbigarrayset (safe, dims, kind, layout) -> - Pbigarrayset (safe, dims, kind, layout) - | Pstring_load_16 is_unsafe -> - Pstring_load (Sixteen, convert_unsafety is_unsafe, Lambda.alloc_heap) - | Pstring_load_32 (is_unsafe,m) -> - Pstring_load (Thirty_two, convert_unsafety is_unsafe, m) - | Pstring_load_64 (is_unsafe, m) -> - Pstring_load (Sixty_four, convert_unsafety is_unsafe, m) - | Pstring_load_128 {unsafe; mode} -> - Pstring_load (One_twenty_eight {aligned=false}, convert_unsafety unsafe, mode) - | Pbytes_load_16 is_unsafe -> - Pbytes_load (Sixteen, convert_unsafety is_unsafe, Lambda.alloc_heap) - | Pbytes_load_32 (is_unsafe, m) -> - Pbytes_load (Thirty_two, convert_unsafety is_unsafe, m) - | Pbytes_load_64 (is_unsafe, m) -> - Pbytes_load (Sixty_four, convert_unsafety is_unsafe, m) - | Pbytes_load_128 {unsafe; mode} -> - Pbytes_load (One_twenty_eight {aligned=false}, convert_unsafety unsafe, mode) - | Pbytes_set_16 is_unsafe -> - Pbytes_set (Sixteen, convert_unsafety is_unsafe) - | Pbytes_set_32 is_unsafe -> - Pbytes_set (Thirty_two, convert_unsafety is_unsafe) - | Pbytes_set_64 is_unsafe -> - Pbytes_set (Sixty_four, convert_unsafety is_unsafe) - | Pbytes_set_128 {unsafe} -> - Pbytes_set (One_twenty_eight {aligned=false}, convert_unsafety unsafe) - | Pbigstring_load_16 is_unsafe -> - Pbigstring_load (Sixteen, convert_unsafety is_unsafe, Lambda.alloc_heap) - | Pbigstring_load_32 (is_unsafe, m) -> - Pbigstring_load (Thirty_two, convert_unsafety is_unsafe, m) - | Pbigstring_load_64 (is_unsafe, m) -> - Pbigstring_load (Sixty_four, convert_unsafety is_unsafe, m) - | Pbigstring_load_128 {aligned; unsafe; mode} -> - Pbigstring_load (One_twenty_eight {aligned}, convert_unsafety unsafe, mode) - | Pbigstring_set_16 is_unsafe -> - Pbigstring_set (Sixteen, convert_unsafety is_unsafe) - | Pbigstring_set_32 is_unsafe -> - Pbigstring_set (Thirty_two, convert_unsafety is_unsafe) - | Pbigstring_set_64 is_unsafe -> - Pbigstring_set (Sixty_four, convert_unsafety is_unsafe) - | Pbigstring_set_128 {aligned; unsafe} -> - Pbigstring_set (One_twenty_eight {aligned}, convert_unsafety unsafe) - | Pbigarraydim dim -> Pbigarraydim dim - | Pbswap16 -> Pbswap16 - | Pint_as_pointer m -> Pint_as_pointer m - | Patomic_load { immediate_or_pointer } -> - Patomic_load { immediate_or_pointer } - | Patomic_exchange -> Patomic_exchange - | Patomic_cas -> Patomic_cas - | Patomic_fetch_add -> Patomic_fetch_add - | Popaque _ -> Popaque - | Pprobe_is_enabled {name} -> Pprobe_is_enabled {name} - | Pobj_dup -> - let module P = Primitive in - Pccall (Primitive.make - ~name:"caml_obj_dup" - ~alloc:true - ~c_builtin:false - ~effects:Only_generative_effects - ~coeffects:Has_coeffects - ~native_name:"caml_obj_dup" - ~native_repr_args:[P.Prim_global, P.Same_as_ocaml_repr Jkind.Sort.Value] - ~native_repr_res:(P.Prim_global, P.Same_as_ocaml_repr Jkind.Sort.Value)) - | Punbox_float -> Punbox_float - | Pbox_float m -> Pbox_float m - | Punbox_int bi -> Punbox_int bi - | Pbox_int (bi, m) -> Pbox_int (bi, m) - | Pget_header m -> Pget_header m - | Pdls_get -> Pdls_get - | Pobj_magic _ - | Pbytes_to_string - | Pbytes_of_string - | Pctconst _ - | Pignore - | Pgetglobal _ - | Psetglobal _ - | Pgetpredef _ - | Parray_to_iarray - | Parray_of_iarray - -> - Misc.fatal_errorf "lambda primitive %a can't be converted to \ - clambda primitive" - Printlambda.primitive prim diff --git a/middle_end/convert_primitives.mli b/middle_end/convert_primitives.mli deleted file mode 100644 index 8c3691268ae..00000000000 --- a/middle_end/convert_primitives.mli +++ /dev/null @@ -1,17 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2017 OCamlPro SAS *) -(* Copyright 2017 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. *) -(* *) -(**************************************************************************) - -val convert : Lambda.primitive -> Clambda_primitives.primitive diff --git a/middle_end/flambda/alias_analysis.ml b/middle_end/flambda/alias_analysis.ml deleted file mode 100644 index 3ea66ab6482..00000000000 --- a/middle_end/flambda/alias_analysis.ml +++ /dev/null @@ -1,168 +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-66"] -open! Int_replace_polymorphic_compare - -type allocation_point = - | Symbol of Symbol.t - | Variable of Variable.t - -type allocated_const = - | Normal of Allocated_const.t - | Array of Lambda.array_kind * Lambda.mutable_flag * Variable.t list - | Duplicate_array of Lambda.array_kind * Lambda.mutable_flag * Variable.t - -type constant_defining_value = - | Allocated_const of allocated_const - | Block of Tag.t * Variable.t list - | Set_of_closures of Flambda.set_of_closures - | Project_closure of Flambda.project_closure - | Move_within_set_of_closures of Flambda.move_within_set_of_closures - | Project_var of Flambda.project_var - | Field of Variable.t * int - | Symbol_field of Symbol.t * int - | Const of Flambda.const - | Symbol of Symbol.t - | Variable of Variable.t - -type initialize_symbol_field = Variable.t option - -type definitions = { - variable : constant_defining_value Variable.Tbl.t; - initialize_symbol : initialize_symbol_field list Symbol.Tbl.t; - symbol : Flambda.constant_defining_value Symbol.Tbl.t; -} - -let print_constant_defining_value ppf = function - | Allocated_const (Normal const) -> Allocated_const.print ppf const - | Allocated_const (Array (_, _, vars)) -> - Format.fprintf ppf "[| %a |]" - (Format.pp_print_list Variable.print) vars - | Allocated_const (Duplicate_array (_, _, var)) -> - Format.fprintf ppf "dup_array(%a)" Variable.print var - | Block (tag, vars) -> - Format.fprintf ppf "[|%a: %a|]" - Tag.print tag - (Format.pp_print_list Variable.print) vars - | Set_of_closures set -> Flambda.print_set_of_closures ppf set - | Project_closure project -> Flambda.print_project_closure ppf project - | Move_within_set_of_closures move -> - Flambda.print_move_within_set_of_closures ppf move - | Project_var project -> Flambda.print_project_var ppf project - | Field (var, field) -> Format.fprintf ppf "%a.(%d)" Variable.print var field - | Symbol_field (sym, field) -> - Format.fprintf ppf "%a.(%d)" Symbol.print sym field - | Const const -> Flambda.print_const ppf const - | Symbol symbol -> Symbol.print ppf symbol - | Variable var -> Variable.print ppf var - -let rec resolve_definition - (definitions: definitions) - (var: Variable.t) - (def: constant_defining_value) - ~the_dead_constant : allocation_point = - match def with - | Allocated_const _ - | Block _ - | Set_of_closures _ - | Project_closure _ - | Const _ - | Move_within_set_of_closures _ -> - Variable var - | Project_var {var} -> - fetch_variable definitions (Var_within_closure.unwrap var) - ~the_dead_constant - | Variable v -> - fetch_variable definitions v - ~the_dead_constant - | Symbol sym -> Symbol sym - | Field (v, n) -> - begin match fetch_variable definitions v ~the_dead_constant with - | Symbol s -> - fetch_symbol_field definitions s n ~the_dead_constant - | Variable v -> - fetch_variable_field definitions v n ~the_dead_constant - end - | Symbol_field (symbol, field) -> - fetch_symbol_field definitions symbol field ~the_dead_constant - -and fetch_variable - (definitions: definitions) - (var: Variable.t) - ~the_dead_constant : allocation_point = - match Variable.Tbl.find definitions.variable var with - | exception Not_found -> Variable var - | def -> resolve_definition definitions var def ~the_dead_constant - -and fetch_variable_field - (definitions: definitions) - (var: Variable.t) - (field: int) - ~the_dead_constant : allocation_point = - match Variable.Tbl.find definitions.variable var with - | Block (_, fields) -> - begin match List.nth fields field with - | exception Not_found -> Symbol the_dead_constant - | v -> fetch_variable definitions v ~the_dead_constant - end - | exception Not_found -> - Misc.fatal_errorf "No definition for field access to %a" Variable.print var - | Symbol _ | Variable _ | Project_var _ | Field _ | Symbol_field _ -> - (* Must have been resolved *) - assert false - | Const _ | Allocated_const _ - | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ -> - Symbol the_dead_constant - -and fetch_symbol_field - (definitions: definitions) - (sym: Symbol.t) - (field: int) - ~the_dead_constant : allocation_point = - match Symbol.Tbl.find definitions.symbol sym with - | Block (_, fields) -> - begin match List.nth fields field with - | exception Not_found -> Symbol the_dead_constant - | Symbol s -> Symbol s - | Const _ -> Symbol sym - end - | exception Not_found -> - begin match Symbol.Tbl.find definitions.initialize_symbol sym with - | fields -> - begin match List.nth fields field with - | None -> - Misc.fatal_errorf "Constant field access to an inconstant %a" - Symbol.print sym - | Some v -> - fetch_variable definitions v ~the_dead_constant - end - | exception Not_found -> - Misc.fatal_errorf "No definition for field access to %a" - Symbol.print sym - end - | Allocated_const _ | Set_of_closures _ | Project_closure _ -> - Symbol the_dead_constant - -let run variable initialize_symbol symbol ~the_dead_constant = - let definitions = { variable; initialize_symbol; symbol; } in - Variable.Tbl.fold (fun var definition result -> - let definition = - resolve_definition definitions var definition ~the_dead_constant - in - Variable.Map.add var definition result) - definitions.variable - Variable.Map.empty diff --git a/middle_end/flambda/alias_analysis.mli b/middle_end/flambda/alias_analysis.mli deleted file mode 100644 index 27b2282d942..00000000000 --- a/middle_end/flambda/alias_analysis.mli +++ /dev/null @@ -1,63 +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"] - -type allocation_point = - | Symbol of Symbol.t - | Variable of Variable.t - -type allocated_const = - | Normal of Allocated_const.t - | Array of Lambda.array_kind * Lambda.mutable_flag * Variable.t list - | Duplicate_array of Lambda.array_kind * Lambda.mutable_flag * Variable.t - -type constant_defining_value = - | Allocated_const of allocated_const - | Block of Tag.t * Variable.t list - | Set_of_closures of Flambda.set_of_closures - | Project_closure of Flambda.project_closure - | Move_within_set_of_closures of Flambda.move_within_set_of_closures - | Project_var of Flambda.project_var - | Field of Variable.t * int - | Symbol_field of Symbol.t * int - | Const of Flambda.const - | Symbol of Symbol.t - | Variable of Variable.t - -type initialize_symbol_field = Variable.t option - -(** Simple alias analysis working over information about which - symbols have been assigned to variables; and which constants have - been assigned to symbols. The return value gives the assignment - of the defining values of constants to variables. - Also see comments for [Lift_constants], whose input feeds this - pass. - - Variables found to be ill-typed accesses to other constants, for - example arising from dead code, will be pointed at [the_dead_constant]. -*) -val run - : constant_defining_value Variable.Tbl.t - -> initialize_symbol_field list Symbol.Tbl.t - -> Flambda.constant_defining_value Symbol.Tbl.t - -> the_dead_constant:Symbol.t - -> allocation_point Variable.Map.t - -val print_constant_defining_value - : Format.formatter - -> constant_defining_value - -> unit diff --git a/middle_end/flambda/allocated_const.ml b/middle_end/flambda/allocated_const.ml deleted file mode 100644 index 78dc4ee103a..00000000000 --- a/middle_end/flambda/allocated_const.ml +++ /dev/null @@ -1,86 +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-66"] -open! Int_replace_polymorphic_compare - -type t = - | Float of float - | Int32 of int32 - | Int64 of int64 - | Nativeint of nativeint - | Float_array of float list - | Immutable_float_array of float list - | String of string - | Immutable_string of string - -let compare_floats x1 x2 = - (* It is important to compare the bit patterns here, so as not to - be subject to bugs such as GPR#295. *) - Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2) - -let compare (x : t) (y : t) = - let rec compare_float_lists l1 l2 = - match l1, l2 with - | [], [] -> 0 - | [], _::_ -> -1 - | _::_, [] -> 1 - | h1::t1, h2::t2 -> - let c = compare_floats h1 h2 in - if c <> 0 then c else compare_float_lists t1 t2 - in - match x, y with - | Float x, Float y -> compare_floats x y - | Int32 x, Int32 y -> Int32.compare x y - | Int64 x, Int64 y -> Int64.compare x y - | Nativeint x, Nativeint y -> Nativeint.compare x y - | Float_array x, Float_array y -> compare_float_lists x y - | Immutable_float_array x, Immutable_float_array y -> compare_float_lists x y - | String x, String y -> String.compare x y - | Immutable_string x, Immutable_string y -> String.compare x y - | Float _, _ -> -1 - | _, Float _ -> 1 - | Int32 _, _ -> -1 - | _, Int32 _ -> 1 - | Int64 _, _ -> -1 - | _, Int64 _ -> 1 - | Nativeint _, _ -> -1 - | _, Nativeint _ -> 1 - | Float_array _, _ -> -1 - | _, Float_array _ -> 1 - | Immutable_float_array _, _ -> -1 - | _, Immutable_float_array _ -> 1 - | String _, _ -> -1 - | _, String _ -> 1 - -let print ppf (t : t) = - let fprintf = Format.fprintf in - let floats ppf fl = - List.iter (fun f -> fprintf ppf "@ %f" f) fl - in - match t with - | String s -> fprintf ppf "%S" s - | Immutable_string s -> fprintf ppf "#%S" s - | Int32 n -> fprintf ppf "%lil" n - | Int64 n -> fprintf ppf "%LiL" n - | Nativeint n -> fprintf ppf "%nin" n - | Float f -> fprintf ppf "%f" f - | Float_array [] -> fprintf ppf "[| |]" - | Float_array (f1 :: fl) -> - fprintf ppf "@[<1>[|@[%f%a@]|]@]" f1 floats fl - | Immutable_float_array [] -> fprintf ppf "[|# |]" - | Immutable_float_array (f1 :: fl) -> - fprintf ppf "@[<1>[|# @[%f%a@]|]@]" f1 floats fl diff --git a/middle_end/flambda/allocated_const.mli b/middle_end/flambda/allocated_const.mli deleted file mode 100644 index 0bdbe49ec4f..00000000000 --- a/middle_end/flambda/allocated_const.mli +++ /dev/null @@ -1,38 +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"] - -(** Constants that are always allocated (possibly statically). Blocks - are not included here since they are always encoded using - [Prim (Pmakeblock, ...)]. *) - -type t = - | Float of float - | Int32 of int32 - | Int64 of int64 - | Nativeint of nativeint - (* CR-someday mshinwell: consider using "float array" *) - | Float_array of float list - | Immutable_float_array of float list - | String of string - | Immutable_string of string - -val compare_floats : float -> float -> int - -val compare : t -> t -> int - -val print : Format.formatter -> t -> unit diff --git a/middle_end/flambda/augment_specialised_args.ml b/middle_end/flambda/augment_specialised_args.ml deleted file mode 100644 index f404c070b53..00000000000 --- a/middle_end/flambda/augment_specialised_args.ml +++ /dev/null @@ -1,801 +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-66"] -open! Int_replace_polymorphic_compare - -module E = Inline_and_simplify_aux.Env -module B = Inlining_cost.Benefit - -module Definition = struct - type t = - | Existing_inner_free_var of Variable.t * Lambda.layout - | Projection_from_existing_specialised_arg of Projection.t * Lambda.layout - - include Identifiable.Make (struct - type nonrec t = t - - let compare t1 t2 = - match t1, t2 with - | Existing_inner_free_var (var1, _), - Existing_inner_free_var (var2, _) -> - Variable.compare var1 var2 - | Projection_from_existing_specialised_arg (proj1, _), - Projection_from_existing_specialised_arg (proj2, _) -> - Projection.compare proj1 proj2 - | Existing_inner_free_var _, _ -> -1 - | _, Existing_inner_free_var _ -> 1 - - let equal t1 t2 = - (compare t1 t2) = 0 - - let hash = Hashtbl.hash - - let print ppf t = - match t with - | Existing_inner_free_var (var, kind) -> - Format.fprintf ppf "Existing_inner_free_var (%a, %a)" - Variable.print var Printlambda.layout kind - | Projection_from_existing_specialised_arg (projection, kind) -> - Format.fprintf ppf "Projection_from_existing_specialised_arg (%a, %a)" - Projection.print projection Printlambda.layout kind - - let output _ _ = failwith "Definition.output not yet implemented" - end) -end - -module What_to_specialise = struct - type t = { - (* [definitions] is indexed by (fun_var, group) *) - definitions : Definition.t list Variable.Pair.Map.t; - set_of_closures : Flambda.set_of_closures; - make_direct_call_surrogates_for : Variable.Set.t; - } - - let create ~set_of_closures = - { definitions = Variable.Pair.Map.empty; - set_of_closures; - make_direct_call_surrogates_for = Variable.Set.empty; - } - - let new_specialised_arg t ~fun_var ~group ~definition = - let key = fun_var, group in - let definitions = - match Variable.Pair.Map.find key t.definitions with - | exception Not_found -> [] - | definitions -> definitions - in - let definitions = - Variable.Pair.Map.add (fun_var, group) (definition :: definitions) - t.definitions - in - { t with definitions; } - - let make_direct_call_surrogate_for t ~fun_var = - match Variable.Map.find fun_var t.set_of_closures.function_decls.funs with - | exception Not_found -> - Misc.fatal_errorf "use_direct_call_surrogate_for: %a is not a fun_var \ - from the given set of closures" - Variable.print fun_var - | _ -> - { t with - make_direct_call_surrogates_for = - Variable.Set.add fun_var t.make_direct_call_surrogates_for; - } -end - -module W = What_to_specialise - -module type S = sig - val pass_name : string - - val what_to_specialise - : env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> What_to_specialise.t -end - -module Processed_what_to_specialise = struct - type for_one_function = { - fun_var : Variable.t; - function_decl : Flambda.function_declaration; - make_direct_call_surrogates : bool; - new_definitions_indexed_by_new_inner_vars : Definition.t Variable.Map.t; - all_new_definitions : Definition.Set.t; - new_inner_to_new_outer_vars : Variable.t Variable.Map.t; - total_number_of_args : int; - existing_specialised_args : Flambda.specialised_to Variable.Map.t; - } - - type t = { - set_of_closures : Flambda.set_of_closures; - existing_definitions_via_spec_args_indexed_by_fun_var - : Definition.Set.t Variable.Map.t; - (* The following two maps' definitions have already been rewritten - into their lifted form (i.e. they reference outer rather than inner - variables). *) - new_lifted_defns_indexed_by_new_outer_vars : Projection.t Variable.Map.t; - new_outer_vars_indexed_by_new_lifted_defns : Variable.t Projection.Map.t; - functions : for_one_function Variable.Map.t; - make_direct_call_surrogates_for : Variable.Set.t; - } - - let lift_projection t ~(projection : Projection.t) = - (* The lifted definition must be in terms of outer variables, - not inner variables. *) - let find_outer_var inner_var = - match Variable.Map.find inner_var t.set_of_closures.specialised_args with - | (outer_var : Flambda.specialised_to) -> outer_var.var - | exception Not_found -> - Misc.fatal_errorf "find_outer_var: expected %a \ - to be in [specialised_args], but it is \ - not. The projection was: %a. Set of closures: %a" - Variable.print inner_var - Projection.print projection - Flambda.print_set_of_closures t.set_of_closures - in - Projection.map_projecting_from projection ~f:find_outer_var - - let really_add_new_specialised_arg t ~group ~(definition : Definition.t) - ~(for_one_function : for_one_function) = - let fun_var = for_one_function.fun_var in - (* We know here that a new specialised argument must be added. This - needs a "new inner var" and a "new outer var". However if there - is already a lifted projection being introduced around the set - of closures (corresponding to another new specialised argument), - we should re-use its "new outer var" to avoid duplication of - projection definitions. Likewise if the definition is just - [Existing_inner_free_var], in which case we can use the - corresponding existing outer free variable. *) - let new_outer_var, t = - let existing_outer_var = - match definition with - | Existing_inner_free_var _ -> None - | Projection_from_existing_specialised_arg (projection, _) -> - let projection = lift_projection t ~projection in - match - Projection.Map.find projection - t.new_outer_vars_indexed_by_new_lifted_defns - with - | new_outer_var -> Some new_outer_var - | exception Not_found -> None - in - match existing_outer_var with - | Some existing_outer_var -> existing_outer_var, t - | None -> - match definition with - | Existing_inner_free_var (existing_inner_var, _) -> - begin match - Variable.Map.find existing_inner_var - t.set_of_closures.free_vars - with - | exception Not_found -> - Misc.fatal_errorf "really_add_new_specialised_arg: \ - Existing_inner_free_var %a is not an inner free variable \ - of %a in %a" - Variable.print existing_inner_var - Variable.print fun_var - Flambda.print_set_of_closures t.set_of_closures - | existing_outer_var -> existing_outer_var.var, t - end - | Projection_from_existing_specialised_arg (projection, _) -> - let new_outer_var = Variable.rename group in - let projection = lift_projection t ~projection in - let new_outer_vars_indexed_by_new_lifted_defns = - Projection.Map.add - projection new_outer_var - t.new_outer_vars_indexed_by_new_lifted_defns - in - let new_lifted_defns_indexed_by_new_outer_vars = - Variable.Map.add - new_outer_var projection - t.new_lifted_defns_indexed_by_new_outer_vars - in - let t = - { t with - new_outer_vars_indexed_by_new_lifted_defns; - new_lifted_defns_indexed_by_new_outer_vars; - } - in - new_outer_var, t - in - let new_inner_var = Variable.rename group in - let new_inner_to_new_outer_vars = - Variable.Map.add new_inner_var new_outer_var - for_one_function.new_inner_to_new_outer_vars - in - let for_one_function : for_one_function = - { for_one_function with - new_definitions_indexed_by_new_inner_vars = - Variable.Map.add new_inner_var definition - for_one_function.new_definitions_indexed_by_new_inner_vars; - all_new_definitions = - Definition.Set.add definition - for_one_function.all_new_definitions; - new_inner_to_new_outer_vars; - total_number_of_args = for_one_function.total_number_of_args + 1; - } - in - { t with - functions = Variable.Map.add fun_var for_one_function t.functions; - } - - let new_specialised_arg t ~fun_var ~group ~definition = - let for_one_function : for_one_function = - match Variable.Map.find fun_var t.functions with - | exception Not_found -> - begin - match Variable.Map.find fun_var t.set_of_closures.function_decls.funs - with - | exception Not_found -> assert false - | (function_decl : Flambda.function_declaration) -> - let params = Parameter.Set.vars function_decl.params in - let existing_specialised_args = - Variable.Map.filter (fun inner_var _spec_to -> - Variable.Set.mem inner_var params) - t.set_of_closures.specialised_args - in - let make_direct_call_surrogates = - Variable.Set.mem fun_var t.make_direct_call_surrogates_for - in - { fun_var; - function_decl; - make_direct_call_surrogates; - new_definitions_indexed_by_new_inner_vars = Variable.Map.empty; - all_new_definitions = Definition.Set.empty; - new_inner_to_new_outer_vars = Variable.Map.empty; - (* The "+ 1" is just in case there is a closure environment - parameter added later. *) - total_number_of_args = List.length function_decl.params + 1; - existing_specialised_args; - } - end - | for_one_function -> for_one_function - in - (* Determine whether there already exists an existing specialised argument - that is known to be equal to the one proposed to this function. If so, - use that instead. (Note that we also desire to dedup against any - new specialised arguments added to the current function; but that - happens automatically since [Extract_projections] returns a set.) *) - let exists_already = - match - Variable.Map.find fun_var - t.existing_definitions_via_spec_args_indexed_by_fun_var - with - | exception Not_found -> false - | definitions -> Definition.Set.mem definition definitions - in - if exists_already then t - else really_add_new_specialised_arg t ~group ~definition ~for_one_function - - let create ~env ~(what_to_specialise : W.t) = - let existing_definitions_via_spec_args_indexed_by_fun_var = - Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> - if function_decl.stub then - Definition.Set.empty - else - let params = Parameter.Set.vars function_decl.params in - Variable.Map.fold (fun inner_var - (spec_to : Flambda.specialised_to) definitions -> - if not (Variable.Set.mem inner_var params) then - definitions - else - let definition : Definition.t = - match spec_to.projection with - | None -> Existing_inner_free_var (inner_var, spec_to.kind) - | Some projection -> - Projection_from_existing_specialised_arg - (projection, spec_to.kind) - in - Definition.Set.add definition definitions) - what_to_specialise.set_of_closures.specialised_args - Definition.Set.empty) - what_to_specialise.set_of_closures.function_decls.funs - in - let t : t = - { set_of_closures = what_to_specialise.set_of_closures; - existing_definitions_via_spec_args_indexed_by_fun_var; - new_lifted_defns_indexed_by_new_outer_vars = Variable.Map.empty; - new_outer_vars_indexed_by_new_lifted_defns = Projection.Map.empty; - functions = Variable.Map.empty; - make_direct_call_surrogates_for = - what_to_specialise.make_direct_call_surrogates_for; - } - in - (* It is important to limit the number of arguments added: if arguments - end up being passed on the stack, tail call optimization will be - disabled (see asmcomp/selectgen.ml). - For each group of new specialised args provided by [T], either all or - none of them will be added. (This is to avoid the situation where we - add extra arguments but yet fail to eliminate an original one by - stopping part-way through the specialised args addition.) *) - let by_group = - Variable.Pair.Map.fold (fun (fun_var, group) definitions by_group -> - let fun_vars_and_definitions = - match Variable.Map.find group by_group with - | exception Not_found -> [] - | fun_vars_and_definitions -> fun_vars_and_definitions - in - Variable.Map.add group - ((fun_var, definitions)::fun_vars_and_definitions) - by_group) - what_to_specialise.definitions - Variable.Map.empty - in - let module Backend = (val (E.backend env) : Backend_intf.S) in - Variable.Map.fold (fun group fun_vars_and_definitions t -> - let original_t = t in - let t = - (* Try adding all specialised args in the current group. *) - List.fold_left (fun t (fun_var, definitions) -> - List.fold_left (fun t definition -> - new_specialised_arg t ~fun_var ~group ~definition) - t - definitions) - t - fun_vars_and_definitions - in - let some_function_has_too_many_args = - Variable.Map.exists (fun _ (for_one_function : for_one_function) -> - for_one_function.total_number_of_args - > Backend.max_sensible_number_of_arguments) - t.functions - in - if some_function_has_too_many_args then - original_t (* drop this group *) - else - t) - by_group - t -end - -module P = Processed_what_to_specialise - -let check_invariants ~pass_name ~(set_of_closures : Flambda.set_of_closures) - ~original_set_of_closures = - if !Clflags.flambda_invariant_checks then begin - Variable.Map.iter (fun fun_var - (function_decl : Flambda.function_declaration) -> - let params = Parameter.Set.vars function_decl.params in - Variable.Map.iter (fun inner_var - (outer_var : Flambda.specialised_to) -> - if Variable.Set.mem inner_var params then begin - assert (not (Variable.Set.mem outer_var.var - function_decl.free_variables)); - match outer_var.projection with - | None -> () - | Some projection -> - let from = Projection.projecting_from projection in - if not (Variable.Set.mem from params) then begin - Misc.fatal_errorf "Augment_specialised_args (%s): \ - specialised argument (%a -> %a) references a \ - projection variable that is not a specialised \ - argument of the function %a. @ The set of closures \ - before the transformation was:@ %a. @ The set of \ - closures after the transformation was:@ %a." - pass_name - Variable.print inner_var - Flambda.print_specialised_to outer_var - Variable.print fun_var - Flambda.print_set_of_closures original_set_of_closures - Flambda.print_set_of_closures set_of_closures - end - end) - set_of_closures.specialised_args) - set_of_closures.function_decls.funs - end - -module Make (T : S) = struct - let () = Pass_wrapper.register ~pass_name:T.pass_name - - let rename_function_and_parameters ~fun_var - ~(function_decl : Flambda.function_declaration) = - let new_fun_var = Variable.rename fun_var in - let params_renaming_list = - List.map (fun param -> - let new_param = Parameter.rename param in - param, new_param) - function_decl.params - in - let renamed_params = List.map snd params_renaming_list in - let params_renaming = - Variable.Map.of_list - (List.map (fun (param, new_param) -> - Parameter.var param, Parameter.var new_param) - params_renaming_list) - in - new_fun_var, params_renaming, renamed_params - - let create_wrapper ~(for_one_function : P.for_one_function) ~benefit = - let fun_var = for_one_function.fun_var in - let function_decl = for_one_function.function_decl in - (* To avoid increasing the free variables of the wrapper, for - general cleanliness, we restate the definitions of the - newly-specialised arguments in the wrapper itself in terms of the - original specialised arguments. The variables bound to these - definitions are called the "specialised args bound in the wrapper". - Note that the domain of [params_renaming] is a (non-strict) superset - of the "inner vars" of the original specialised args. *) - let params = Parameter.Set.vars function_decl.params in - let new_fun_var, params_renaming, wrapper_params = - rename_function_and_parameters ~fun_var ~function_decl - in - let find_wrapper_param param = - assert (Variable.Set.mem param params); - match Variable.Map.find param params_renaming with - | wrapper_param -> wrapper_param - | exception Not_found -> - Misc.fatal_errorf "find_wrapper_param: expected %a \ - to be in [params_renaming], but it is not." - Variable.print param - in - let new_inner_vars_to_spec_args_bound_in_the_wrapper_renaming = - Variable.Map.mapi (fun new_inner_var _ -> - Variable.rename new_inner_var) - for_one_function.new_definitions_indexed_by_new_inner_vars - in - let spec_args_bound_in_the_wrapper = - (* N.B.: in the order matching the new specialised argument parameters - to the main function. *) - Variable.Map.data - new_inner_vars_to_spec_args_bound_in_the_wrapper_renaming - in - let mode = - if function_decl.region then Lambda.alloc_heap else Lambda.alloc_local in - (* New definitions that project from existing specialised args need - to be rewritten to use the corresponding specialised args of - the wrapper. Definitions that are just equality to existing - inner free variables do not need to be changed. Once this has - been done the wrapper body can be constructed. - We also need to rewrite definitions for any existing specialised - args; these now have corresponding wrapper parameters that must - also be specialised. *) - let wrapper_body, benefit = - let apply : Flambda.expr = - Apply { - func = new_fun_var; - args = - (Parameter.List.vars wrapper_params) @ - spec_args_bound_in_the_wrapper; - result_layout = function_decl.return_layout; - kind = Direct (Closure_id.wrap new_fun_var); - dbg = Debuginfo.none; - reg_close = Rc_normal; - mode; - inlined = Default_inlined; - specialise = Default_specialise; - probe = None; - } - in - Variable.Map.fold (fun new_inner_var definition (wrapper_body, benefit) -> - let definition : Definition.t = - match (definition : Definition.t) with - | Existing_inner_free_var _ -> definition - | Projection_from_existing_specialised_arg (projection, kind) -> - Projection_from_existing_specialised_arg - (Projection.map_projecting_from projection - ~f:find_wrapper_param, - kind) - in - let benefit = - match (definition : Definition.t) with - | Existing_inner_free_var _ -> benefit - | Projection_from_existing_specialised_arg (projection, _) -> - B.add_projection projection benefit - in - match - Variable.Map.find new_inner_var - new_inner_vars_to_spec_args_bound_in_the_wrapper_renaming - with - | exception Not_found -> assert false - | new_inner_var_of_wrapper -> - let named : Flambda.named = - match definition with - | Existing_inner_free_var (existing_inner_var, _) -> - Expr (Var existing_inner_var) - | Projection_from_existing_specialised_arg (projection, _) -> - Flambda_utils.projection_to_named projection - in - let wrapper_body = - Flambda.create_let new_inner_var_of_wrapper named wrapper_body - in - (wrapper_body, benefit)) - for_one_function.new_definitions_indexed_by_new_inner_vars - (apply, benefit) - in - let rewritten_existing_specialised_args = - Variable.Map.fold (fun inner_var (spec_to : Flambda.specialised_to) - result -> - let inner_var = find_wrapper_param inner_var in - let projection = - match spec_to.projection with - | None -> None - | Some projection -> - Some (Projection.map_projecting_from projection - ~f:find_wrapper_param) - in - let spec_to : Flambda.specialised_to = - { var = spec_to.var; - projection; - kind = spec_to.kind; - } - in - Variable.Map.add inner_var spec_to result) - for_one_function.existing_specialised_args - Variable.Map.empty - in - let alloc_mode = - (* Wrapper closes over no more values than the original function, - so can share the same alloc mode *) - function_decl.alloc_mode - in - let new_function_decl = - Flambda.create_function_declaration - ~params:wrapper_params - ~return_layout:function_decl.return_layout - ~alloc_mode - ~region:function_decl.region - ~body:wrapper_body - ~stub:true - ~inline:Default_inline - ~specialise:Default_specialise - ~check:Default_check - ~is_a_functor:false - ~closure_origin:function_decl.closure_origin - ~poll:Default_poll (* don't propagate attribute to wrappers *) - in - new_fun_var, new_function_decl, rewritten_existing_specialised_args, - benefit - - let rewrite_function_decl (t : P.t) ~env ~duplicate_function - ~(for_one_function : P.for_one_function) ~benefit = - let set_of_closures = t.set_of_closures in - let fun_var = for_one_function.fun_var in - let function_decl = for_one_function.function_decl in - let num_definitions = - Variable.Map.cardinal for_one_function. - new_definitions_indexed_by_new_inner_vars - in - if function_decl.stub - || num_definitions < 1 - || Variable.Map.mem fun_var set_of_closures.direct_call_surrogates - then - None - else - let new_fun_var, wrapper, rewritten_existing_specialised_args, benefit = - create_wrapper ~for_one_function ~benefit - in - let new_specialised_args = - Variable.Map.mapi (fun new_inner_var (definition : Definition.t) - : Flambda.specialised_to -> - assert (not (Variable.Map.mem new_inner_var - set_of_closures.specialised_args)); - match - Variable.Map.find new_inner_var - for_one_function.new_inner_to_new_outer_vars - with - | exception Not_found -> assert false - | new_outer_var -> - match definition with - | Existing_inner_free_var (_, kind) -> - { var = new_outer_var; - projection = None; - kind; - } - | Projection_from_existing_specialised_arg (projection, kind) -> - let projecting_from = Projection.projecting_from projection in - assert (Variable.Map.mem projecting_from - set_of_closures.specialised_args); - assert (Variable.Set.mem projecting_from - (Parameter.Set.vars function_decl.params)); - { var = new_outer_var; - projection = Some projection; - kind; - }) - for_one_function.new_definitions_indexed_by_new_inner_vars - in - let specialised_args = - Variable.Map.disjoint_union rewritten_existing_specialised_args - new_specialised_args - in - let specialised_args, existing_function_decl = - if not for_one_function.make_direct_call_surrogates then - specialised_args, None - else - let function_decl, new_specialised_args = - duplicate_function ~env ~set_of_closures ~fun_var ~new_fun_var - in - let specialised_args = - Variable.Map.disjoint_union specialised_args new_specialised_args - in - specialised_args, Some function_decl - in - let all_params = - let new_params = - Variable.Set.elements (Variable.Map.keys - for_one_function.new_inner_to_new_outer_vars) - in - let last_mode = - List.fold_left (fun _mode p -> Parameter.alloc_mode p) - function_decl.alloc_mode function_decl.params - in - let new_params = - List.map (fun p -> - let definition = - Variable.Map.find p - for_one_function.new_definitions_indexed_by_new_inner_vars - in - let kind = - match definition with - | Existing_inner_free_var (_, kind) -> kind - | Projection_from_existing_specialised_arg (_, kind) -> kind - in - Parameter.wrap p last_mode kind) new_params - in - function_decl.params @ new_params - in - let closure_origin = - Closure_origin.create (Closure_id.wrap new_fun_var) - in - let rewritten_function_decl = - Flambda.create_function_declaration - ~params:all_params - ~return_layout:function_decl.return_layout - ~alloc_mode:function_decl.alloc_mode - ~region:function_decl.region - ~body:function_decl.body - ~stub:function_decl.stub - ~inline:function_decl.inline - ~specialise:function_decl.specialise - ~check:function_decl.check - ~is_a_functor:function_decl.is_a_functor - ~closure_origin - ~poll:function_decl.poll - in - let funs, direct_call_surrogates = - if for_one_function.make_direct_call_surrogates then - let surrogate = Variable.rename fun_var in - let funs = - (* In this case, the original function declaration remains - untouched up to alpha-equivalence. Direct calls to it - (including inside the rewritten original function) will be - replaced by calls to the surrogate (i.e. the wrapper) which - will then be inlined. *) - let existing_function_decl = - match existing_function_decl with - | Some decl -> decl - | None -> assert false - in - Variable.Map.add new_fun_var rewritten_function_decl - (Variable.Map.add surrogate wrapper - (Variable.Map.add fun_var existing_function_decl - Variable.Map.empty)) - in - let direct_call_surrogates = - Variable.Map.add fun_var surrogate Variable.Map.empty - in - funs, direct_call_surrogates - else - let funs = - Variable.Map.add new_fun_var rewritten_function_decl - (Variable.Map.add fun_var wrapper Variable.Map.empty) - in - funs, Variable.Map.empty - in - let free_vars = Variable.Map.empty in - Some (funs, free_vars, specialised_args, direct_call_surrogates, benefit) - - let add_lifted_projections_around_set_of_closures - ~(set_of_closures : Flambda.set_of_closures) ~benefit - ~new_lifted_defns_indexed_by_new_outer_vars = - let body = - Flambda_utils.name_expr - ~name:Internal_variable_names.set_of_closures - (Set_of_closures set_of_closures) - in - Variable.Map.fold (fun new_outer_var (projection : Projection.t) - (expr, benefit) -> - let named = Flambda_utils.projection_to_named projection in - let benefit = B.add_projection projection benefit in - let expr = Flambda.create_let new_outer_var named expr in - expr, benefit) - new_lifted_defns_indexed_by_new_outer_vars - (body, benefit) - - let rewrite_set_of_closures_core ~env ~duplicate_function ~benefit - ~(set_of_closures : Flambda.set_of_closures) = - let what_to_specialise = - P.create ~env - ~what_to_specialise:(T.what_to_specialise ~env ~set_of_closures) - in - let original_set_of_closures = set_of_closures in - let funs, free_vars, specialised_args, direct_call_surrogates, - done_something, benefit = - Variable.Map.fold (fun fun_var function_decl - (funs, free_vars, specialised_args, direct_call_surrogates, - done_something, benefit) -> - match Variable.Map.find fun_var what_to_specialise.functions with - | exception Not_found -> - let funs = Variable.Map.add fun_var function_decl funs in - funs, free_vars, specialised_args, direct_call_surrogates, - done_something, benefit - | (for_one_function : P.for_one_function) -> - assert (Variable.equal fun_var for_one_function.fun_var); - match - rewrite_function_decl what_to_specialise ~env - ~duplicate_function ~for_one_function ~benefit - with - | None -> - let function_decl = for_one_function.function_decl in - let funs = Variable.Map.add fun_var function_decl funs in - funs, free_vars, specialised_args, direct_call_surrogates, - done_something, benefit - | Some (funs', free_vars', specialised_args', - direct_call_surrogates', benefit) -> - let funs = Variable.Map.disjoint_union funs funs' in - let direct_call_surrogates = - Variable.Map.disjoint_union direct_call_surrogates - direct_call_surrogates' - in - let free_vars = - Variable.Map.disjoint_union free_vars free_vars' - in - let specialised_args = - Variable.Map.disjoint_union specialised_args specialised_args' - in - funs, free_vars, specialised_args, direct_call_surrogates, true, - benefit) - set_of_closures.function_decls.funs - (Variable.Map.empty, set_of_closures.free_vars, - set_of_closures.specialised_args, - set_of_closures.direct_call_surrogates, false, benefit) - in - if not done_something then - None - else - let function_decls = - Flambda.update_function_declarations set_of_closures.function_decls - ~funs - in - assert (Variable.Map.cardinal specialised_args - >= Variable.Map.cardinal original_set_of_closures.specialised_args); - let set_of_closures = - Flambda.create_set_of_closures - ~function_decls - ~free_vars - ~specialised_args - ~direct_call_surrogates - in - if !Clflags.flambda_invariant_checks then begin - check_invariants ~set_of_closures ~original_set_of_closures - ~pass_name:T.pass_name - end; - let expr, benefit = - add_lifted_projections_around_set_of_closures ~set_of_closures ~benefit - ~new_lifted_defns_indexed_by_new_outer_vars: - what_to_specialise.new_lifted_defns_indexed_by_new_outer_vars - in - Some (expr, benefit) - - let rewrite_set_of_closures ~env ~duplicate_function ~set_of_closures = - Pass_wrapper.with_dump ~ppf_dump:(Inline_and_simplify_aux.Env.ppf_dump env) - ~pass_name:T.pass_name ~input:set_of_closures - ~print_input:Flambda.print_set_of_closures - ~print_output:(fun ppf (expr, _) -> Flambda.print ppf expr) - ~f:(fun () -> - rewrite_set_of_closures_core ~env ~duplicate_function - ~benefit:B.zero ~set_of_closures) -end diff --git a/middle_end/flambda/augment_specialised_args.mli b/middle_end/flambda/augment_specialised_args.mli deleted file mode 100644 index 16fe59e6f09..00000000000 --- a/middle_end/flambda/augment_specialised_args.mli +++ /dev/null @@ -1,65 +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. *) -(* *) -(**************************************************************************) - -(** Helper module for adding specialised arguments to sets of closures. *) - -module Definition : sig - type t = - | Existing_inner_free_var of Variable.t * Lambda.layout - | Projection_from_existing_specialised_arg of Projection.t * Lambda.layout -end - -module What_to_specialise : sig - type t - - val create - : set_of_closures:Flambda.set_of_closures - -> t - - val new_specialised_arg - : t - -> fun_var:Variable.t - -> group:Variable.t - -> definition:Definition.t (* [projecting_from] "existing inner vars" *) - -> t - - val make_direct_call_surrogate_for : t -> fun_var:Variable.t -> t -end - -module type S = sig - val pass_name : string - - val what_to_specialise - : env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> What_to_specialise.t -end - -module Make (_ : S) : sig - (** [duplicate_function] should be - [Inline_and_simplify.duplicate_function]. *) - val rewrite_set_of_closures - : env:Inline_and_simplify_aux.Env.t - -> duplicate_function:( - env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> fun_var:Variable.t - -> new_fun_var:Variable.t - -> Flambda.function_declaration - * Flambda.specialised_to Variable.Map.t) - -> set_of_closures:Flambda.set_of_closures - -> (Flambda.expr * Inlining_cost.Benefit.t) option -end diff --git a/middle_end/flambda/base_types/closure_element.ml b/middle_end/flambda/base_types/closure_element.ml deleted file mode 100644 index 561e0803962..00000000000 --- a/middle_end/flambda/base_types/closure_element.ml +++ /dev/null @@ -1,26 +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-66"] -open! Int_replace_polymorphic_compare - -include Variable - -let wrap t = t -let unwrap t = t - -let wrap_map t = t -let unwrap_set t = t diff --git a/middle_end/flambda/base_types/closure_element.mli b/middle_end/flambda/base_types/closure_element.mli deleted file mode 100644 index e5bee534151..00000000000 --- a/middle_end/flambda/base_types/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 - -val wrap : Variable.t -> t -val unwrap : t -> Variable.t - -val wrap_map : 'a Variable.Map.t -> 'a Map.t -val unwrap_set : Set.t -> Variable.Set.t - -val in_compilation_unit : t -> Compilation_unit.t -> bool -val get_compilation_unit : t -> Compilation_unit.t - -val debug_info : t -> Debuginfo.t option - -val unique_name : t -> string - -val output_full : out_channel -> t -> unit diff --git a/middle_end/flambda/base_types/closure_id.ml b/middle_end/flambda/base_types/closure_id.ml deleted file mode 100644 index 82cdac6cca1..00000000000 --- a/middle_end/flambda/base_types/closure_id.ml +++ /dev/null @@ -1,22 +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-66"] -open! Int_replace_polymorphic_compare - -include Closure_element - -let debug_info t = Option.get (debug_info t) diff --git a/middle_end/flambda/base_types/closure_id.mli b/middle_end/flambda/base_types/closure_id.mli deleted file mode 100644 index 19a2d708f6c..00000000000 --- a/middle_end/flambda/base_types/closure_id.mli +++ /dev/null @@ -1,29 +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-someday lwhite: "Closure_id" is quite a generic name. I wonder - whether something like "Closure_label" would better capture that it is - the label of a projection. *) - -(** An identifier, unique across the whole program (not just one compilation - unit), that identifies a closure within a particular set of closures - (viz. [Project_closure]). *) - -include module type of Closure_element - -val debug_info : t -> Debuginfo.t diff --git a/middle_end/flambda/base_types/closure_origin.ml b/middle_end/flambda/base_types/closure_origin.ml deleted file mode 100644 index 3fbdb3f4db5..00000000000 --- a/middle_end/flambda/base_types/closure_origin.ml +++ /dev/null @@ -1,23 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell, Leo White and Fu Yong Quah, Jane Street Europe *) -(* *) -(* Copyright 2013--2017 OCamlPro SAS *) -(* Copyright 2014--2017 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-66"] -open! Int_replace_polymorphic_compare - -include Closure_id - -let create t = t - diff --git a/middle_end/flambda/base_types/closure_origin.mli b/middle_end/flambda/base_types/closure_origin.mli deleted file mode 100644 index 531ac4556c9..00000000000 --- a/middle_end/flambda/base_types/closure_origin.mli +++ /dev/null @@ -1,23 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell, Leo White and Fu Yong Quah, Jane Street Europe *) -(* *) -(* Copyright 2013--2017 OCamlPro SAS *) -(* Copyright 2014--2017 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. *) -(* *) -(**************************************************************************) - -include Identifiable.S - -val create : Closure_id.t -> t - -val get_compilation_unit : t -> Compilation_unit.t - -val debug_info : t -> Debuginfo.t diff --git a/middle_end/flambda/base_types/export_id.ml b/middle_end/flambda/base_types/export_id.ml deleted file mode 100644 index 928e9033a12..00000000000 --- a/middle_end/flambda/base_types/export_id.ml +++ /dev/null @@ -1,29 +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-66"] -open! Int_replace_polymorphic_compare - -module Id : Id_types.Id = Id_types.Id () -module Unit_id = Id_types.UnitId (Id) (Compilation_unit) - -type t = Unit_id.t - -include Identifiable.Make (Unit_id) - -let create = Unit_id.create -let get_compilation_unit = Unit_id.unit -let name = Unit_id.name diff --git a/middle_end/flambda/base_types/export_id.mli b/middle_end/flambda/base_types/export_id.mli deleted file mode 100644 index 54c14418e49..00000000000 --- a/middle_end/flambda/base_types/export_id.mli +++ /dev/null @@ -1,28 +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"] - -(* Keys representing value descriptions that may be written into - intermediate files and loaded by a dependent compilation unit. - These keys are used to ensure maximal sharing of value descriptions, - which may be substantial. *) - -include Identifiable.S - -val create : ?name:string -> Compilation_unit.t -> t -val name : t -> string option -val get_compilation_unit : t -> Compilation_unit.t diff --git a/middle_end/flambda/base_types/id_types.ml b/middle_end/flambda/base_types/id_types.ml deleted file mode 100644 index c9a77adc38f..00000000000 --- a/middle_end/flambda/base_types/id_types.ml +++ /dev/null @@ -1,93 +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-66"] -open! Int_replace_polymorphic_compare - -module type BaseId = sig - type t - val equal : t -> t -> bool - val compare : t -> t -> int - val hash : t -> int - val name : t -> string option - val to_string : t -> string - val output : out_channel -> t -> unit - val print : Format.formatter -> t -> unit -end - -module type Id = sig - include BaseId - val create : ?name:string -> unit -> t -end - -module type UnitId = sig - module Compilation_unit : Identifiable.Thing - include BaseId - val create : ?name:string -> Compilation_unit.t -> t - val unit : t -> Compilation_unit.t -end - -module Id() : 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 equal (t1,_) (t2,_) = (t1:int) = t2 - let compare (t1,_) (t2,_) = t1 - t2 - let hash (t,_) = t - let name (_,name) = - if name == empty_string - then None - else Some name - let to_string (t,name) = - if name == empty_string - then Int.to_string t - else Printf.sprintf "%s_%i" name t - let output fd t = output_string fd (to_string t) - let print ppf v = Format.pp_print_string ppf (to_string v) -end - -module UnitId(Innerid:Id)(Compilation_unit:Identifiable.Thing) : - UnitId with module Compilation_unit := Compilation_unit = struct - type t = { - id : Innerid.t; - unit : Compilation_unit.t; - } - let compare x y = - let c = Innerid.compare x.id y.id in - if c <> 0 - then c - else Compilation_unit.compare x.unit y.unit - let output oc x = - Printf.fprintf oc "%a.%a" - Compilation_unit.output x.unit - Innerid.output x.id - let print ppf x = - Format.fprintf ppf "%a.%a" - Compilation_unit.print x.unit - Innerid.print x.id - let hash off = Hashtbl.hash off - let equal o1 o2 = compare o1 o2 = 0 - let name o = Innerid.name o.id - let to_string x = - Format.asprintf "%a.%a" - Compilation_unit.print x.unit - Innerid.print x.id - let create ?name unit = - let id = Innerid.create ?name () in - { id; unit } - let unit x = x.unit -end diff --git a/middle_end/flambda/base_types/id_types.mli b/middle_end/flambda/base_types/id_types.mli deleted file mode 100644 index 78ca75a8be2..00000000000 --- a/middle_end/flambda/base_types/id_types.mli +++ /dev/null @@ -1,54 +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-soon mshinwell: This module should be removed. *) - -(** Generic identifier type *) -module type BaseId = -sig - type t - val equal : t -> t -> bool - val compare : t -> t -> int - val hash : t -> int - val name : t -> string option - val to_string : t -> string - val output : out_channel -> t -> unit - val print : Format.formatter -> t -> unit -end - -module type Id = -sig - include BaseId - val create : ?name:string -> unit -> t -end - -(** Fully qualified identifiers *) -module type UnitId = -sig - module Compilation_unit : Identifiable.Thing - include BaseId - val create : ?name:string -> Compilation_unit.t -> t - val unit : t -> Compilation_unit.t -end - -module Id () : Id - -module UnitId : - Id -> - functor (Compilation_unit : Identifiable.Thing) -> - UnitId with module Compilation_unit := Compilation_unit diff --git a/middle_end/flambda/base_types/mutable_variable.ml b/middle_end/flambda/base_types/mutable_variable.ml deleted file mode 100644 index b6de464514f..00000000000 --- a/middle_end/flambda/base_types/mutable_variable.ml +++ /dev/null @@ -1,28 +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-66"] -open! Int_replace_polymorphic_compare - -include Variable - -let create ?current_compilation_unit names = create ?current_compilation_unit names - -let create_with_same_name_as_ident ident = create_with_same_name_as_ident ident - -let rename ?current_compilation_unit t = rename ?current_compilation_unit t - -let create_from_variable = rename diff --git a/middle_end/flambda/base_types/mutable_variable.mli b/middle_end/flambda/base_types/mutable_variable.mli deleted file mode 100644 index 17fe208fe07..00000000000 --- a/middle_end/flambda/base_types/mutable_variable.mli +++ /dev/null @@ -1,47 +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 - -val create - : ?current_compilation_unit:Compilation_unit.t - -> Internal_variable_names.t - -> t - -val create_with_same_name_as_ident : Ident.t -> t - -val create_from_variable - : ?current_compilation_unit:Compilation_unit.t - -> Variable.t - -> t - -val rename - : ?current_compilation_unit:Compilation_unit.t - -> t - -> t - -val in_compilation_unit : t -> Compilation_unit.t -> bool - -val name : t -> string - -val unique_name : t -> string - -val print_list : Format.formatter -> t list -> unit -val print_opt : Format.formatter -> t option -> unit - -val output_full : out_channel -> t -> unit diff --git a/middle_end/flambda/base_types/set_of_closures_id.ml b/middle_end/flambda/base_types/set_of_closures_id.ml deleted file mode 100644 index 928e9033a12..00000000000 --- a/middle_end/flambda/base_types/set_of_closures_id.ml +++ /dev/null @@ -1,29 +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-66"] -open! Int_replace_polymorphic_compare - -module Id : Id_types.Id = Id_types.Id () -module Unit_id = Id_types.UnitId (Id) (Compilation_unit) - -type t = Unit_id.t - -include Identifiable.Make (Unit_id) - -let create = Unit_id.create -let get_compilation_unit = Unit_id.unit -let name = Unit_id.name diff --git a/middle_end/flambda/base_types/set_of_closures_id.mli b/middle_end/flambda/base_types/set_of_closures_id.mli deleted file mode 100644 index 811cb66102f..00000000000 --- a/middle_end/flambda/base_types/set_of_closures_id.mli +++ /dev/null @@ -1,26 +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"] - -(** An identifier, unique across the whole program, that identifies a set - of closures (viz. [Set_of_closures]). *) - -include Identifiable.S - -val create : ?name:string -> Compilation_unit.t -> t -val name : t -> string option -val get_compilation_unit : t -> Compilation_unit.t diff --git a/middle_end/flambda/base_types/set_of_closures_origin.ml b/middle_end/flambda/base_types/set_of_closures_origin.ml deleted file mode 100644 index a5ef8c7c3da..00000000000 --- a/middle_end/flambda/base_types/set_of_closures_origin.ml +++ /dev/null @@ -1,23 +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-66"] -open! Int_replace_polymorphic_compare - -include Set_of_closures_id - -let create t = t -let rename f t = f t diff --git a/middle_end/flambda/base_types/set_of_closures_origin.mli b/middle_end/flambda/base_types/set_of_closures_origin.mli deleted file mode 100644 index 4c9cfdcf807..00000000000 --- a/middle_end/flambda/base_types/set_of_closures_origin.mli +++ /dev/null @@ -1,22 +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. *) -(* *) -(**************************************************************************) - -include Identifiable.S - -val create : Set_of_closures_id.t -> t - -val get_compilation_unit : t -> Compilation_unit.t -val rename : (Set_of_closures_id.t -> Set_of_closures_id.t) -> t -> t diff --git a/middle_end/flambda/base_types/static_exception.ml b/middle_end/flambda/base_types/static_exception.ml deleted file mode 100644 index 6cecae6328c..00000000000 --- a/middle_end/flambda/base_types/static_exception.ml +++ /dev/null @@ -1,23 +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-66"] -open! Int_replace_polymorphic_compare - -include Numbers.Int - -let create () = Lambda.next_raise_count () -let to_int t = t diff --git a/middle_end/flambda/base_types/static_exception.mli b/middle_end/flambda/base_types/static_exception.mli deleted file mode 100644 index 88f690aa103..00000000000 --- a/middle_end/flambda/base_types/static_exception.mli +++ /dev/null @@ -1,26 +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"] - -(** An identifier that is used to label static exceptions. Its - uniqueness properties are unspecified. *) - -include Identifiable.S - -val create : unit -> t - -val to_int : t -> int diff --git a/middle_end/flambda/base_types/tag.ml b/middle_end/flambda/base_types/tag.ml deleted file mode 100644 index cfa51ddbb24..00000000000 --- a/middle_end/flambda/base_types/tag.ml +++ /dev/null @@ -1,35 +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-66"] -open! Int_replace_polymorphic_compare - -type t = int - -include Identifiable.Make (Numbers.Int) - -let create_exn tag = - if tag < 0 || tag > 255 then - Misc.fatal_error (Printf.sprintf "Tag.create_exn %d" tag) - else - tag - -let to_int t = t - -let zero = 0 -let object_tag = Obj.object_tag - -let compare : t -> t -> int = Stdlib.compare diff --git a/middle_end/flambda/base_types/tag.mli b/middle_end/flambda/base_types/tag.mli deleted file mode 100644 index 12ce55255cd..00000000000 --- a/middle_end/flambda/base_types/tag.mli +++ /dev/null @@ -1,29 +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"] - -(** Tags on runtime boxed values. *) - -include Identifiable.S - -val create_exn : int -> t -val to_int : t -> int - -val zero : t -val object_tag : t - -val compare : t -> t -> int diff --git a/middle_end/flambda/base_types/var_within_closure.ml b/middle_end/flambda/base_types/var_within_closure.ml deleted file mode 100644 index 466f59a237d..00000000000 --- a/middle_end/flambda/base_types/var_within_closure.ml +++ /dev/null @@ -1,20 +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-66"] -open! Int_replace_polymorphic_compare - -include Closure_element diff --git a/middle_end/flambda/base_types/var_within_closure.mli b/middle_end/flambda/base_types/var_within_closure.mli deleted file mode 100644 index 56f0af0ad6f..00000000000 --- a/middle_end/flambda/base_types/var_within_closure.mli +++ /dev/null @@ -1,24 +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"] - -(** An identifier, unique across the whole program, that identifies a - particular variable within a particular closure. Only - [Project_var], and not [Var], nodes are tagged with these - identifiers. *) - -include module type of Closure_element diff --git a/middle_end/flambda/build_export_info.ml b/middle_end/flambda/build_export_info.ml deleted file mode 100644 index 53925a96b13..00000000000 --- a/middle_end/flambda/build_export_info.ml +++ /dev/null @@ -1,723 +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"] - -module Env : sig - type t - - val new_descr : t -> Export_info.descr -> Export_id.t - - val record_descr : t -> Export_id.t -> Export_info.descr -> unit - val new_value_closure_descr - : t - -> closure_id:Closure_id.t - -> set_of_closures: Export_info.value_set_of_closures - -> Export_id.t - - val get_descr : t -> Export_info.approx -> Export_info.descr option - - val add_approx : t -> Variable.t -> Export_info.approx -> t - val add_approx_maps : t -> Export_info.approx Variable.Map.t list -> t - val find_approx : t -> Variable.t -> Export_info.approx - - val get_symbol_descr : t -> Symbol.t -> Export_info.descr option - - val new_unit_descr : t -> Export_id.t - - val is_symbol_being_defined : t -> Symbol.t -> bool - - module Global : sig - (* "Global" as in "without local variable bindings". *) - type t - - val create_empty : unit -> t - - val add_symbol : t -> Symbol.t -> Export_id.t -> t - val new_symbol : t -> Symbol.t -> Export_id.t * t - - val symbol_to_export_id_map : t -> Export_id.t Symbol.Map.t - val export_id_to_descr_map : t -> Export_info.descr Export_id.Map.t - end - - (** Creates a new environment, sharing the mapping from export IDs to - export descriptions with the given global environment. *) - val empty_of_global : symbols_being_defined:Symbol.Set.t -> Global.t -> t -end = struct - let fresh_id () = Export_id.create (Compilation_unit.get_current_exn ()) - - module Global = struct - type t = - { sym : Export_id.t Symbol.Map.t; - (* Note that [ex_table]s themselves are shared (hence [ref] and not - [mutable]). *) - ex_table : Export_info.descr Export_id.Map.t ref; - closure_table : Export_id.t Closure_id.Map.t ref; - } - - let create_empty () = - { sym = Symbol.Map.empty; - ex_table = ref Export_id.Map.empty; - closure_table = ref Closure_id.Map.empty; - } - - let add_symbol t sym export_id = - if Symbol.Map.mem sym t.sym then begin - Misc.fatal_errorf "Build_export_info.Env.Global.add_symbol: cannot \ - rebind symbol %a in environment" - Symbol.print sym - end; - { t with sym = Symbol.Map.add sym export_id t.sym } - - let new_symbol t sym = - let export_id = fresh_id () in - export_id, add_symbol t sym export_id - - let symbol_to_export_id_map t = t.sym - let export_id_to_descr_map t = !(t.ex_table) - end - - (* CR-someday mshinwell: The half-mutable nature of [t] with sharing of - the [ex_table] is kind of nasty. Consider making it immutable. *) - type t = - { var : Export_info.approx Variable.Map.t; - sym : Export_id.t Symbol.Map.t; - symbols_being_defined : Symbol.Set.t; - ex_table : Export_info.descr Export_id.Map.t ref; - closure_table: Export_id.t Closure_id.Map.t ref; - } - - let empty_of_global ~symbols_being_defined (env : Global.t) = - { var = Variable.Map.empty; - sym = env.sym; - symbols_being_defined; - ex_table = env.ex_table; - closure_table = env.closure_table; - } - - let extern_id_descr export_id = - let export = Compilenv.approx_env () in - try Some (Export_info.find_description export export_id) - with Not_found -> None - - let extern_symbol_descr sym = - if Symbol.is_predef_exn sym - then None - else - match - Compilenv.approx_for_global (Symbol.compilation_unit sym) - with - | None -> None - | Some export -> - try - let id = Symbol.Map.find sym export.symbol_id in - let descr = Export_info.find_description export id in - Some descr - with - | Not_found -> None - - let get_id_descr t export_id = - try Some (Export_id.Map.find export_id !(t.ex_table)) - with Not_found -> extern_id_descr export_id - - let get_symbol_descr t sym = - try - let export_id = Symbol.Map.find sym t.sym in - Some (Export_id.Map.find export_id !(t.ex_table)) - with - | Not_found -> extern_symbol_descr sym - - let get_descr t (approx : Export_info.approx) = - match approx with - | Value_unknown -> None - | Value_id export_id -> get_id_descr t export_id - | Value_symbol sym -> get_symbol_descr t sym - - let record_descr t id (descr : Export_info.descr) = - if Export_id.Map.mem id !(t.ex_table) then begin - Misc.fatal_errorf "Build_export_info.Env.record_descr: cannot rebind \ - export ID %a in environment" - Export_id.print id - end; - t.ex_table := Export_id.Map.add id descr !(t.ex_table) - - let new_descr t (descr : Export_info.descr) = - let id = fresh_id () in - record_descr t id descr; - id - - let new_value_closure_descr t ~closure_id ~set_of_closures = - match Closure_id.Map.find closure_id !(t.closure_table) with - | exception Not_found -> - let export_id = - new_descr t (Value_closure { closure_id; set_of_closures }) - in - t.closure_table := - Closure_id.Map.add closure_id export_id !(t.closure_table); - export_id - | export_id -> export_id - - let new_unit_descr t = - new_descr t (Value_int 0) - - let add_approx t var approx = - if Variable.Map.mem var t.var then begin - Misc.fatal_errorf "Build_export_info.Env.add_approx: cannot rebind \ - variable %a in environment" - Variable.print var - end; - { t with var = Variable.Map.add var approx t.var; } - - let add_approx_map t vars_to_approxs = - Variable.Map.fold (fun var approx t -> add_approx t var approx) - vars_to_approxs - t - - let add_approx_maps t vars_to_approxs_list = - List.fold_left add_approx_map t vars_to_approxs_list - - let find_approx t var : Export_info.approx = - try Variable.Map.find var t.var with - | Not_found -> Value_unknown - - let is_symbol_being_defined t sym = - Symbol.Set.mem sym t.symbols_being_defined -end - -let descr_of_constant (c : Flambda.const) : Export_info.descr = - match c with - | Int i -> Value_int i - | Char c -> Value_char c - -let descr_of_allocated_constant (c : Allocated_const.t) : Export_info.descr = - match c with - | Float f -> Value_float f - | Int32 i -> Value_boxed_int (Int32, i) - | Int64 i -> Value_boxed_int (Int64, i) - | Nativeint i -> Value_boxed_int (Nativeint, i) - | String s -> - let v_string : Export_info.value_string = - { size = String.length s; contents = Unknown_or_mutable; } - in - Value_string v_string - | Immutable_string s -> - let v_string : Export_info.value_string = - { size = String.length s; contents = Contents s; } - in - Value_string v_string - | Immutable_float_array fs -> - Value_float_array { - contents = Contents (Array.map (fun x -> Some x) (Array.of_list fs)); - size = List.length fs; - } - | Float_array fs -> - Value_float_array { - contents = Unknown_or_mutable; - size = List.length fs; - } - -let rec approx_of_expr (env : Env.t) (flam : Flambda.t) : Export_info.approx = - match flam with - | Var var -> Env.find_approx env var - | Let { var; defining_expr; body; _ } -> - let approx = descr_of_named env defining_expr in - let env = Env.add_approx env var approx in - approx_of_expr env body - | Let_mutable { body } -> - approx_of_expr env body - | Let_rec (defs, body) -> - let env = - List.fold_left (fun env (var, defining_expr) -> - let approx = descr_of_named env defining_expr in - Env.add_approx env var approx) - env defs - in - approx_of_expr env body - | Apply { func; kind; _ } -> - begin match kind with - | Indirect -> Value_unknown - | Direct closure_id' -> - match Env.get_descr env (Env.find_approx env func) with - | Some (Value_closure - { closure_id; set_of_closures = { results; _ }; }) -> - assert (Closure_id.equal closure_id closure_id'); - assert (Closure_id.Map.mem closure_id results); - Closure_id.Map.find closure_id results - | _ -> Value_unknown - end - | Region body -> - approx_of_expr env body - | Exclave body -> - approx_of_expr env body - | Assign _ -> Value_id (Env.new_unit_descr env) - | For _ -> Value_id (Env.new_unit_descr env) - | While _ -> Value_id (Env.new_unit_descr env) - | Static_raise _ | Static_catch _ | Try_with _ | If_then_else _ - | Switch _ | String_switch _ | Send _ | Proved_unreachable -> - Value_unknown - -and descr_of_named (env : Env.t) (named : Flambda.named) - : Export_info.approx = - match named with - | Expr expr -> approx_of_expr env expr - | Symbol sym -> Value_symbol sym - | Read_mutable _ -> Value_unknown - | Read_symbol_field (sym, i) -> - begin match Env.get_symbol_descr env sym with - | Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i) - | _ -> Value_unknown - end - | Const const -> - Value_id (Env.new_descr env (descr_of_constant const)) - | Allocated_const const -> - Value_id (Env.new_descr env (descr_of_allocated_constant const)) - | Prim (Pmakeblock (tag, Immutable, _value_kind, _mode), args, _dbg) -> - let approxs = List.map (Env.find_approx env) args in - let descr : Export_info.descr = - Value_block (Tag.create_exn tag, Array.of_list approxs) - in - Value_id (Env.new_descr env descr) - | Prim (Pfield (i, _, _, _), [arg], _) -> - begin match Env.get_descr env (Env.find_approx env arg) with - | Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i) - | _ -> Value_unknown - end - | Prim _ -> Value_unknown - | Set_of_closures set -> - let descr : Export_info.descr = - Value_set_of_closures (describe_set_of_closures env set) - in - Value_id (Env.new_descr env descr) - | Project_closure { set_of_closures; closure_id; } -> - begin match Env.get_descr env (Env.find_approx env set_of_closures) with - | Some (Value_set_of_closures set_of_closures) -> - if not (Closure_id.Map.mem closure_id set_of_closures.results) then begin - Misc.fatal_errorf "Could not build export description for \ - [Project_closure]: closure ID %a not in set of closures" - Closure_id.print closure_id - end; - Value_id ( - Env.new_value_closure_descr env ~closure_id ~set_of_closures - ) - | _ -> - (* It would be nice if this were [assert false], but owing to the fact - that this pass may propagate less information than for example - [Inline_and_simplify], we might end up here. *) - Value_unknown - end - | Move_within_set_of_closures { closure; start_from; move_to; } -> - begin match Env.get_descr env (Env.find_approx env closure) with - | Some (Value_closure { set_of_closures; closure_id; }) -> - assert (Closure_id.equal closure_id start_from); - Value_id ( - Env.new_value_closure_descr env ~closure_id:move_to ~set_of_closures - ) - | _ -> Value_unknown - end - | Project_var { closure; closure_id = closure_id'; var; } -> - begin match Env.get_descr env (Env.find_approx env closure) with - | Some (Value_closure - { set_of_closures = { bound_vars; _ }; closure_id; }) -> - assert (Closure_id.equal closure_id closure_id'); - if not (Var_within_closure.Map.mem var bound_vars) then begin - Misc.fatal_errorf "Project_var from %a (closure ID %a) of \ - variable %a that is not bound by the closure. \ - Variables bound by the closure are: %a" - Variable.print closure - Closure_id.print closure_id - Var_within_closure.print var - (Var_within_closure.Map.print (fun _ _ -> ())) bound_vars - end; - Var_within_closure.Map.find var bound_vars - | _ -> Value_unknown - end - -and describe_set_of_closures env (set : Flambda.set_of_closures) - : Export_info.value_set_of_closures = - let bound_vars_approx = - Variable.Map.map (fun (external_var : Flambda.specialised_to) -> - Env.find_approx env external_var.var) - set.free_vars - in - let specialised_args_approx = - Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - Env.find_approx env spec_to.var) - set.specialised_args - in - let closures_approx = - (* To build an approximation of the results, we need an - approximation of the functions. The first one we can build is - one where every function returns something unknown. - *) - (* CR-someday pchambart: we could improve a bit on that by building a - recursive approximation of the closures: The value_closure - description contains a [value_set_of_closures]. We could replace - this field by a [Expr_id.t] or an [approx]. - mshinwell: Deferred for now. - *) - let initial_value_set_of_closures = - { Export_info. - set_of_closures_id = set.function_decls.set_of_closures_id; - bound_vars = Var_within_closure.wrap_map bound_vars_approx; - free_vars = set.free_vars; - results = - Closure_id.wrap_map - (Variable.Map.map (fun _ -> Export_info.Value_unknown) - set.function_decls.funs); - aliased_symbol = None; - } - in - Variable.Map.mapi (fun fun_var _function_decl -> - let export_id = - let closure_id = Closure_id.wrap fun_var in - let set_of_closures = initial_value_set_of_closures in - Env.new_value_closure_descr env ~closure_id ~set_of_closures - in - Export_info.Value_id export_id) - set.function_decls.funs - in - let closure_env = - Env.add_approx_maps env - [closures_approx; bound_vars_approx; specialised_args_approx] - in - let results = - let result_approx _var (function_decl : Flambda.function_declaration) = - approx_of_expr closure_env function_decl.body - in - Variable.Map.mapi result_approx set.function_decls.funs - in - { set_of_closures_id = set.function_decls.set_of_closures_id; - bound_vars = Var_within_closure.wrap_map bound_vars_approx; - free_vars = set.free_vars; - results = Closure_id.wrap_map results; - aliased_symbol = None; - } - -let approx_of_constant_defining_value_block_field env - (c : Flambda.constant_defining_value_block_field) : Export_info.approx = - match c with - | Symbol s -> - if Env.is_symbol_being_defined env s - then Value_unknown - else Value_symbol s - | Const c -> Value_id (Env.new_descr env (descr_of_constant c)) - -let describe_constant_defining_value env export_id symbol - ~symbols_being_defined (const : Flambda.constant_defining_value) = - let env = - (* Assignments of variables to export IDs are local to each constant - defining value. *) - Env.empty_of_global ~symbols_being_defined env - in - match const with - | Allocated_const alloc_const -> - let descr = descr_of_allocated_constant alloc_const in - Env.record_descr env export_id descr - | Block (tag, fields) -> - let approxs = - List.map (approx_of_constant_defining_value_block_field env) fields - in - Env.record_descr env export_id (Value_block (tag, Array.of_list approxs)) - | Set_of_closures set_of_closures -> - let descr : Export_info.descr = - Value_set_of_closures - { (describe_set_of_closures env set_of_closures) with - aliased_symbol = Some symbol; - } - in - Env.record_descr env export_id descr - | Project_closure (sym, closure_id) -> - begin match Env.get_symbol_descr env sym with - | Some (Value_set_of_closures set_of_closures) -> - if not (Closure_id.Map.mem closure_id set_of_closures.results) then begin - Misc.fatal_errorf "Could not build export description for \ - [Project_closure] constant defining value: closure ID %a not in \ - set of closures" - Closure_id.print closure_id - end; - let descr = - Export_info.Value_closure - { closure_id = closure_id; set_of_closures; } - in - Env.record_descr env export_id descr - | None -> - Misc.fatal_errorf - "Cannot project symbol %a to closure_id %a. \ - No available export description@." - Symbol.print sym - Closure_id.print closure_id - | Some (Value_closure _) -> - Misc.fatal_errorf - "Cannot project symbol %a to closure_id %a. \ - The symbol is a closure instead of a set of closures.@." - Symbol.print sym - Closure_id.print closure_id - | Some _ -> - Misc.fatal_errorf - "Cannot project symbol %a to closure_id %a. \ - The symbol is not a set of closures.@." - Symbol.print sym - Closure_id.print closure_id - end - -let describe_program (env : Env.Global.t) (program : Flambda.program) = - let rec loop env (program : Flambda.program_body) = - match program with - | Let_symbol (symbol, constant_defining_value, program) -> - let id, env = Env.Global.new_symbol env symbol in - describe_constant_defining_value env id symbol - ~symbols_being_defined:(Symbol.Set.singleton symbol) - constant_defining_value; - loop env program - | Let_rec_symbol (defs, program) -> - let env, defs = - List.fold_left (fun (env, defs) (symbol, def) -> - let id, env = Env.Global.new_symbol env symbol in - env, ((id, symbol, def) :: defs)) - (env, []) defs - in - (* [Project_closure]s are separated to be handled last. They are the - only values that need a description for their argument. *) - let project_closures, other_constants = - List.partition (function - | _, _, Flambda.Project_closure _ -> true - | _ -> false) - defs - in - let symbols_being_defined = - Symbol.Set.of_list (List.map (fun (_, sym, _) -> sym) defs) - in - List.iter (fun (id, symbol, def) -> - describe_constant_defining_value env id symbol - ~symbols_being_defined def) - other_constants; - List.iter (fun (id, symbol, def) -> - describe_constant_defining_value env id symbol - ~symbols_being_defined def) - project_closures; - loop env program - | Initialize_symbol (symbol, tag, fields, program) -> - let id = - let env = - (* Assignments of variables to export IDs are local to each - [Initialize_symbol] construction. *) - Env.empty_of_global - ~symbols_being_defined:(Symbol.Set.singleton symbol) env - in - let field_approxs = List.map (approx_of_expr env) fields in - let descr : Export_info.descr = - Value_block (tag, Array.of_list field_approxs) - in - Env.new_descr env descr - in - let env = Env.Global.add_symbol env symbol id in - loop env program - | Effect (_expr, program) -> loop env program - | End symbol -> symbol, env - in - loop env program.program_body - - -let build_transient (program : Flambda.program) : Export_info.transient = - if !Clflags.opaque then - let compilation_unit = Compilation_unit.get_current_exn () in - let root_symbol = Symbol.for_current_unit () in - Export_info.opaque_transient ~root_symbol ~compilation_unit - else - (* CR-soon pchambart: Should probably use that instead of the ident of - the module as global identifier. - mshinwell: Is "that" the variable "_global_symbol"? - Yes it is. We are just assuming that the symbol produced from - the identifier of the module is the right one. *) - let _global_symbol, env = - describe_program (Env.Global.create_empty ()) program - in - let sets_of_closures_map = - Flambda_utils.all_sets_of_closures_map program - in - let function_declarations_map = - let set_of_closures_approx { Flambda. function_decls; _ } = - let recursive = - lazy - (Find_recursive_functions.in_function_declarations function_decls) - in - let keep_body = - Inline_and_simplify_aux.keep_body_check - ~is_classic_mode:function_decls.is_classic_mode ~recursive - in - Simple_value_approx.function_declarations_approx - ~keep_body function_decls - in - Set_of_closures_id.Map.map set_of_closures_approx sets_of_closures_map - in - let unnested_values = - Env.Global.export_id_to_descr_map env - in - let invariant_params = - let invariant_params = - Set_of_closures_id.Map.map - (fun { Flambda. function_decls; _ } -> - if function_decls.is_classic_mode then begin - Variable.Map.empty - end else begin - Invariant_params.invariant_params_in_recursion function_decls - end) - (Flambda_utils.all_sets_of_closures_map program) - in - let export = Compilenv.approx_env () in - Export_id.Map.fold - (fun _eid (descr:Export_info.descr) invariant_params -> - match (descr : Export_info.descr) with - | Value_closure { set_of_closures } - | Value_set_of_closures set_of_closures -> - let { Export_info.set_of_closures_id } = set_of_closures in - begin match - Set_of_closures_id.Map.find set_of_closures_id - export.invariant_params - with - | exception Not_found -> - invariant_params - | (set : Variable.Set.t Variable.Map.t) -> - Set_of_closures_id.Map.add - set_of_closures_id set invariant_params - end - | Export_info.Value_boxed_int (_, _) - | Value_block _ - | Value_mutable_block _ - | Value_int _ - | Value_char _ - | Value_float _ - | Value_float_array _ - | Value_string _ - | Value_unknown_descr -> - invariant_params) - unnested_values invariant_params - in - let recursive = - let recursive = - Set_of_closures_id.Map.map - (fun { Flambda. function_decls; _ } -> - if function_decls.is_classic_mode then begin - Variable.Set.empty - end else begin - Find_recursive_functions.in_function_declarations function_decls - end) - (Flambda_utils.all_sets_of_closures_map program) - in - let export = Compilenv.approx_env () in - Export_id.Map.fold - (fun _eid (descr:Export_info.descr) recursive -> - match (descr : Export_info.descr) with - | Value_closure { set_of_closures } - | Value_set_of_closures set_of_closures -> - let { Export_info.set_of_closures_id } = set_of_closures in - begin match - Set_of_closures_id.Map.find set_of_closures_id - export.recursive - with - | exception Not_found -> - recursive - | (set : Variable.Set.t) -> - Set_of_closures_id.Map.add - set_of_closures_id set recursive - end - | Export_info.Value_boxed_int (_, _) - | Value_block _ - | Value_mutable_block _ - | Value_int _ - | Value_char _ - | Value_float _ - | Value_float_array _ - | Value_string _ - | Value_unknown_descr -> - recursive) - unnested_values recursive - in - let values = Export_info.nest_eid_map unnested_values in - let symbol_id = Env.Global.symbol_to_export_id_map env in - let { Traverse_for_exported_symbols. - set_of_closure_ids = relevant_set_of_closures; - symbols = relevant_symbols; - export_ids = relevant_export_ids; - set_of_closure_ids_keep_declaration = - relevant_set_of_closures_declaration_only; - relevant_local_closure_ids; - relevant_imported_closure_ids; - relevant_local_vars_within_closure; - relevant_imported_vars_within_closure; - } = - let closure_id_to_set_of_closures_id = - Set_of_closures_id.Map.fold - (fun set_of_closure_id - (function_declarations : Simple_value_approx.function_declarations) - acc -> - Variable.Map.fold - (fun fun_var _ acc -> - let closure_id = Closure_id.wrap fun_var in - Closure_id.Map.add closure_id set_of_closure_id acc) - function_declarations.funs - acc) - function_declarations_map - Closure_id.Map.empty - in - Traverse_for_exported_symbols.traverse - ~sets_of_closures_map - ~closure_id_to_set_of_closures_id - ~function_declarations_map - ~values:(Compilation_unit.Map.find - (Compilation_unit.get_current_exn ()) values) - ~symbol_id - ~root_symbol:(Symbol.for_current_unit ()) - in - let sets_of_closures = - function_declarations_map |> Set_of_closures_id.Map.filter_map - (fun key (fun_decls : Simple_value_approx.function_declarations) -> - if Set_of_closures_id.Set.mem key relevant_set_of_closures then - Some fun_decls - else if begin - Set_of_closures_id.Set.mem key - relevant_set_of_closures_declaration_only - end then begin - if fun_decls.is_classic_mode then - Some (Simple_value_approx.clear_function_bodies fun_decls) - else - Some fun_decls - end else begin - None - end) - in - - let values = - Compilation_unit.Map.map (fun map -> - Export_id.Map.filter (fun key _ -> - Export_id.Set.mem key relevant_export_ids) - map) - values - in - let symbol_id = - Symbol.Map.filter - (fun key _ -> Symbol.Set.mem key relevant_symbols) - symbol_id - in - Export_info.create_transient ~values - ~symbol_id - ~sets_of_closures - ~invariant_params - ~recursive - ~relevant_local_closure_ids - ~relevant_imported_closure_ids - ~relevant_local_vars_within_closure - ~relevant_imported_vars_within_closure diff --git a/middle_end/flambda/build_export_info.mli b/middle_end/flambda/build_export_info.mli deleted file mode 100644 index da35bf05c64..00000000000 --- a/middle_end/flambda/build_export_info.mli +++ /dev/null @@ -1,24 +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"] - -(** Construct export information, for emission into .cmx files, from an - Flambda program. *) - -val build_transient : - Flambda.program -> - Export_info.transient diff --git a/middle_end/flambda/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml deleted file mode 100644 index 178e9599bd6..00000000000 --- a/middle_end/flambda/closure_conversion.ml +++ /dev/null @@ -1,781 +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-66-69"] -open! Int_replace_polymorphic_compare - -module Env = Closure_conversion_aux.Env -module Function_decls = Closure_conversion_aux.Function_decls -module Function_decl = Function_decls.Function_decl -module Names = Internal_variable_names - -let name_expr = Flambda_utils.name_expr -let name_expr_from_var = Flambda_utils.name_expr_from_var - -type t = { - current_unit : Compilation_unit.t; - filename : string; - backend : (module Backend_intf.S); - mutable imported_symbols : Symbol.Set.t; - mutable declared_symbols : (Symbol.t * Flambda.constant_defining_value) list; -} - -let add_default_argument_wrappers lam = - let defs_are_all_functions (defs : (_ * Lambda.lambda) list) = - List.for_all (function (_, Lambda.Lfunction _) -> true | _ -> false) defs - in - let f (lam : Lambda.lambda) : Lambda.lambda = - match lam with - | Llet (( Strict | Alias | StrictOpt), _k, id, - Lfunction {kind; params; body = fbody; attr; loc; - ret_mode; mode; region; return }, body) -> - begin match - Simplif.split_default_wrapper ~id ~kind ~params - ~body:fbody ~return ~attr ~loc ~ret_mode ~mode ~region - with - | [fun_id, def] -> Llet (Alias, Lambda.layout_function, fun_id, def, body) - | [fun_id, def; inner_fun_id, def_inner] -> - Llet (Alias, Lambda.layout_function, inner_fun_id, def_inner, - Llet (Alias, Lambda.layout_function, fun_id, def, body)) - | _ -> assert false - end - | Lletrec (defs, body) as lam -> - if defs_are_all_functions defs then - let defs = - List.flatten - (List.map - (function - | (id, Lambda.Lfunction {kind; params; body; attr; loc; - ret_mode; mode; region; return }) -> - Simplif.split_default_wrapper ~id ~kind ~params ~body - ~return ~attr ~loc ~ret_mode ~mode ~region - | _ -> assert false) - defs) - in - Lletrec (defs, body) - else lam - | lam -> lam - in - Lambda.map f lam - -(** Generate a wrapper ("stub") function that accepts a tuple argument and - calls another function with arguments extracted in the obvious - manner from the tuple. *) -let tupled_function_call_stub original_params unboxed_version ~closure_bound_var ~region ~return_layout - : Flambda.function_declaration = - let tuple_param_var = Variable.rename unboxed_version in - let params = List.map (fun p -> Variable.rename p) original_params in - let call : Flambda.t = - Apply ({ - func = unboxed_version; - args = params; - result_layout = return_layout; - (* CR-someday mshinwell for mshinwell: investigate if there is some - redundancy here (func is also unboxed_version) *) - kind = Direct (Closure_id.wrap unboxed_version); - dbg = Debuginfo.none; - reg_close = Rc_normal; - mode = if region then Lambda.alloc_heap else Lambda.alloc_local; - inlined = Default_inlined; - specialise = Default_specialise; - probe = None; - }) - in - let _, body = - List.fold_left (fun (pos, body) param -> - let lam : Flambda.named = - Prim (Pfield (pos, Pvalue Pgenval, Pointer, Immutable), - [tuple_param_var], Debuginfo.none) - in - pos + 1, Flambda.create_let param lam body) - (0, call) params - in - (* Tupled functions are always Alloc_heap. See translcore.ml *) - let alloc_mode = Lambda.alloc_heap in - let tuple_param = Parameter.wrap tuple_param_var alloc_mode Lambda.layout_block in - Flambda.create_function_declaration ~params:[tuple_param] ~alloc_mode ~region - ~body ~stub:true ~inline:Default_inline ~return_layout - ~specialise:Default_specialise ~check:Default_check ~is_a_functor:false - ~closure_origin:(Closure_origin.create (Closure_id.wrap closure_bound_var)) - ~poll:Default_poll (* don't propogate attribute to wrappers *) - -let register_const t (constant:Flambda.constant_defining_value) name - : Flambda.constant_defining_value_block_field * Internal_variable_names.t = - let var = Variable.create name in - let symbol = Symbol_utils.Flambda.for_variable var in - t.declared_symbols <- (symbol, constant) :: t.declared_symbols; - Symbol symbol, name - -let rec declare_const t (const : Lambda.structured_constant) - : Flambda.constant_defining_value_block_field * Internal_variable_names.t = - match const with - | Const_base (Const_int c) -> (Const (Int c), Names.const_int) - | Const_base (Const_char c) -> (Const (Char c), Names.const_char) - | Const_base (Const_unboxed_float _) -> - (* CR alanechang: implement unboxed float constants in flambda *) - Misc.fatal_error "Unboxed float constants are not supported in flambda. Consider using flambda2." - | Const_base (Const_string (s, _, _)) -> - let const, name = - (Flambda.Allocated_const (Immutable_string s), - Names.const_immstring) - in - register_const t const name - | Const_base (Const_float c) -> - register_const t - (Allocated_const (Float (float_of_string c))) - Names.const_float - | Const_base (Const_int32 c) -> - register_const t (Allocated_const (Int32 c)) - Names.const_int32 - | Const_base (Const_int64 c) -> - register_const t (Allocated_const (Int64 c)) - Names.const_int64 - | Const_base (Const_nativeint c) -> - register_const t (Allocated_const (Nativeint c)) Names.const_nativeint - | Const_immstring c -> - register_const t (Allocated_const (Immutable_string c)) - Names.const_immstring - | Const_float_array c | Const_float_block c -> - register_const t - (Allocated_const (Immutable_float_array (List.map float_of_string c))) - Names.const_float_array - | Const_block (tag, consts) -> - let const : Flambda.constant_defining_value = - Block (Tag.create_exn tag, - List.map (fun c -> fst (declare_const t c)) consts) - in - register_const t const Names.const_block - -let close_const t (const : Lambda.structured_constant) - : Flambda.named * Internal_variable_names.t = - match declare_const t const with - | Const c, name -> - Const c, name - | Symbol s, name -> - Symbol s, name - -let lambda_const_bool b : Lambda.structured_constant = - if b then - Lambda.const_int 1 - else - Lambda.const_int 0 - -let lambda_const_int i : Lambda.structured_constant = - Const_base (Const_int i) - -let rec close t env (lam : Lambda.lambda) : Flambda.t = - match lam with - | Lvar id -> - begin match Env.find_var_exn env id with - | var, _kind -> Var var - | exception Not_found -> - Misc.fatal_errorf "Closure_conversion.close: unbound identifier %a" - Ident.print id - end - | Lmutvar id -> - begin match Env.find_mutable_var_exn env id with - | mut_var, _kind -> - name_expr (Read_mutable mut_var) ~name:Names.read_mutable - | exception Not_found -> - Misc.fatal_errorf - "Closure_conversion.close: unbound mutable identifier %a" - Ident.print id - end - | Lconst cst -> - let cst, name = close_const t cst in - name_expr cst ~name - | Llet ((Strict | Alias | StrictOpt), layout, id, defining_expr, body) -> - let var = Variable.create_with_same_name_as_ident id in - let defining_expr = - close_let_bound_expression t var env defining_expr - in - let body = close t (Env.add_var env id var layout) body in - Flambda.create_let var defining_expr body - | Lmutlet (block_kind, id, defining_expr, body) -> - let mut_var = Mutable_variable.create_with_same_name_as_ident id in - let var = Variable.create_with_same_name_as_ident id in - let defining_expr = - close_let_bound_expression t var env defining_expr - in - let body = close t (Env.add_mutable_var env id mut_var block_kind) body in - Flambda.create_let var defining_expr - (Let_mutable - { var = mut_var; - initial_value = var; - body; - contents_kind = block_kind }) - | Lfunction { kind; params; body; attr; loc; mode; region; return } -> - let name = Names.anon_fn_with_loc loc in - let closure_bound_var = - let debug_info = Debuginfo.from_location loc in - Variable.create ~debug_info name - in - (* CR-soon mshinwell: some of this is now very similar to the let rec case - below *) - let set_of_closures_var = Variable.create Names.set_of_closures in - let params = List.map (fun (p : Lambda.lparam) -> let No_attributes = p.attributes in (p.name, p.layout)) params in - let set_of_closures = - let decl = - Function_decl.create ~let_rec_ident:None ~closure_bound_var ~kind ~mode - ~region ~params ~body ~attr ~loc ~return_layout:return - in - close_functions t env (Function_decls.create [decl]) - in - let project_closure : Flambda.project_closure = - { set_of_closures = set_of_closures_var; - closure_id = Closure_id.wrap closure_bound_var; - } - in - Flambda.create_let set_of_closures_var set_of_closures - (name_expr (Project_closure (project_closure)) ~name) - | Lapply { ap_func; ap_args; ap_loc; ap_region_close; ap_mode; ap_result_layout; - ap_tailcall = _; ap_inlined; ap_specialised; ap_probe; } -> - Lift_code.lifting_helper (close_list t env ap_args) - ~evaluation_order:`Right_to_left - ~name:Names.apply_arg - ~create_body:(fun args -> - let func = close t env ap_func in - let func_var = Variable.create Names.apply_funct in - Flambda.create_let func_var (Expr func) - (Apply ({ - func = func_var; - args; - result_layout = ap_result_layout; - kind = Indirect; - dbg = Debuginfo.from_location ap_loc; - reg_close = ap_region_close; - mode = ap_mode; - inlined = ap_inlined; - specialise = ap_specialised; - probe = ap_probe; - }))) - - | Lletrec (defs, body) -> - let env = - List.fold_right (fun (id, _) env -> - Env.add_var env id (Variable.create_with_same_name_as_ident id) - Lambda.layout_letrec) - defs env - in - let function_declarations = - (* Identify any bindings in the [let rec] that are functions. These - will be named after the corresponding identifier in the [let rec]. *) - List.map (function - | (let_rec_ident, - Lambda.Lfunction { kind; params; return; body; attr; loc; mode; region }) -> - let closure_bound_var = - let debug_info = Debuginfo.from_location loc in - Variable.create_with_same_name_as_ident ~debug_info let_rec_ident - in - let params = List.map (fun (p : Lambda.lparam) -> let No_attributes = p.attributes in (p.name, p.layout)) params in - let function_declaration = - Function_decl.create ~let_rec_ident:(Some let_rec_ident) - ~closure_bound_var ~kind ~mode ~region - ~params ~body ~attr ~loc ~return_layout:return - in - Some function_declaration - | _ -> None) - defs - in - begin match - Misc.Stdlib.List.some_if_all_elements_are_some function_declarations - with - | Some function_declarations -> - (* When all the bindings are (syntactically) functions, we can - eliminate the [let rec] construction, instead producing a normal - [Let] that binds a set of closures containing all of the functions. - *) - (* CR-someday lwhite: This is a very syntactic criteria. Adding an - unused value to a set of recursive bindings changes how - functions are represented at runtime. *) - let set_of_closures_var = Variable.create (Names.set_of_closures) in - let set_of_closures = - close_functions t env (Function_decls.create function_declarations) - in - let body = - List.fold_left (fun body decl -> - let let_rec_ident = Function_decl.let_rec_ident decl in - let closure_bound_var = Function_decl.closure_bound_var decl in - let let_bound_var, _kind = Env.find_var env let_rec_ident in - (* Inside the body of the [let], each function is referred to by - a [Project_closure] expression, which projects from the set of - closures. *) - (Flambda.create_let let_bound_var - (Project_closure { - set_of_closures = set_of_closures_var; - closure_id = Closure_id.wrap closure_bound_var; - }) - body)) - (close t env body) function_declarations - in - Flambda.create_let set_of_closures_var set_of_closures body - | None -> - (* If the condition above is not satisfied, we build a [Let_rec] - expression; any functions bound by it will have their own - individual closures. *) - let defs = - List.map (fun (id, def) -> - let var, _kind = Env.find_var env id in - var, close_let_bound_expression t ~let_rec_ident:id var env def) - defs - in - Let_rec (defs, close t env body) - end - | Lsend (kind, meth, obj, args, reg_close, mode, loc, result_layout) -> - let meth_var = Variable.create Names.meth in - let obj_var = Variable.create Names.obj in - let dbg = Debuginfo.from_location loc in - Flambda.create_let meth_var (Expr (close t env meth)) - (Flambda.create_let obj_var (Expr (close t env obj)) - (Lift_code.lifting_helper (close_list t env args) - ~evaluation_order:`Right_to_left - ~name:Names.send_arg - ~create_body:(fun args -> - Send { kind; meth = meth_var; obj = obj_var; args; - dbg; reg_close; mode; result_layout }))) - | Lprim ((Pdivint Safe | Pmodint Safe - | Pdivbint { is_safe = Safe } | Pmodbint { is_safe = Safe }) as prim, - [arg1; arg2], loc) - when not !Clflags.unsafe -> - let arg2 = close t env arg2 in - let arg1 = close t env arg1 in - let numerator = Variable.create Names.numerator in - let denominator = Variable.create Names.denominator in - let zero = Variable.create Names.zero in - let is_zero = Variable.create Names.is_zero in - let exn = Variable.create Names.division_by_zero in - let exn_symbol = Symbol.for_predef_ident Predef.ident_division_by_zero in - let dbg = Debuginfo.from_location loc in - let zero_const : Flambda.named = - match prim with - | Pdivint _ | Pmodint _ -> - Const (Int 0) - | Pdivbint { size = Pint32 } | Pmodbint { size = Pint32 } -> - Allocated_const (Int32 0l) - | Pdivbint { size = Pint64 } | Pmodbint { size = Pint64 } -> - Allocated_const (Int64 0L) - | Pdivbint { size = Pnativeint } | Pmodbint { size = Pnativeint } -> - Allocated_const (Nativeint 0n) - | _ -> assert false - in - let prim : Clambda_primitives.primitive = - match prim with - | Pdivint _ -> Pdivint Unsafe - | Pmodint _ -> Pmodint Unsafe - | Pdivbint { size; mode } -> Pdivbint { size; is_safe = Unsafe; mode } - | Pmodbint { size; mode } -> Pmodbint { size; is_safe = Unsafe; mode } - | _ -> assert false - in - let comparison : Clambda_primitives.primitive = - match prim with - | Pdivint _ | Pmodint _ -> Pintcomp Ceq - | Pdivbint { size } | Pmodbint { size } -> Pbintcomp (size,Ceq) - | _ -> assert false - in - t.imported_symbols <- Symbol.Set.add exn_symbol t.imported_symbols; - Flambda.create_let zero zero_const - (Flambda.create_let exn (Symbol exn_symbol) - (Flambda.create_let denominator (Expr arg2) - (Flambda.create_let numerator (Expr arg1) - (Flambda.create_let is_zero - (Prim (comparison, [zero; denominator], dbg)) - (If_then_else (is_zero, - name_expr (Prim (Praise Raise_regular, [exn], dbg)) - ~name:Names.dummy, - (* CR-someday pchambart: find the right event. - mshinwell: I briefly looked at this, and couldn't - figure it out. - lwhite: I don't think any of the existing events - are suitable. I had to add a new one for a similar - case in the array data types work. - mshinwell: deferred CR *) - name_expr ~name:Names.result - (Prim (prim, [numerator; denominator], dbg)), Lambda.layout_int)))))) - | Lprim ((Pdivint Safe | Pmodint Safe - | Pdivbint { is_safe = Safe } | Pmodbint { is_safe = Safe }), _, _) - when not !Clflags.unsafe -> - Misc.fatal_error "Pdivint / Pmodint must have exactly two arguments" - | Lprim (Psequor, [arg1; arg2], _) -> - let arg1 = close t env arg1 in - let arg2 = close t env arg2 in - let const_true = Variable.create Names.const_true in - let cond = Variable.create Names.cond_sequor in - Flambda.create_let const_true (Const (Int 1)) - (Flambda.create_let cond (Expr arg1) - (If_then_else (cond, Var const_true, arg2, Lambda.layout_int))) - | Lprim (Psequand, [arg1; arg2], _) -> - let arg1 = close t env arg1 in - let arg2 = close t env arg2 in - let const_false = Variable.create Names.const_false in - let cond = Variable.create Names.const_sequand in - Flambda.create_let const_false (Const (Int 0)) - (Flambda.create_let cond (Expr arg1) - (If_then_else (cond, arg2, Var const_false, Lambda.layout_int))) - | Lprim ((Psequand | Psequor), _, _) -> - Misc.fatal_error "Psequand / Psequor must have exactly two arguments" - | Lprim ((Pbytes_to_string | Pbytes_of_string | - Parray_to_iarray | Parray_of_iarray | - Pobj_magic _), - [arg], _) -> - close t env arg - | Lprim (Pignore, [arg], _) -> - let var = Variable.create Names.ignore in - let defining_expr = - close_let_bound_expression t var env arg - in - Flambda.create_let var defining_expr - (name_expr (Const (Int 0)) ~name:Names.unit) - | Lprim (Praise kind, [arg], loc) -> - let arg_var = Variable.create Names.raise_arg in - let dbg = Debuginfo.from_location loc in - Flambda.create_let arg_var (Expr (close t env arg)) - (name_expr - (Prim (Praise kind, [arg_var], dbg)) - ~name:Names.raise) - | Lprim (Pctconst c, [arg], _loc) -> - let module Backend = (val t.backend) in - let const = - begin match c with - | Big_endian -> lambda_const_bool Backend.big_endian - | Word_size -> lambda_const_int (8*Backend.size_int) - | Int_size -> lambda_const_int (8*Backend.size_int - 1) - | Max_wosize -> - lambda_const_int ((1 lsl ((8*Backend.size_int) - 10)) - 1) - | Ostype_unix -> lambda_const_bool (String.equal Sys.os_type "Unix") - | Ostype_win32 -> lambda_const_bool (String.equal Sys.os_type "Win32") - | Ostype_cygwin -> lambda_const_bool (String.equal Sys.os_type "Cygwin") - | Backend_type -> - Lambda.const_int 0 (* tag 0 is the same as Native *) - | Runtime5 -> lambda_const_bool Config.runtime5 - end - in - close t env - (Lambda.Llet(Strict, Lambda.layout_unit, Ident.create_local "dummy", - arg, Lconst const)) - | Lprim (Pfield _, [Lprim (Pgetglobal cu, [],_)], _) - when Compilation_unit.equal cu t.current_unit -> - Misc.fatal_errorf "[Pfield (Pgetglobal ...)] for the current compilation \ - unit is forbidden upon entry to the middle end" - | Lprim (Psetfield (_, _, _), [Lprim (Pgetglobal _, [], _); _], _) -> - Misc.fatal_errorf "[Psetfield (Pgetglobal ...)] is \ - forbidden upon entry to the middle end" - | Lprim (Pgetpredef id, [], _) -> - assert (Ident.is_predef id); - let symbol = Symbol.for_predef_ident id in - t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols; - name_expr (Symbol symbol) ~name:Names.predef_exn - | Lprim (Pgetglobal cu, [], _) -> - assert (not (Compilation_unit.equal cu t.current_unit)); - let symbol = Symbol.for_compilation_unit cu in - t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols; - name_expr (Symbol symbol) ~name:Names.pgetglobal - | Lprim (lambda_p, args, loc) -> - (* One of the important consequences of the ANF-like representation - here is that we obtain names corresponding to the components of - blocks being made (with [Pmakeblock]). This information can be used - by the simplification pass to increase the likelihood of eliminating - the allocation, since some field accesses can be tracked back to known - field values. *) - let dbg = Debuginfo.from_location loc in - let p = Convert_primitives.convert lambda_p in - Lift_code.lifting_helper (close_list t env args) - ~evaluation_order:`Right_to_left - ~name:(Names.of_primitive_arg lambda_p) - ~create_body:(fun args -> - name_expr (Prim (p, args, dbg)) - ~name:(Names.of_primitive lambda_p)) - | Lswitch (arg, sw, _loc, kind) -> - let scrutinee = Variable.create Names.switch in - let aux (i, lam) = i, close t env lam in - let nums sw_num cases default = - let module I = Numbers.Int in - match default with - | Some _ -> - I.zero_to_n (sw_num - 1) - | None -> - List.fold_left (fun set (i, _) -> I.Set.add i set) I.Set.empty cases - in - Flambda.create_let scrutinee (Expr (close t env arg)) - (Switch (scrutinee, - { numconsts = nums sw.sw_numconsts sw.sw_consts sw.sw_failaction; - consts = List.map aux sw.sw_consts; - numblocks = nums sw.sw_numblocks sw.sw_blocks sw.sw_failaction; - blocks = List.map aux sw.sw_blocks; - failaction = Option.map (close t env) sw.sw_failaction; - kind; - })) - | Lstringswitch (arg, sw, def, _, kind) -> - let scrutinee = Variable.create Names.string_switch in - Flambda.create_let scrutinee (Expr (close t env arg)) - (String_switch (scrutinee, - List.map (fun (s, e) -> s, close t env e) sw, - Option.map (close t env) def, kind)) - | Lstaticraise (i, args) -> - Lift_code.lifting_helper (close_list t env args) - ~evaluation_order:`Right_to_left - ~name:Names.staticraise_arg - ~create_body:(fun args -> - let static_exn = Env.find_static_exception env i in - Static_raise (static_exn, args)) - | Lstaticcatch (body, (i, ids), handler, kind) -> - let st_exn = Static_exception.create () in - let env = Env.add_static_exception env i st_exn in - let vars = - List.map (fun (ident, kind) -> - (Variable.create_with_same_name_as_ident ident, kind)) ids - in - Static_catch (st_exn, vars, close t env body, - close t (Env.add_vars env (List.map fst ids) vars) handler, kind) - | Ltrywith (body, id, handler, kind) -> - let var = Variable.create_with_same_name_as_ident id in - Try_with (close t env body, var, - close t (Env.add_var env id var Lambda.layout_block) handler, - kind) - | Lifthenelse (cond, ifso, ifnot, kind) -> - let cond = close t env cond in - let cond_var = Variable.create Names.cond in - Flambda.create_let cond_var (Expr cond) - (If_then_else (cond_var, close t env ifso, close t env ifnot, kind)) - | Lsequence (lam1, lam2) -> - let var = Variable.create Names.sequence in - let lam1 = Flambda.Expr (close t env lam1) in - let lam2 = close t env lam2 in - Flambda.create_let var lam1 lam2 - | Lwhile {wh_cond; wh_body} -> - While (close t env wh_cond, close t env wh_body) - | Lfor {for_id; for_from; for_to; for_dir; for_body} -> - let bound_var = Variable.create_with_same_name_as_ident for_id in - let from_value = Variable.create Names.for_from in - let to_value = Variable.create Names.for_to in - let body = close t (Env.add_var env for_id bound_var Lambda.layout_int) for_body in - Flambda.create_let from_value (Expr (close t env for_from)) - (Flambda.create_let to_value (Expr (close t env for_to)) - (For { bound_var; from_value; to_value; direction=for_dir; body; })) - | Lassign (id, new_value) -> - let being_assigned, _kind = - match Env.find_mutable_var_exn env id with - | being_assigned -> being_assigned - | exception Not_found -> - Misc.fatal_errorf "Closure_conversion.close: unbound mutable \ - variable %s in assignment" - (Ident.unique_name id) - in - let new_value_var = Variable.create Names.new_value in - Flambda.create_let new_value_var (Expr (close t env new_value)) - (Assign { being_assigned; new_value = new_value_var; }) - | Levent (lam, _) -> close t env lam - | Lifused _ -> - (* [Lifused] is used to mark that this expression should be alive only if - an identifier is. Every use should have been removed by - [Simplif.simplify_lets], either by replacing by the inner expression, - or by completely removing it (replacing by unit). *) - Misc.fatal_error "[Lifused] should have been removed by \ - [Simplif.simplify_lets]" - | Lregion (body, _) -> - Region (close t env body) - | Lexclave body -> - Exclave (close t env body) - -(** Perform closure conversion on a set of function declarations, returning a - set of closures. (The set will often only contain a single function; - the only case where it cannot is for "let rec".) *) -and close_functions t external_env function_declarations : Flambda.named = - let closure_env_without_parameters = - Function_decls.closure_env_without_parameters - external_env function_declarations - in - let all_free_idents = Function_decls.all_free_idents function_declarations in - let close_one_function map decl = - let body = Function_decl.body decl in - let region = Function_decl.region decl in - let params = Function_decl.params decl in - let return_layout = Function_decl.return_layout decl in - (* Create fresh variables for the elements of the closure (cf. - the comment on [Function_decl.closure_env_without_parameters], above). - This induces a renaming on [Function_decl.free_idents]; the results of - that renaming are stored in [free_variables]. *) - let closure_env = - List.fold_right (fun (id, kind) env -> - Env.add_var env id (Variable.create_with_same_name_as_ident id) kind) - params closure_env_without_parameters - in - (* If the function is the wrapper for a function with an optional - argument with a default value, make sure it always gets inlined. - CR-someday pchambart: eta-expansion wrapper for a primitive are - not marked as stub but certainly should *) - let stub = Function_decl.stub decl in - let param_vars = List.map (fun (id, _) -> Env.find_var closure_env id) params in - let nheap = - match Function_decl.mode decl, Function_decl.kind decl with - | _, Curried {nlocal} -> List.length params - nlocal - | Alloc_heap, Tupled -> List.length params - | Alloc_local, Tupled -> - Misc.fatal_error "Closure_conversion: Tupled Alloc_local function found" - in - let params = List.mapi (fun i (v, kind) -> - (* CR ncourant: actually now we have the alloc_mode in lambda, propagate it *) - let alloc_mode = - if i < nheap then Lambda.alloc_heap else Lambda.alloc_local - in - Parameter.wrap v alloc_mode kind) param_vars - in - let closure_bound_var = Function_decl.closure_bound_var decl in - let unboxed_version = Variable.rename closure_bound_var in - let body = close t closure_env body in - let closure_origin = - Closure_origin.create (Closure_id.wrap unboxed_version) - in - let fun_decl = - Flambda.create_function_declaration - ~params ~alloc_mode:(Function_decl.mode decl) ~region - ~body ~stub ~return_layout - ~inline:(Function_decl.inline decl) - ~specialise:(Function_decl.specialise decl) - ~check:(Function_decl.check decl) - ~is_a_functor:(Function_decl.is_a_functor decl) - ~closure_origin - ~poll:(Function_decl.poll_attribute decl) - in - match Function_decl.kind decl with - | Curried _ -> - Variable.Map.add closure_bound_var fun_decl map - | Tupled -> - let unboxed_version = Variable.rename closure_bound_var in - let generic_function_stub = - tupled_function_call_stub (List.map fst param_vars) unboxed_version - ~closure_bound_var ~region ~return_layout - in - Variable.Map.add unboxed_version fun_decl - (Variable.Map.add closure_bound_var generic_function_stub map) - in - let function_decls = - let is_classic_mode = !Clflags.classic_inlining in - let funs = - List.fold_left close_one_function Variable.Map.empty - (Function_decls.to_list function_declarations) - in - Flambda.create_function_declarations ~is_classic_mode ~funs - in - (* The closed representation of a set of functions is a "set of closures". - (For avoidance of doubt, the runtime representation of the *whole set* is - a single block with tag [Closure_tag].) *) - let set_of_closures = - let free_vars = - Ident.Set.fold (fun var map -> - let internal_var, _ = - Env.find_var closure_env_without_parameters var - in - let var, kind = Env.find_var external_env var in - let external_var : Flambda.specialised_to = - { var ; projection = None; kind } - in - Variable.Map.add internal_var external_var map) - all_free_idents Variable.Map.empty - in - Flambda.create_set_of_closures ~function_decls ~free_vars - ~specialised_args:Variable.Map.empty - ~direct_call_surrogates:Variable.Map.empty - in - Set_of_closures set_of_closures - -and close_list t sb l = List.map (close t sb) l - -and close_let_bound_expression t ?let_rec_ident let_bound_var env - (lam : Lambda.lambda) : Flambda.named = - match lam with - | Lfunction { kind; params; return; body; attr; loc; mode; region } -> - (* Ensure that [let] and [let rec]-bound functions have appropriate - names. *) - let closure_bound_var = - let debug_info = Debuginfo.from_location loc in - Variable.rename ~debug_info let_bound_var - in - let params = List.map (fun (p : Lambda.lparam) -> let No_attributes = p.attributes in (p.name, p.layout)) params in - let decl = - Function_decl.create ~let_rec_ident ~closure_bound_var ~kind ~mode ~region - ~params ~body ~attr ~loc ~return_layout:return - in - let set_of_closures_var = Variable.rename let_bound_var in - let set_of_closures = - close_functions t env (Function_decls.create [decl]) - in - let project_closure : Flambda.project_closure = - { set_of_closures = set_of_closures_var; - closure_id = Closure_id.wrap closure_bound_var; - } - in - Expr (Flambda.create_let set_of_closures_var set_of_closures - (name_expr_from_var (Project_closure (project_closure)) - ~var:let_bound_var)) - | lam -> Expr (close t env lam) - -let lambda_to_flambda ~backend ~compilation_unit ~size ~filename lam - : Flambda.program = - let lam = add_default_argument_wrappers lam in - let current_unit = Compilation_unit.get_current_exn () in - let t = - { current_unit; - filename; - backend; - imported_symbols = Symbol.Set.empty; - declared_symbols = []; - } - in - let module_symbol = Symbol.for_compilation_unit compilation_unit in - let block_symbol = - let var = Variable.create Internal_variable_names.module_as_block in - Symbol_utils.Flambda.for_variable var - in - (* The global module block is built by accessing the fields of all the - introduced symbols. *) - (* CR-soon mshinwell for mshinwell: Add a comment describing how modules are - compiled. *) - let fields = - Array.init size (fun pos -> - let sym_v = Variable.create Names.block_symbol in - let result_v = Variable.create Names.block_symbol_get in - let value_v = Variable.create Names.block_symbol_get_field in - Flambda.create_let - sym_v (Symbol block_symbol) - (Flambda.create_let result_v - (Prim (Pfield (0, Pvalue Pgenval, Pointer, Mutable), [sym_v], - Debuginfo.none)) - (Flambda.create_let value_v - (Prim (Pfield (pos, Pvalue Pgenval, Pointer, Mutable), [result_v], - Debuginfo.none)) - (Var value_v)))) - in - let module_initializer : Flambda.program_body = - Initialize_symbol ( - block_symbol, - Tag.create_exn 0, - [close t Env.empty lam], - Initialize_symbol ( - module_symbol, - Tag.create_exn 0, - Array.to_list fields, - End module_symbol)) - in - let program_body = - List.fold_left - (fun program_body (symbol, constant) : Flambda.program_body -> - Let_symbol (symbol, constant, program_body)) - module_initializer - t.declared_symbols - in - { imported_symbols = t.imported_symbols; - program_body; - } diff --git a/middle_end/flambda/closure_conversion.mli b/middle_end/flambda/closure_conversion.mli deleted file mode 100644 index 32fc984a44b..00000000000 --- a/middle_end/flambda/closure_conversion.mli +++ /dev/null @@ -1,53 +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"] - -(** Generation of [Flambda] intermediate language code from [Lambda] code - by performing a form of closure conversion. - - Function declarations (which may bind one or more variables identifying - functions, possibly with mutual recursion) are transformed to - [Set_of_closures] expressions. [Project_closure] expressions are then - used to select a closure for a particular function from a [Set_of_closures] - expression. The [Set_of_closures] expressions say nothing about the - actual runtime layout of the closures; this is handled when [Flambda] code - is translated to [Clambda] code. - - The following transformations are also performed during closure - conversion: - - Constant blocks (by which is meant things wrapped in [Lambda.Const_block]) - are converted to applications of the [Pmakeblock] primitive. - - [Levent] debugging event nodes are removed and the information within - them attached to function, method and [raise] calls. - - Tuplified functions are converted to curried functions and a stub - function emitted to call the curried version. For example: - let rec f (x, y) = f (x + 1, y + 1) - is transformed to: - let rec internal_f x y = f (x + 1,y + 1) - and f (x, y) = internal_f x y (* [f] is marked as a stub function *) - - The [Pdirapply] and [Prevapply] application primitives are removed and - converted to normal [Flambda] application nodes. - - The [lambda_to_flambda] function is not re-entrant. -*) -val lambda_to_flambda - : backend:(module Backend_intf.S) - -> compilation_unit:Compilation_unit.t - -> size:int - -> filename:string - -> Lambda.lambda - -> Flambda.program diff --git a/middle_end/flambda/closure_conversion_aux.ml b/middle_end/flambda/closure_conversion_aux.ml deleted file mode 100644 index 6393a82e972..00000000000 --- a/middle_end/flambda/closure_conversion_aux.ml +++ /dev/null @@ -1,200 +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-66"] -open! Int_replace_polymorphic_compare - -module Env = struct - type t = { - variables : (Variable.t * Lambda.layout) Ident.tbl; - mutable_variables : (Mutable_variable.t * Lambda.layout) Ident.tbl; - static_exceptions : Static_exception.t Numbers.Int.Map.t; - globals : Symbol.t Numbers.Int.Map.t; - at_toplevel : bool; - } - - let empty = { - variables = Ident.empty; - mutable_variables = Ident.empty; - static_exceptions = Numbers.Int.Map.empty; - globals = Numbers.Int.Map.empty; - at_toplevel = true; - } - - let clear_local_bindings env = - { empty with globals = env.globals } - - let add_var t id var kind = - { t with variables = Ident.add id (var, kind) t.variables } - let add_vars t ids vars = - List.fold_left2 (fun t id (var, kind) -> add_var t id var kind) t ids vars - - let find_var t id = - try Ident.find_same id t.variables - with Not_found -> - Misc.fatal_errorf "Closure_conversion.Env.find_var: %s@ %s" - (Ident.unique_name id) - (Printexc.raw_backtrace_to_string (Printexc.get_callstack 42)) - - let find_var_exn t id = - Ident.find_same id t.variables - - let add_mutable_var t id mutable_var kind = - let mutable_variables = Ident.add id (mutable_var, kind) t.mutable_variables in - { t with mutable_variables } - - let find_mutable_var_exn t id = - Ident.find_same id t.mutable_variables - - let add_static_exception t st_exn fresh_st_exn = - { t with - static_exceptions = - Numbers.Int.Map.add st_exn fresh_st_exn t.static_exceptions } - - let find_static_exception t st_exn = - try Numbers.Int.Map.find st_exn t.static_exceptions - with Not_found -> - Misc.fatal_error ("Closure_conversion.Env.find_static_exception: exn " - ^ Int.to_string st_exn) - - let add_global t pos symbol = - { t with globals = Numbers.Int.Map.add pos symbol t.globals } - - let find_global t pos = - try Numbers.Int.Map.find pos t.globals - with Not_found -> - Misc.fatal_error ("Closure_conversion.Env.find_global: global " - ^ Int.to_string pos) - - let at_toplevel t = t.at_toplevel - - let not_at_toplevel t = { t with at_toplevel = false; } -end - -module Function_decls = struct - module Function_decl = struct - type t = { - let_rec_ident : Ident.t; - closure_bound_var : Variable.t; - kind : Lambda.function_kind; - mode : Lambda.alloc_mode; - region : bool; - params : (Ident.t * Lambda.layout) list; - return_layout : Lambda.layout; - body : Lambda.lambda; - free_idents_of_body : Ident.Set.t; - attr : Lambda.function_attribute; - loc : Lambda.scoped_location - } - - let create ~let_rec_ident ~closure_bound_var ~kind ~mode ~region - ~params ~return_layout ~body ~attr ~loc = - let let_rec_ident = - match let_rec_ident with - | None -> Ident.create_local "unnamed_function" - | Some let_rec_ident -> let_rec_ident - in - { let_rec_ident; - closure_bound_var; - kind; - mode; - region; - params; - return_layout; - body; - free_idents_of_body = Lambda.free_variables body; - attr; - loc; - } - - let let_rec_ident t = t.let_rec_ident - let closure_bound_var t = t.closure_bound_var - let kind t = t.kind - let mode t = t.mode - let region t = t.region - let params t = t.params - let return_layout t = t.return_layout - let body t = t.body - let free_idents t = t.free_idents_of_body - let inline t = t.attr.inline - let specialise t = t.attr.specialise - let check t = t.attr.check - let is_a_functor t = t.attr.is_a_functor - let stub t = t.attr.stub - let poll_attribute t = t.attr.poll - let loc t = t.loc - - end - - type t = { - function_decls : Function_decl.t list; - all_free_idents : Ident.Set.t; - } - - (* All identifiers free in the bodies of the given function declarations, - indexed by the identifiers corresponding to the functions themselves. *) - let free_idents_by_function function_decls = - List.fold_right (fun decl map -> - Variable.Map.add (Function_decl.closure_bound_var decl) - (Function_decl.free_idents decl) map) - function_decls Variable.Map.empty - - let all_free_idents function_decls = - Variable.Map.fold (fun _ -> Ident.Set.union) - (free_idents_by_function function_decls) Ident.Set.empty - - (* All identifiers of simultaneously-defined functions in [ts]. *) - let let_rec_idents function_decls = - List.map Function_decl.let_rec_ident function_decls - - (* All parameters of functions in [ts]. *) - let all_params function_decls = - List.concat (List.map Function_decl.params function_decls) - - let set_diff (from : Ident.Set.t) (idents : Ident.t list) = - List.fold_right Ident.Set.remove idents from - - (* CR-someday lwhite: use a different name from above or explain the - difference *) - let all_free_idents function_decls = - set_diff (set_diff (all_free_idents function_decls) - (List.map fst (all_params function_decls))) - (let_rec_idents function_decls) - - let create (function_decls : Function_decl.t list) = - { function_decls; - all_free_idents = all_free_idents function_decls; - } - - let to_list t = t.function_decls - - let all_free_idents t = t.all_free_idents - - let closure_env_without_parameters external_env t = - let closure_env = - (* For "let rec"-bound functions. *) - List.fold_right (fun function_decl env -> - Env.add_var env (Function_decl.let_rec_ident function_decl) - (Function_decl.closure_bound_var function_decl) Lambda.layout_function) - t.function_decls (Env.clear_local_bindings external_env) - in - (* For free variables. *) - Ident.Set.fold (fun id env -> - let _, kind = Env.find_var external_env id in - Env.add_var env id (Variable.create_with_same_name_as_ident id) kind - ) - t.all_free_idents closure_env -end diff --git a/middle_end/flambda/closure_conversion_aux.mli b/middle_end/flambda/closure_conversion_aux.mli deleted file mode 100644 index b421615a2c0..00000000000 --- a/middle_end/flambda/closure_conversion_aux.mli +++ /dev/null @@ -1,104 +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"] - -(** Environments and auxiliary structures used during closure conversion. *) - -(** Used to remember which [Variable.t] values correspond to which - [Ident.t] values during closure conversion, and similarly for - static exception identifiers. *) -module Env : sig - type t - - val empty : t - - val add_var : t -> Ident.t -> Variable.t -> Lambda.layout -> t - val add_vars : t -> Ident.t list -> (Variable.t * Lambda.layout) list -> t - - val find_var : t -> Ident.t -> Variable.t * Lambda.layout - val find_var_exn : t -> Ident.t -> Variable.t * Lambda.layout - - val add_mutable_var : - t -> Ident.t -> Mutable_variable.t -> Lambda.layout -> t - val find_mutable_var_exn : - t -> Ident.t -> Mutable_variable.t * Lambda.layout - - val add_static_exception : t -> int -> Static_exception.t -> t - val find_static_exception : t -> int -> Static_exception.t - - val add_global : t -> int -> Symbol.t -> t - val find_global : t -> int -> Symbol.t - - val at_toplevel : t -> bool - val not_at_toplevel : t -> t -end - -(** Used to represent information about a set of function declarations - during closure conversion. (The only case in which such a set may - contain more than one declaration is when processing "let rec".) *) -module Function_decls : sig - module Function_decl : sig - type t - - val create - : let_rec_ident:Ident.t option - -> closure_bound_var:Variable.t - -> kind:Lambda.function_kind - -> mode:Lambda.alloc_mode - -> region:bool - -> params:(Ident.t * Lambda.layout) list - -> return_layout:Lambda.layout - -> body:Lambda.lambda - -> attr:Lambda.function_attribute - -> loc:Lambda.scoped_location - -> t - - val let_rec_ident : t -> Ident.t - val closure_bound_var : t -> Variable.t - val kind : t -> Lambda.function_kind - val mode : t -> Lambda.alloc_mode - val region : t -> bool - val params : t -> (Ident.t * Lambda.layout) list - val return_layout : t -> Lambda.layout - val body : t -> Lambda.lambda - val inline : t -> Lambda.inline_attribute - val specialise : t -> Lambda.specialise_attribute - val check : t -> Lambda.check_attribute - val is_a_functor : t -> bool - val stub : t -> bool - val loc : t -> Lambda.scoped_location - val poll_attribute : t -> Lambda.poll_attribute - - (* Like [all_free_idents], but for just one function. *) - val free_idents : t -> Ident.Set.t - end - - type t - - val create : Function_decl.t list -> t - val to_list : t -> Function_decl.t list - - (* All identifiers free in the given function declarations after the binding - of parameters and function identifiers has been performed. *) - val all_free_idents : t -> Ident.Set.t - - (* A map from identifiers to their corresponding [Variable.t]s whose domain - is the set of all identifiers free in the bodies of the declarations that - are not bound as parameters. - It also contains the globals bindings of the provided environment. *) - val closure_env_without_parameters : Env.t -> t -> Env.t -end diff --git a/middle_end/flambda/closure_offsets.ml b/middle_end/flambda/closure_offsets.ml deleted file mode 100644 index 3f6dea997c6..00000000000 --- a/middle_end/flambda/closure_offsets.ml +++ /dev/null @@ -1,97 +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"] - -type layout_atom = Clambda_layout.atom - -type decomposition = Clambda_layout.decomposition -type parts = decomposition - -let equal_parts = Clambda_layout.equal_decomposition -let print_parts = Clambda_layout.print_decomposition - -type result = { - function_offsets : int Closure_id.Map.t; - free_variable_offsets : parts Var_within_closure.Map.t; -} - -let add_closure_offsets - { function_offsets; free_variable_offsets } - ({ function_decls; free_vars } : Flambda.set_of_closures) = - (* Build the table mapping the functions declared by the set of closures - to the positions of their individual "infix" closures inside the runtime - closure block. (All of the environment entries will come afterwards.) *) - let assign_function_offset id function_decl (map, env_pos) = - let pos = env_pos + 1 in - let env_pos = - let arity = Flambda_utils.function_arity function_decl in - env_pos - + 1 (* GC header; either [Closure_tag] or [Infix_tag] *) - + 1 (* full application code pointer *) - + 1 (* arity *) - + (if arity > 1 then 1 else 0) (* partial application code pointer *) - in - let closure_id = Closure_id.wrap id in - if Closure_id.Map.mem closure_id map then begin - Misc.fatal_errorf "Closure_offsets.add_closure_offsets: function \ - offset for %a would be defined multiple times" - Closure_id.print closure_id - end; - let map = Closure_id.Map.add closure_id pos map in - (map, env_pos) - in - let function_offsets, free_variable_pos = - Variable.Map.fold assign_function_offset - function_decls.funs (function_offsets, -1) - in - (* Adds the mapping of free variables to their offset. Recall that - projections of [Var_within_closure]s are only currently used when - compiling accesses to the closure of a function from outside that - function (in particular, as a result of inlining). Accesses to - a function's own closure are compiled directly via normal [Var] - accesses. *) - (* CR-someday mshinwell: As discussed with lwhite, maybe this isn't - ideal, and the self accesses should be explicitly marked too. *) - let free_vars = Variable.Map.bindings free_vars in - let free_vars = List.map (fun (var, (free_var : Flambda.specialised_to)) -> - var, free_var.kind) free_vars in - let free_vars = - Clambda_layout.decompose_free_vars - ~base_offset:free_variable_pos - ~free_vars - in - let free_variable_offsets = - List.fold_left (fun map (var, dec) -> - let var_within_closure = Var_within_closure.wrap var in - Var_within_closure.Map.add var_within_closure dec map) - free_variable_offsets free_vars - in - { function_offsets; - free_variable_offsets; - } - -let compute (program:Flambda.program) = - let init : result = - { function_offsets = Closure_id.Map.empty; - free_variable_offsets = Var_within_closure.Map.empty; - } - in - let r = - List.fold_left add_closure_offsets - init (Flambda_utils.all_sets_of_closures program) - in - r diff --git a/middle_end/flambda/closure_offsets.mli b/middle_end/flambda/closure_offsets.mli deleted file mode 100644 index 858f7ebc59b..00000000000 --- a/middle_end/flambda/closure_offsets.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"] - -(** Assign numerical offsets, within closure blocks, for code pointers and - environment entries. *) - -type layout_atom = Clambda_layout.atom - -type parts = Clambda_layout.decomposition - -val equal_parts : parts -> parts -> bool -val print_parts : Format.formatter -> parts -> unit - -type result = private { - function_offsets : int Closure_id.Map.t; - free_variable_offsets : parts Var_within_closure.Map.t; -} - -val compute : Flambda.program -> result diff --git a/middle_end/flambda/effect_analysis.ml b/middle_end/flambda/effect_analysis.ml deleted file mode 100644 index 3ccfcdd4c73..00000000000 --- a/middle_end/flambda/effect_analysis.ml +++ /dev/null @@ -1,62 +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-66"] -open! Int_replace_polymorphic_compare - -let no_effects_prim (prim : Clambda_primitives.primitive) = - match Semantics_of_primitives.for_primitive prim with - | (No_effects | Only_generative_effects), (No_coeffects | Has_coeffects) -> - true - | _ -> false - -let rec no_effects (flam : Flambda.t) = - match flam with - | Var _ -> true - | Let { defining_expr; body; _ } -> - no_effects_named defining_expr && no_effects body - | Let_mutable { body } -> no_effects body - | Let_rec (defs, body) -> - no_effects body - && List.for_all (fun (_, def) -> no_effects_named def) defs - | If_then_else (_, ifso, ifnot, _) -> no_effects ifso && no_effects ifnot - | Switch (_, sw) -> - let aux (_, flam) = no_effects flam in - List.for_all aux sw.blocks - && List.for_all aux sw.consts - && Option.fold ~some:no_effects ~none:true sw.failaction - | String_switch (_, sw, def, _) -> - List.for_all (fun (_, lam) -> no_effects lam) sw - && Option.fold ~some:no_effects ~none:true def - | Static_catch (_, _, body, _, _) | Try_with (body, _, _, _) -> - (* If there is a [raise] in [body], the whole [Try_with] may have an - effect, so there is no need to test the handler. *) - no_effects body - | Region body -> - no_effects body - | Exclave body -> - no_effects body - | While _ | For _ | Apply _ | Send _ | Assign _ | Static_raise _ -> false - | Proved_unreachable -> true - -and no_effects_named (named : Flambda.named) = - match named with - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ - | Set_of_closures _ | Project_closure _ | Project_var _ - | Move_within_set_of_closures _ -> true - | Prim (prim, _, _) -> no_effects_prim prim - | Expr flam -> no_effects flam diff --git a/middle_end/flambda/effect_analysis.mli b/middle_end/flambda/effect_analysis.mli deleted file mode 100644 index b025bf0f873..00000000000 --- a/middle_end/flambda/effect_analysis.mli +++ /dev/null @@ -1,27 +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"] - -(** Simple side effect analysis. *) - -(* CR-someday pchambart: Replace by call to [Purity] module. - mshinwell: Where is the [Purity] module? *) -(** Conservative approximation as to whether a given Flambda expression may - have any side effects. *) -val no_effects : Flambda.t -> bool - -val no_effects_named : Flambda.named -> bool diff --git a/middle_end/flambda/export_info.ml b/middle_end/flambda/export_info.ml deleted file mode 100644 index dffd12dc98e..00000000000 --- a/middle_end/flambda/export_info.ml +++ /dev/null @@ -1,562 +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"] - -module A = Simple_value_approx - -type value_string_contents = - | Contents of string - | Unknown_or_mutable - -type value_string = { - contents : value_string_contents; - size : int; -} - -type value_float_array_contents = - | Contents of float option array - | Unknown_or_mutable - -type value_float_array = { - contents : value_float_array_contents; - size : int; -} - -type descr = - | Value_block of Tag.t * approx array - | Value_mutable_block of Tag.t * int - | Value_int of int - | Value_char of char - | Value_float of float - | Value_float_array of value_float_array - | Value_boxed_int : 'a A.boxed_int * 'a -> descr - | Value_string of value_string - | Value_closure of value_closure - | Value_set_of_closures of value_set_of_closures - | Value_unknown_descr - -and value_closure = { - closure_id : Closure_id.t; - set_of_closures : value_set_of_closures; -} - -and value_set_of_closures = { - set_of_closures_id : Set_of_closures_id.t; - bound_vars : approx Var_within_closure.Map.t; - free_vars : Flambda.specialised_to Variable.Map.t; - results : approx Closure_id.Map.t; - aliased_symbol : Symbol.t option; -} - -and approx = - | Value_unknown - | Value_id of Export_id.t - | Value_symbol of Symbol.t - -let equal_approx (a1:approx) (a2:approx) = - match a1, a2 with - | Value_unknown, Value_unknown -> - true - | Value_id id1, Value_id id2 -> - Export_id.equal id1 id2 - | Value_symbol s1, Value_symbol s2 -> - Symbol.equal s1 s2 - | (Value_unknown | Value_symbol _ | Value_id _), - (Value_unknown | Value_symbol _ | Value_id _) -> - false - -let equal_array eq a1 a2 = - Array.length a1 = Array.length a2 && - try - Array.iteri (fun i v1 -> if not (eq a2.(i) v1) then raise Exit) a1; - true - with Exit -> false - -let equal_option eq o1 o2 = - match o1, o2 with - | None, None -> true - | Some v1, Some v2 -> eq v1 v2 - | Some _, None | None, Some _ -> false - -let equal_set_of_closures (s1:value_set_of_closures) - (s2:value_set_of_closures) = - Set_of_closures_id.equal s1.set_of_closures_id s2.set_of_closures_id && - Var_within_closure.Map.equal equal_approx s1.bound_vars s2.bound_vars && - Closure_id.Map.equal equal_approx s1.results s2.results && - equal_option Symbol.equal s1.aliased_symbol s2.aliased_symbol - -let equal_descr (d1:descr) (d2:descr) : bool = - match d1, d2 with - | Value_unknown_descr, Value_unknown_descr -> - true - | Value_block (t1, f1), Value_block (t2, f2) -> - Tag.equal t1 t2 && equal_array equal_approx f1 f2 - | Value_mutable_block (t1, s1), Value_mutable_block (t2, s2) -> - Tag.equal t1 t2 && - s1 = s2 - | Value_int i1, Value_int i2 -> - i1 = i2 - | Value_char c1, Value_char c2 -> - c1 = c2 - | Value_float f1, Value_float f2 -> - f1 = f2 - | Value_float_array s1, Value_float_array s2 -> - s1 = s2 - | Value_boxed_int (t1, v1), Value_boxed_int (t2, v2) -> - A.equal_boxed_int t1 v1 t2 v2 - | Value_string s1, Value_string s2 -> - s1 = s2 - | Value_closure c1, Value_closure c2 -> - Closure_id.equal c1.closure_id c2.closure_id && - equal_set_of_closures c1.set_of_closures c2.set_of_closures - | Value_set_of_closures s1, Value_set_of_closures s2 -> - equal_set_of_closures s1 s2 - | ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _ - | Value_char _ | Value_float _ | Value_float_array _ - | Value_boxed_int _ | Value_string _ | Value_closure _ - | Value_set_of_closures _ - | Value_unknown_descr ), - ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _ - | Value_char _ | Value_float _ | Value_float_array _ - | Value_boxed_int _ | Value_string _ | Value_closure _ - | Value_set_of_closures _ - | Value_unknown_descr ) -> - false - -type t = { - sets_of_closures : A.function_declarations Set_of_closures_id.Map.t; - values : descr Export_id.Map.t Compilation_unit.Map.t; - symbol_id : Export_id.t Symbol.Map.t; - offset_fun : int Closure_id.Map.t; - offset_fv : Closure_offsets.parts Var_within_closure.Map.t; - constant_closures : Closure_id.Set.t; - invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; - recursive : Variable.Set.t Set_of_closures_id.Map.t; -} - -type transient = { - sets_of_closures : A.function_declarations Set_of_closures_id.Map.t; - values : descr Export_id.Map.t Compilation_unit.Map.t; - symbol_id : Export_id.t Symbol.Map.t; - invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; - recursive : Variable.Set.t Set_of_closures_id.Map.t; - relevant_local_closure_ids : Closure_id.Set.t; - relevant_imported_closure_ids : Closure_id.Set.t; - relevant_local_vars_within_closure : Var_within_closure.Set.t; - relevant_imported_vars_within_closure : Var_within_closure.Set.t; -} - -let empty : t = { - sets_of_closures = Set_of_closures_id.Map.empty; - values = Compilation_unit.Map.empty; - symbol_id = Symbol.Map.empty; - offset_fun = Closure_id.Map.empty; - offset_fv = Var_within_closure.Map.empty; - constant_closures = Closure_id.Set.empty; - invariant_params = Set_of_closures_id.Map.empty; - recursive = Set_of_closures_id.Map.empty; -} - -let opaque_transient ~compilation_unit ~root_symbol : transient = - let export_id = Export_id.create compilation_unit in - let values = - let map = Export_id.Map.singleton export_id Value_unknown_descr in - Compilation_unit.Map.singleton compilation_unit map - in - let symbol_id = Symbol.Map.singleton root_symbol export_id in - { sets_of_closures = Set_of_closures_id.Map.empty; - values; - symbol_id; - invariant_params = Set_of_closures_id.Map.empty; - recursive = Set_of_closures_id.Map.empty; - relevant_local_closure_ids = Closure_id.Set.empty; - relevant_imported_closure_ids = Closure_id.Set.empty; - relevant_local_vars_within_closure = Var_within_closure.Set.empty; - relevant_imported_vars_within_closure = Var_within_closure.Set.empty; - } - -let create ~sets_of_closures ~values ~symbol_id - ~offset_fun ~offset_fv ~constant_closures - ~invariant_params ~recursive = - { sets_of_closures; - values; - symbol_id; - offset_fun; - offset_fv; - constant_closures; - invariant_params; - recursive; - } - -let create_transient - ~sets_of_closures ~values ~symbol_id ~invariant_params ~recursive - ~relevant_local_closure_ids ~relevant_imported_closure_ids - ~relevant_local_vars_within_closure - ~relevant_imported_vars_within_closure = - { sets_of_closures; - values; - symbol_id; - invariant_params; - recursive; - relevant_local_closure_ids; - relevant_imported_closure_ids; - relevant_local_vars_within_closure; - relevant_imported_vars_within_closure; - } - -let t_of_transient transient - ~program:_ - ~local_offset_fun ~local_offset_fv - ~imported_offset_fun ~imported_offset_fv - ~constant_closures = - let offset_fun = - let fold_map set = - Closure_id.Map.fold (fun key value unchanged -> - if Closure_id.Set.mem key set then - Closure_id.Map.add key value unchanged - else - unchanged) - in - Closure_id.Map.empty - |> fold_map transient.relevant_local_closure_ids local_offset_fun - |> fold_map transient.relevant_imported_closure_ids imported_offset_fun - in - let offset_fv = - let fold_map set = - Var_within_closure.Map.fold (fun key value unchanged -> - if Var_within_closure.Set.mem key set then - Var_within_closure.Map.add key value unchanged - else - unchanged) - in - Var_within_closure.Map.empty - |> fold_map transient.relevant_local_vars_within_closure local_offset_fv - |> fold_map transient.relevant_imported_vars_within_closure - imported_offset_fv - in - { sets_of_closures = transient.sets_of_closures; - values = transient.values; - symbol_id = transient.symbol_id; - invariant_params = transient.invariant_params; - recursive = transient.recursive; - offset_fun; - offset_fv; - constant_closures; - } - -let t_of_opaque_transient transient = - { sets_of_closures = transient.sets_of_closures; - values = transient.values; - symbol_id = transient.symbol_id; - invariant_params = transient.invariant_params; - recursive = transient.recursive; - offset_fun = empty.offset_fun; - offset_fv = empty.offset_fv; - constant_closures = empty.constant_closures; - } - -let merge (t1 : t) (t2 : t) : t = - let eidmap_disjoint_union ?eq map1 map2 = - Compilation_unit.Map.merge (fun _id map1 map2 -> - match map1, map2 with - | None, None -> None - | None, Some map - | Some map, None -> Some map - | Some map1, Some map2 -> - Some (Export_id.Map.disjoint_union ?eq map1 map2)) - map1 map2 - in - let int_eq (i : int) j = i = j in - { values = eidmap_disjoint_union ~eq:equal_descr t1.values t2.values; - sets_of_closures = - Set_of_closures_id.Map.disjoint_union t1.sets_of_closures - t2.sets_of_closures; - symbol_id = - Symbol.Map.disjoint_union ~print:Export_id.print t1.symbol_id - t2.symbol_id; - offset_fun = Closure_id.Map.disjoint_union - ~eq:int_eq t1.offset_fun t2.offset_fun; - offset_fv = Var_within_closure.Map.disjoint_union - ~eq:Closure_offsets.equal_parts t1.offset_fv t2.offset_fv; - constant_closures = - Closure_id.Set.union t1.constant_closures t2.constant_closures; - invariant_params = - Set_of_closures_id.Map.disjoint_union - ~print:(Variable.Map.print Variable.Set.print) - ~eq:(Variable.Map.equal Variable.Set.equal) - t1.invariant_params t2.invariant_params; - recursive = - Set_of_closures_id.Map.disjoint_union - ~print:Variable.Set.print - ~eq:Variable.Set.equal - t1.recursive t2.recursive; - } - -let find_value eid map = - let unit_map = - Compilation_unit.Map.find (Export_id.get_compilation_unit eid) map - in - Export_id.Map.find eid unit_map - -let find_description (t : t) eid = - find_value eid t.values - -let nest_eid_map map = - let add_map eid v map = - let unit = Export_id.get_compilation_unit eid in - let m = - try Compilation_unit.Map.find unit map - with Not_found -> Export_id.Map.empty - in - Compilation_unit.Map.add unit (Export_id.Map.add eid v m) map - in - Export_id.Map.fold add_map map Compilation_unit.Map.empty - -let print_raw_approx ppf approx = - let fprintf = Format.fprintf in - match approx with - | Value_unknown -> fprintf ppf "(Unknown)" - | Value_id export_id -> fprintf ppf "(Id %a)" Export_id.print export_id - | Value_symbol symbol -> fprintf ppf "(Symbol %a)" Symbol.print symbol - -let print_value_set_of_closures ppf (t : value_set_of_closures) = - let print_bound_vars ppf bound_vars = - Format.fprintf ppf "(%a)" - (Var_within_closure.Map.print print_raw_approx) - bound_vars - in - let print_free_vars ppf free_vars = - Format.fprintf ppf "(%a)" - (Variable.Map.print Flambda.print_specialised_to) - free_vars - in - let print_results ppf results = - Format.fprintf ppf "(%a)" (Closure_id.Map.print print_raw_approx) results - in - let print_aliased_symbol ppf aliased_symbol = - match aliased_symbol with - | None -> Format.fprintf ppf "" - | Some symbol -> Format.fprintf ppf "(%a)" Symbol.print symbol - in - Format.fprintf ppf - "((set_of_closures_id %a) \ - (bound_vars %a) \ - (free_vars %a) \ - (results %a) \ - (aliased_symbol %a))" - Set_of_closures_id.print t.set_of_closures_id - print_bound_vars t.bound_vars - print_free_vars t.free_vars - print_results t.results - print_aliased_symbol t.aliased_symbol - -let print_value_closure ppf (t : value_closure) = - Format.fprintf ppf "((closure_id %a) (set_of_closures %a))" - Closure_id.print t.closure_id - print_value_set_of_closures t.set_of_closures - -let print_value_float_array_contents - ppf (value : value_float_array_contents) = - match value with - | Unknown_or_mutable -> Format.fprintf ppf "(Unknown_or_mutable)" - | Contents _ -> Format.fprintf ppf "(Contents ...)" - -let print_value_float_array ppf (value : value_float_array) = - Format.fprintf ppf "((size %d) (contents %a))" - value.size - print_value_float_array_contents value.contents - -let print_value_string_contents ppf (value : value_string_contents) = - match value with - | Unknown_or_mutable -> Format.fprintf ppf "(Unknown_or_mutable)" - | Contents _ -> Format.fprintf ppf "(Contents ...)" - -let print_value_string ppf (value : value_string) = - Format.fprintf ppf "((size %d) (contents %a))" - value.size - print_value_string_contents value.contents - -let print_raw_descr ppf descr = - let fprintf = Format.fprintf in - let print_approx_array ppf arr = - Array.iter (fun approx -> fprintf ppf "%a " print_raw_approx approx) arr - in - match descr with - | Value_block (tag, approx_array) -> - fprintf ppf "(Value_block (%a %a))" - Tag.print tag - print_approx_array approx_array - | Value_mutable_block (tag, i) -> - fprintf ppf "(Value_mutable-block (%a %d))" Tag.print tag i - | Value_int i -> fprintf ppf "(Value_int %d)" i - | Value_char c -> fprintf ppf "(Value_char %c)" c - | Value_float f -> fprintf ppf "(Value_float %.3f)" f - | Value_float_array value_float_array -> - fprintf ppf "(Value_float_array %a)" - print_value_float_array value_float_array - | Value_boxed_int _ -> - fprintf ppf "(Value_Boxed_int)" - | Value_string value_string -> - fprintf ppf "(Value_string %a)" print_value_string value_string - | Value_closure value_closure -> - fprintf ppf "(Value_closure %a)" - print_value_closure value_closure - | Value_set_of_closures value_set_of_closures -> - fprintf ppf "(Value_set_of_closures %a)" - print_value_set_of_closures value_set_of_closures - | Value_unknown_descr -> fprintf ppf "(Value_unknown_descr)" - -let print_approx_components ppf ~symbol_id ~values - (root_symbols : Symbol.t list) = - let fprintf = Format.fprintf in - let printed = ref Export_id.Set.empty in - let recorded_symbol = ref Symbol.Set.empty in - let symbols_to_print = Queue.create () in - let printed_set_of_closures = ref Set_of_closures_id.Set.empty in - let rec print_approx ppf (approx : approx) = - match approx with - | Value_unknown -> fprintf ppf "?" - | Value_id id -> - if Export_id.Set.mem id !printed then - fprintf ppf "(%a: _)" Export_id.print id - else begin - try - let descr = find_value id values in - printed := Export_id.Set.add id !printed; - fprintf ppf "@[(%a:@ %a)@]" - Export_id.print id print_descr descr - with Not_found -> - fprintf ppf "(%a: Not available)" Export_id.print id - end - | Value_symbol sym -> - if not (Symbol.Set.mem sym !recorded_symbol) then begin - recorded_symbol := Symbol.Set.add sym !recorded_symbol; - Queue.push sym symbols_to_print; - end; - Symbol.print ppf sym - and print_descr ppf (descr : descr) = - match descr with - | Value_int i -> Format.pp_print_int ppf i - | Value_char c -> fprintf ppf "%c" c - | Value_block (tag, fields) -> - fprintf ppf "[%a:%a]" Tag.print tag print_fields fields - | Value_mutable_block (tag, size) -> - fprintf ppf "[mutable %a:%i]" Tag.print tag size - | Value_closure {closure_id; set_of_closures} -> - fprintf ppf "(closure %a, %a)" Closure_id.print closure_id - print_set_of_closures set_of_closures - | Value_set_of_closures set_of_closures -> - fprintf ppf "(set_of_closures %a)" print_set_of_closures set_of_closures - | Value_string { contents; size } -> - begin match contents with - | Unknown_or_mutable -> Format.fprintf ppf "string %i" size - | Contents s -> - let s = - if size > 10 - then String.sub s 0 8 ^ "..." - else s - in - Format.fprintf ppf "string %i %S" size s - end - | Value_float f -> Format.pp_print_float ppf f - | Value_float_array float_array -> - Format.fprintf ppf "float_array%s %i" - (match float_array.contents with - | Unknown_or_mutable -> "" - | Contents _ -> "_imm") - float_array.size - | Value_boxed_int (t, i) -> - begin match t with - | A.Int32 -> Format.fprintf ppf "%li" i - | A.Int64 -> Format.fprintf ppf "%Li" i - | A.Nativeint -> Format.fprintf ppf "%ni" i - end - | Value_unknown_descr -> Format.fprintf ppf "?" - and print_fields ppf fields = - Array.iter (fun approx -> fprintf ppf "%a@ " print_approx approx) fields - and print_set_of_closures ppf - { set_of_closures_id; bound_vars; aliased_symbol; results } = - if Set_of_closures_id.Set.mem set_of_closures_id !printed_set_of_closures - then fprintf ppf "%a" Set_of_closures_id.print set_of_closures_id - else begin - printed_set_of_closures := - Set_of_closures_id.Set.add set_of_closures_id !printed_set_of_closures; - let print_alias ppf = function - | None -> () - | Some symbol -> - Format.fprintf ppf "@ (alias: %a)" Symbol.print symbol - in - fprintf ppf "{%a: %a%a => %a}" - Set_of_closures_id.print set_of_closures_id - print_binding bound_vars - print_alias aliased_symbol - (Closure_id.Map.print print_approx) results - end - and print_binding ppf bound_vars = - Var_within_closure.Map.iter (fun clos_id approx -> - fprintf ppf "%a -> %a,@ " - Var_within_closure.print clos_id - print_approx approx) - bound_vars - in - let rec print_recorded_symbols () = - if not (Queue.is_empty symbols_to_print) then begin - let sym = Queue.pop symbols_to_print in - begin match Symbol.Map.find sym symbol_id with - | exception Not_found -> () - | id -> - fprintf ppf "@[%a:@ %a@];@ " - Symbol.print sym - print_approx (Value_id id) - end; - print_recorded_symbols (); - end - in - List.iter (fun s -> Queue.push s symbols_to_print) root_symbols; - fprintf ppf "@[Globals:@ "; - fprintf ppf "@]@ @[Symbols:@ "; - print_recorded_symbols (); - fprintf ppf "@]" - -let print_approx ppf ((t : t), symbols) = - let symbol_id = t.symbol_id in - let values = t.values in - print_approx_components ppf ~symbol_id ~values symbols - -let print_offsets ppf (t : t) = - Format.fprintf ppf "@[offset_fun:@ "; - Closure_id.Map.iter (fun cid off -> - Format.fprintf ppf "%a -> %i@ " - Closure_id.print cid off) t.offset_fun; - Format.fprintf ppf "@]@ @[offset_fv:@ "; - Var_within_closure.Map.iter (fun vid off -> - Format.fprintf ppf "%a -> %a@ " - Var_within_closure.print vid - Closure_offsets.print_parts off) t.offset_fv; - Format.fprintf ppf "@]@ " - -let print_functions ppf (t : t) = - Set_of_closures_id.Map.print - A.print_function_declarations ppf - t.sets_of_closures - -let print_all ppf ((t, root_symbols) : t * Symbol.t list) = - let fprintf = Format.fprintf in - fprintf ppf "approxs@ %a@.@." - print_approx (t, root_symbols); - fprintf ppf "functions@ %a@.@." - print_functions t diff --git a/middle_end/flambda/export_info.mli b/middle_end/flambda/export_info.mli deleted file mode 100644 index a70b894e95a..00000000000 --- a/middle_end/flambda/export_info.mli +++ /dev/null @@ -1,196 +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"] - -(** Exported information (that is to say, information written into a .cmx - file) about a compilation unit. *) - -module A = Simple_value_approx - -type value_string_contents = - | Contents of string - | Unknown_or_mutable - -type value_string = { - contents : value_string_contents; - size : int; -} - -type value_float_array_contents = - | Contents of float option array - | Unknown_or_mutable - -type value_float_array = { - contents : value_float_array_contents; - size : int; -} - -type descr = - | Value_block of Tag.t * approx array - | Value_mutable_block of Tag.t * int - | Value_int of int - | Value_char of char - | Value_float of float - | Value_float_array of value_float_array - | Value_boxed_int : 'a A.boxed_int * 'a -> descr - | Value_string of value_string - | Value_closure of value_closure - | Value_set_of_closures of value_set_of_closures - | Value_unknown_descr - -and value_closure = { - closure_id : Closure_id.t; - set_of_closures : value_set_of_closures; -} - -and value_set_of_closures = { - set_of_closures_id : Set_of_closures_id.t; - bound_vars : approx Var_within_closure.Map.t; - free_vars : Flambda.specialised_to Variable.Map.t; - results : approx Closure_id.Map.t; - aliased_symbol : Symbol.t option; -} - -(* CR-soon mshinwell: Fix the export information so we can correctly - propagate "unresolved due to..." in the manner of [Simple_value_approx]. - Unfortunately this seems to be complicated by the fact that, during - [Import_approx], resolution can fail not only due to missing symbols but - also due to missing export IDs. The argument type of - [Simple_value_approx.t] may need updating to reflect this (make the - symbol optional? It's only for debugging anyway.) *) -and approx = - | Value_unknown - | Value_id of Export_id.t - | Value_symbol of Symbol.t - -(** A structure that describes what a single compilation unit exports. *) -type t = private { - sets_of_closures : A.function_declarations Set_of_closures_id.Map.t; - (** Code of exported functions indexed by set of closures IDs. *) - values : descr Export_id.Map.t Compilation_unit.Map.t; - (** Structure of exported values. *) - symbol_id : Export_id.t Symbol.Map.t; - (** Associates symbols and values. *) - offset_fun : int Closure_id.Map.t; - (** Positions of function pointers in their closures. *) - offset_fv : Closure_offsets.parts Var_within_closure.Map.t; - (** Positions of value pointers in their closures. *) - constant_closures : Closure_id.Set.t; - (* CR-soon mshinwell for pchambart: Add comment *) - invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; - (* Function parameters known to be invariant (see [Invariant_params]) - indexed by set of closures ID. *) - recursive : Variable.Set.t Set_of_closures_id.Map.t; -} - -type transient = private { - sets_of_closures : A.function_declarations Set_of_closures_id.Map.t; - values : descr Export_id.Map.t Compilation_unit.Map.t; - symbol_id : Export_id.t Symbol.Map.t; - invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; - recursive : Variable.Set.t Set_of_closures_id.Map.t; - relevant_local_closure_ids : Closure_id.Set.t; - relevant_imported_closure_ids : Closure_id.Set.t; - relevant_local_vars_within_closure : Var_within_closure.Set.t; - relevant_imported_vars_within_closure : Var_within_closure.Set.t; -} - -(** Export information for a compilation unit that exports nothing. *) -val empty : t - -val opaque_transient - : compilation_unit:Compilation_unit.t - -> root_symbol:Symbol.t - -> transient - -(** Create a new export information structure. *) -val create - : sets_of_closures:(A.function_declarations Set_of_closures_id.Map.t) - -> values:descr Export_id.Map.t Compilation_unit.Map.t - -> symbol_id:Export_id.t Symbol.Map.t - -> offset_fun:int Closure_id.Map.t - -> offset_fv:Closure_offsets.parts Var_within_closure.Map.t - -> constant_closures:Closure_id.Set.t - -> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t - -> recursive:Variable.Set.t Set_of_closures_id.Map.t - -> t - -val create_transient - : sets_of_closures:(A.function_declarations Set_of_closures_id.Map.t) - -> values:descr Export_id.Map.t Compilation_unit.Map.t - -> symbol_id:Export_id.t Symbol.Map.t - -> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t - -> recursive:Variable.Set.t Set_of_closures_id.Map.t - -> relevant_local_closure_ids: Closure_id.Set.t - -> relevant_imported_closure_ids : Closure_id.Set.t - -> relevant_local_vars_within_closure : Var_within_closure.Set.t - -> relevant_imported_vars_within_closure : Var_within_closure.Set.t - -> transient - -(* CR-someday pchambart: Should we separate [t] in 2 types: one created by the - current [create] function, returned by [Build_export_info]. And - another built using t and offset_informations returned by - [flambda_to_clambda] ? - mshinwell: I think we should, but after we've done the first release. -*) -(** Record information about the layout of closures and which sets of - closures are constant. These are all worked out during the - [Flambda_to_clambda] pass. *) -val t_of_transient - : transient - -> program: Flambda.program - -> local_offset_fun:int Closure_id.Map.t - -> local_offset_fv:Closure_offsets.parts Var_within_closure.Map.t - -> imported_offset_fun:int Closure_id.Map.t - -> imported_offset_fv:Closure_offsets.parts Var_within_closure.Map.t - -> constant_closures:Closure_id.Set.t - -> t - -val t_of_opaque_transient : transient -> t - -(** Union of export information. Verifies that there are no identifier - clashes. *) -val merge : t -> t -> t - -(** Look up the description of an exported value given its export ID. *) -val find_description - : t - -> Export_id.t - -> descr - -(** Partition a mapping from export IDs by compilation unit. *) -val nest_eid_map - : 'a Export_id.Map.t - -> 'a Export_id.Map.t Compilation_unit.Map.t - -(**/**) -(* Debug printing functions. *) -val print_approx_components - : Format.formatter - -> symbol_id: Export_id.t Symbol.Map.t - -> values: descr Export_id.Map.t Compilation_unit.Map.t - -> Symbol.t list - -> unit -val print_approx : Format.formatter -> t * Symbol.t list -> unit -val print_functions : Format.formatter -> t -> unit -val print_offsets : Format.formatter -> t -> unit -val print_all : Format.formatter -> t * Symbol.t list -> unit - -(** Prints approx and descr as it is, without recursively looking up - [Export_id.t] *) -val print_raw_approx : Format.formatter -> approx -> unit -val print_raw_descr : Format.formatter -> descr -> unit diff --git a/middle_end/flambda/export_info_for_pack.ml b/middle_end/flambda/export_info_for_pack.ml deleted file mode 100644 index 89154a17072..00000000000 --- a/middle_end/flambda/export_info_for_pack.ml +++ /dev/null @@ -1,225 +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"] - -module A = Simple_value_approx - -let rename_id_state = Export_id.Tbl.create 100 -let rename_set_of_closures_id_state = Set_of_closures_id.Tbl.create 10 -let imported_function_declarations_table = - (Set_of_closures_id.Tbl.create 10 - : A.function_declarations Set_of_closures_id.Tbl.t) - -(* Rename export identifiers' compilation units to denote that they now - live within a pack. *) -let import_eid_for_pack units prefix id = - try Export_id.Tbl.find rename_id_state id - with Not_found -> - let unit_id = Export_id.get_compilation_unit id in - let id' = - if Compilation_unit.Set.mem unit_id units - then - let compilation_unit = - Compilation_unit.with_for_pack_prefix unit_id prefix - in - Export_id.create ?name:(Export_id.name id) compilation_unit - else id - in - Export_id.Tbl.add rename_id_state id id'; - id' - -(* Similar to [import_eid_for_pack], but for symbols. *) -let import_symbol_for_pack units pack symbol = - let compilation_unit = Symbol.compilation_unit symbol in - if Compilation_unit.Set.mem compilation_unit units - then Symbol_utils.Flambda.import_for_pack ~pack symbol - else symbol - -let import_approx_for_pack units pack (approx : Export_info.approx) - : Export_info.approx = - match approx with - | Value_symbol sym -> Value_symbol (import_symbol_for_pack units pack sym) - | Value_id eid -> Value_id (import_eid_for_pack units pack eid) - | Value_unknown -> Value_unknown - -let import_set_of_closures_id_for_pack units prefix - (set_of_closures_id : Set_of_closures_id.t) - : Set_of_closures_id.t = - let compilation_unit = - Set_of_closures_id.get_compilation_unit set_of_closures_id - in - if Compilation_unit.Set.mem compilation_unit units then - let compilation_unit = - Compilation_unit.with_for_pack_prefix compilation_unit prefix - in - Set_of_closures_id.Tbl.memoize - rename_set_of_closures_id_state - (fun _ -> - Set_of_closures_id.create - ?name:(Set_of_closures_id.name set_of_closures_id) - compilation_unit) - set_of_closures_id - else set_of_closures_id - -let import_set_of_closures_origin_for_pack units pack - (set_of_closures_origin : Set_of_closures_origin.t) - : Set_of_closures_origin.t = - Set_of_closures_origin.rename - (import_set_of_closures_id_for_pack units pack) - set_of_closures_origin - -let import_set_of_closures units pack - (set_of_closures : Export_info.value_set_of_closures) - : Export_info.value_set_of_closures = - { set_of_closures_id = - import_set_of_closures_id_for_pack units pack - set_of_closures.set_of_closures_id; - bound_vars = - Var_within_closure.Map.map (import_approx_for_pack units pack) - set_of_closures.bound_vars; - free_vars = set_of_closures.free_vars; - results = - Closure_id.Map.map (import_approx_for_pack units pack) - set_of_closures.results; - aliased_symbol = - Option.map - (import_symbol_for_pack units pack) - set_of_closures.aliased_symbol; - } - -let import_descr_for_pack units pack (descr : Export_info.descr) - : Export_info.descr = - match descr with - | Value_int _ - | Value_char _ - | Value_string _ - | Value_float _ - | Value_float_array _ - | Export_info.Value_boxed_int _ - | Value_mutable_block _ as desc -> desc - | Value_block (tag, fields) -> - Value_block (tag, Array.map (import_approx_for_pack units pack) fields) - | Value_closure { closure_id; set_of_closures } -> - Value_closure { - closure_id; - set_of_closures = import_set_of_closures units pack set_of_closures; - } - | Value_set_of_closures set_of_closures -> - Value_set_of_closures (import_set_of_closures units pack set_of_closures) - | Value_unknown_descr -> Value_unknown_descr - -let rec import_code_for_pack units pack expr = - Flambda_iterators.map_named (function - | Symbol sym -> Symbol (import_symbol_for_pack units pack sym) - | Read_symbol_field (sym, field) -> - Read_symbol_field (import_symbol_for_pack units pack sym, field) - | Set_of_closures set_of_closures -> - let set_of_closures = - Flambda.create_set_of_closures - ~free_vars:set_of_closures.free_vars - ~specialised_args:set_of_closures.specialised_args - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - ~function_decls: - (import_function_declarations_for_pack_aux units pack - set_of_closures.function_decls) - in - Set_of_closures set_of_closures - | e -> e) - expr - -and import_function_declarations_for_pack_aux units pack - (function_decls : Flambda.function_declarations) = - Flambda.import_function_declarations_for_pack - function_decls - (import_set_of_closures_id_for_pack units pack) - (import_set_of_closures_origin_for_pack units pack) - -let import_function_declarations_for_pack_aux units pack - (function_decls : A.function_declarations) : A.function_declarations = - let funs = - Variable.Map.map - (fun (function_decl : A.function_declaration) -> - A.update_function_declaration_body function_decl - (fun body -> import_code_for_pack units pack body)) - function_decls.funs - in - A.import_function_declarations_for_pack - (A.update_function_declarations function_decls ~funs) - (import_set_of_closures_id_for_pack units pack) - (import_set_of_closures_origin_for_pack units pack) - -let import_function_declarations_approx_for_pack units pack - (function_decls: A.function_declarations) = - let original_set_of_closures_id = function_decls.set_of_closures_id in - try - Set_of_closures_id.Tbl.find imported_function_declarations_table - original_set_of_closures_id - with Not_found -> - let function_decls = - import_function_declarations_for_pack_aux units pack function_decls - in - Set_of_closures_id.Tbl.add - imported_function_declarations_table - original_set_of_closures_id - function_decls; - function_decls - -let import_eidmap_for_pack units pack f map = - Export_info.nest_eid_map - (Compilation_unit.Map.fold - (fun _ map acc -> Export_id.Map.disjoint_union map acc) - (Compilation_unit.Map.map (fun map -> - Export_id.Map.map_keys (import_eid_for_pack units pack) - (Export_id.Map.map f map)) - map) - Export_id.Map.empty) - -let import_for_pack ~pack_units ~pack (exp : Export_info.t) = - let import_sym = import_symbol_for_pack pack_units pack in - let import_descr = import_descr_for_pack pack_units pack in - let import_eid = import_eid_for_pack pack_units pack in - let import_eidmap f map = import_eidmap_for_pack pack_units pack f map in - let import_set_of_closures_id = - import_set_of_closures_id_for_pack pack_units pack - in - let import_function_declarations = - import_function_declarations_approx_for_pack pack_units pack - in - let sets_of_closures = - Set_of_closures_id.Map.map_keys import_set_of_closures_id - (Set_of_closures_id.Map.map - import_function_declarations - exp.sets_of_closures) - in - Export_info.create ~sets_of_closures - ~offset_fun:exp.offset_fun - ~offset_fv:exp.offset_fv - ~values:(import_eidmap import_descr exp.values) - ~symbol_id:(Symbol.Map.map_keys import_sym - (Symbol.Map.map import_eid exp.symbol_id)) - ~constant_closures:exp.constant_closures - ~invariant_params: - (Set_of_closures_id.Map.map_keys import_set_of_closures_id - exp.invariant_params) - ~recursive: - (Set_of_closures_id.Map.map_keys import_set_of_closures_id - exp.recursive) - -let clear_import_state () = - Set_of_closures_id.Tbl.clear imported_function_declarations_table; - Set_of_closures_id.Tbl.clear rename_set_of_closures_id_state; - Export_id.Tbl.clear rename_id_state diff --git a/middle_end/flambda/extract_projections.ml b/middle_end/flambda/extract_projections.ml deleted file mode 100644 index 4a6add1253c..00000000000 --- a/middle_end/flambda/extract_projections.ml +++ /dev/null @@ -1,191 +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-66"] -open! Int_replace_polymorphic_compare - -module A = Simple_value_approx -module E = Inline_and_simplify_aux.Env - -(* CR-soon pchambart: should we restrict only to cases - when the field is aliased to a variable outside - of the closure (i.e. when we can certainly remove - the allocation of the block) ? - Note that this may prevent cases with imbricated - closures from benefiting from this transformations. - mshinwell: What word was "imbricated" supposed to be? - (The code this referred to has been deleted, but the same thing is - probably still happening). -*) - -let known_valid_projections ~env ~projections ~which_variables = - Projection.Set.filter (fun projection -> - let from = Projection.projecting_from projection in - let outer_var = - match Variable.Map.find from which_variables with - | exception Not_found -> assert false - | (outer_var : Flambda.specialised_to) -> - Freshening.apply_variable (E.freshening env) outer_var.var - in - let approx = E.find_exn env outer_var in - match projection with - | Project_var project_var -> - begin match A.check_approx_for_closure approx with - | Ok (_value_closure, _approx_var, _approx_sym, - value_set_of_closures) -> - Var_within_closure.Map.mem project_var.var - value_set_of_closures.bound_vars - | Wrong -> false - end - | Project_closure project_closure -> - begin match A.strict_check_approx_for_set_of_closures approx with - | Ok (_var, value_set_of_closures) -> - Variable.Set.mem (Closure_id.unwrap project_closure.closure_id) - (Variable.Map.keys value_set_of_closures.function_decls.funs) - | Wrong -> false - end - | Move_within_set_of_closures move -> - begin match A.check_approx_for_closure approx with - | Ok (value_closure, _approx_var, _approx_sym, - _value_set_of_closures) -> - (* We could check that [move.move_to] is in [value_set_of_closures], - but this is unnecessary, since [Closure_id]s are unique. *) - Closure_id.equal value_closure.closure_id move.start_from - | Wrong -> false - end - | Field (field_index, _) -> - match A.check_approx_for_block approx with - | Wrong -> false - | Ok (_tag, fields) -> - field_index >= 0 && field_index < Array.length fields) - projections - -let rec analyse_expr ~which_variables expr = - let projections = ref Projection.Set.empty in - let used_which_variables = ref Variable.Set.empty in - let check_free_variable var = - if Variable.Map.mem var which_variables then begin - used_which_variables := Variable.Set.add var !used_which_variables - end - in - let for_expr (expr : Flambda.expr) = - match expr with - | Var var - | Let_mutable { initial_value = var } -> - check_free_variable var - (* CR-soon mshinwell: We don't handle [Apply] for the moment to - avoid disabling unboxing optimizations whenever we see a recursive - call. We should improve this analysis. Leo says this can be - done by a similar thing to the unused argument analysis. *) - | Apply _ -> () - | Send { meth; obj; args; _ } -> - check_free_variable meth; - check_free_variable obj; - List.iter check_free_variable args - | Assign { new_value; _ } -> - check_free_variable new_value - | If_then_else (var, _, _, _) - | Switch (var, _) - | String_switch (var, _, _, _) -> - check_free_variable var - | Static_raise (_, args) -> - List.iter check_free_variable args - | For { from_value; to_value; _ } -> - check_free_variable from_value; - check_free_variable to_value - | Let _ | Let_rec _ | Static_catch _ | While _ | Try_with _ - | Region _ | Exclave _ - | Proved_unreachable -> () - in - let for_named (named : Flambda.named) = - match named with - | Project_var project_var - when Variable.Map.mem project_var.closure which_variables -> - projections := - Projection.Set.add (Project_var project_var) !projections - | Project_closure project_closure - when Variable.Map.mem project_closure.set_of_closures - which_variables -> - projections := - Projection.Set.add (Project_closure project_closure) !projections - | Move_within_set_of_closures move - when Variable.Map.mem move.closure which_variables -> - projections := - Projection.Set.add (Move_within_set_of_closures move) !projections - | Prim (Pfield (field_index, Pvalue _, _, _), [var], _dbg) - when Variable.Map.mem var which_variables -> - projections := - Projection.Set.add (Field (field_index, var)) !projections - | Set_of_closures set_of_closures -> - let aliasing_free_vars = - Variable.Map.filter (fun _ (spec_to : Flambda.specialised_to) -> - Variable.Map.mem spec_to.var which_variables) - set_of_closures.free_vars - in - let aliasing_specialised_args = - Variable.Map.filter (fun _ (spec_to : Flambda.specialised_to) -> - Variable.Map.mem spec_to.var which_variables) - set_of_closures.specialised_args - in - let aliasing_vars = - Variable.Map.disjoint_union - aliasing_free_vars aliasing_specialised_args - in - if not (Variable.Map.is_empty aliasing_vars) then begin - Variable.Map.iter (fun _ (fun_decl : Flambda.function_declaration) -> - (* We ignore projections from within nested sets of closures. *) - let _, used = - analyse_expr fun_decl.body ~which_variables:aliasing_vars - in - Variable.Set.iter (fun var -> - match Variable.Map.find var aliasing_vars with - | exception Not_found -> assert false - | spec_to -> check_free_variable spec_to.var) - used) - set_of_closures.function_decls.funs - end - | Prim (_, vars, _) -> - List.iter check_free_variable vars - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ | Project_var _ | Project_closure _ - | Move_within_set_of_closures _ - | Expr _ -> () - in - Flambda_iterators.iter_toplevel for_expr for_named expr; - let projections = !projections in - let used_which_variables = !used_which_variables in - projections, used_which_variables - -let from_function_decl ~env ~which_variables - ~(function_decl : Flambda.function_declaration) = - let projections, used_which_variables = - analyse_expr ~which_variables function_decl.body - in - (* We must use approximation information to determine which projections - are actually valid in the current environment, other we might lift - expressions too far. *) - let projections = - known_valid_projections ~env ~projections ~which_variables - in - (* Don't extract projections whose [projecting_from] variable is also - used boxed. We could in the future consider being more sophisticated - about this based on the uses in the body, but given we are not doing - that yet, it seems safest in performance terms not to (e.g.) unbox a - specialised argument whose boxed version is used. *) - Projection.Set.filter (fun projection -> - let projecting_from = Projection.projecting_from projection in - not (Variable.Set.mem projecting_from used_which_variables)) - projections diff --git a/middle_end/flambda/extract_projections.mli b/middle_end/flambda/extract_projections.mli deleted file mode 100644 index 47456bda0af..00000000000 --- a/middle_end/flambda/extract_projections.mli +++ /dev/null @@ -1,33 +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. *) -(* *) -(**************************************************************************) - -(** Identify projections from variables used in function bodies (free - variables or specialised args, for example, according to [which_variables] - below). Projections from variables that are also used boxed are not - returned. *) - -(** [which_variables] maps (existing) inner variables to (existing) outer - variables in the manner of [free_vars] and [specialised_args] in - [Flambda.set_of_closures]. - - The returned projections are [projecting_from] (cf. projection.mli) - the "existing inner vars". -*) -val from_function_decl - : env:Inline_and_simplify_aux.Env.t - -> which_variables:Flambda.specialised_to Variable.Map.t - -> function_decl:Flambda.function_declaration - -> Projection.Set.t diff --git a/middle_end/flambda/find_recursive_functions.ml b/middle_end/flambda/find_recursive_functions.ml deleted file mode 100644 index 90e3cb6e01b..00000000000 --- a/middle_end/flambda/find_recursive_functions.ml +++ /dev/null @@ -1,31 +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-66"] -open! Int_replace_polymorphic_compare - -let in_function_declarations (function_decls : Flambda.function_declarations) = - let module VCC = Strongly_connected_components.Make (Variable) in - let directed_graph = - Flambda_utils.fun_vars_referenced_in_decls function_decls - in - let connected_components = - VCC.connected_components_sorted_from_roots_to_leaf directed_graph - in - Array.fold_left (fun rec_fun -> function - | VCC.No_loop _ -> rec_fun - | VCC.Has_loop elts -> List.fold_right Variable.Set.add elts rec_fun) - Variable.Set.empty connected_components diff --git a/middle_end/flambda/find_recursive_functions.mli b/middle_end/flambda/find_recursive_functions.mli deleted file mode 100644 index 3db43041c9a..00000000000 --- a/middle_end/flambda/find_recursive_functions.mli +++ /dev/null @@ -1,36 +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"] - -(** "Recursive functions" are those functions [f] that might call either: - - themselves, or - - another function that in turn might call [f]. - - For example in the following simultaneous definition of [f] [g] and [h], - [f] and [g] are recursive functions, but not [h]: - [let rec f x = g x - and g x = f x - and h x = g x] -*) - -(** Determine the recursive functions, if any, bound by the given set of - function declarations. - This is only intended to be used by [Flambda.create_function_declarations]. -*) -val in_function_declarations - : Flambda.function_declarations - -> Variable.Set.t diff --git a/middle_end/flambda/flambda.ml b/middle_end/flambda/flambda.ml deleted file mode 100644 index d19710d7ebd..00000000000 --- a/middle_end/flambda/flambda.ml +++ /dev/null @@ -1,1443 +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-66"] -open! Int_replace_polymorphic_compare - -type call_kind = - | Indirect - | Direct of Closure_id.t - -type const = - | Int of int - | Char of char - -type apply = { - func : Variable.t; - args : Variable.t list; - result_layout : Lambda.layout; - kind : call_kind; - dbg : Debuginfo.t; - reg_close : Lambda.region_close; - mode : Lambda.alloc_mode; - inlined : Lambda.inlined_attribute; - specialise : Lambda.specialise_attribute; - probe : Lambda.probe; -} - -type assign = { - being_assigned : Mutable_variable.t; - new_value : Variable.t; -} - -type send = { - kind : Lambda.meth_kind; - meth : Variable.t; - obj : Variable.t; - args : Variable.t list; - dbg : Debuginfo.t; - reg_close : Lambda.region_close; - mode : Lambda.alloc_mode; - result_layout : Lambda.layout; -} - -type project_closure = Projection.project_closure -type move_within_set_of_closures = Projection.move_within_set_of_closures -type project_var = Projection.project_var - -type specialised_to = { - var : Variable.t; - projection : Projection.t option; - kind : Lambda.layout; -} - -type t = - | Var of Variable.t - | Let of let_expr - | Let_mutable of let_mutable - | Let_rec of (Variable.t * named) list * t - | Apply of apply - | Send of send - | Assign of assign - | If_then_else of Variable.t * t * t * Lambda.layout - | Switch of Variable.t * switch - | String_switch of Variable.t * (string * t) list * t option - * Lambda.layout - | Static_raise of Static_exception.t * Variable.t list - | Static_catch of Static_exception.t * ( Variable.t * Lambda.layout ) list * t * t * Lambda.layout - | Try_with of t * Variable.t * t * Lambda.layout - | While of t * t - | For of for_loop - | Region of t - | Exclave of t - | Proved_unreachable - -and named = - | Symbol of Symbol.t - | Const of const - | Allocated_const of Allocated_const.t - | Read_mutable of Mutable_variable.t - | Read_symbol_field of Symbol.t * int - | Set_of_closures of set_of_closures - | Project_closure of project_closure - | Move_within_set_of_closures of move_within_set_of_closures - | Project_var of project_var - | Prim of Clambda_primitives.primitive * Variable.t list * Debuginfo.t - | Expr of t - -and let_expr = { - var : Variable.t; - defining_expr : named; - body : t; - free_vars_of_defining_expr : Variable.Set.t; - free_vars_of_body : Variable.Set.t; -} - -and let_mutable = { - var : Mutable_variable.t; - initial_value : Variable.t; - contents_kind : Lambda.layout; - body : t; -} - -and set_of_closures = { - function_decls : function_declarations; - free_vars : specialised_to Variable.Map.t; - specialised_args : specialised_to Variable.Map.t; - direct_call_surrogates : Variable.t Variable.Map.t; - alloc_mode : Lambda.alloc_mode; -} - -and function_declarations = { - is_classic_mode : bool; - set_of_closures_id : Set_of_closures_id.t; - set_of_closures_origin : Set_of_closures_origin.t; - funs : function_declaration Variable.Map.t; -} - -and function_declaration = { - closure_origin: Closure_origin.t; - params : Parameter.t list; - return_layout : Lambda.layout; - alloc_mode : Lambda.alloc_mode; - region : bool; - body : t; - free_variables : Variable.Set.t; - free_symbols : Symbol.Set.t; - stub : bool; - dbg : Debuginfo.t; - inline : Lambda.inline_attribute; - specialise : Lambda.specialise_attribute; - check : Lambda.check_attribute; - is_a_functor : bool; - poll: Lambda.poll_attribute; -} - -and switch = { - numconsts : Numbers.Int.Set.t; - consts : (int * t) list; - numblocks : Numbers.Int.Set.t; - blocks : (int * t) list; - failaction : t option; - kind: Lambda.layout; -} - -and for_loop = { - bound_var : Variable.t; - from_value : Variable.t; - to_value : Variable.t; - direction : Asttypes.direction_flag; - body : t -} - -and constant_defining_value = - | Allocated_const of Allocated_const.t - | Block of Tag.t * constant_defining_value_block_field list - | Set_of_closures of set_of_closures (* [free_vars] must be empty *) - | Project_closure of Symbol.t * Closure_id.t - -and constant_defining_value_block_field = - | Symbol of Symbol.t - | Const of const - -type expr = t - -type program_body = - | Let_symbol of Symbol.t * constant_defining_value * program_body - | Let_rec_symbol of (Symbol.t * constant_defining_value) list * program_body - | Initialize_symbol of Symbol.t * Tag.t * t list * program_body - | Effect of t * program_body - | End of Symbol.t - -type program = { - imported_symbols : Symbol.Set.t; - program_body : program_body; -} - -let fprintf = Format.fprintf -module Int = Numbers.Int - -let print_specialised_to ppf (spec_to : specialised_to) = - match spec_to.projection with - | None -> - fprintf ppf "%a[%a]" - Variable.print spec_to.var - Printlambda.layout spec_to.kind - | Some projection -> - fprintf ppf "%a(= %a)[%a]" - Variable.print spec_to.var - Projection.print projection - Printlambda.layout spec_to.kind - -(* CR-soon mshinwell: delete uses of old names *) -let print_project_var = Projection.print_project_var -let print_move_within_set_of_closures = - Projection.print_move_within_set_of_closures -let print_project_closure = Projection.print_project_closure - -let print_call_attrs ppf (mode, reg_close) = - let mode ppf () = - match (mode : Lambda.alloc_mode) with - | Alloc_local -> fprintf ppf "" - | Alloc_heap -> () - in - let reg_close ppf () = - match (reg_close : Lambda.region_close) with - | Rc_nontail -> fprintf ppf "" - | Rc_close_at_apply -> fprintf ppf "" - | Rc_normal -> () - in - fprintf ppf "%a%a" mode () reg_close () - -(** CR-someday lwhite: use better name than this *) -let [@warning "+missing-record-field-pattern"] rec lam ppf (flam : t) = - match flam with - | Var (id) -> - Variable.print ppf id - | Apply({func; args; kind; inlined; probe; dbg; result_layout; - mode; reg_close; specialise = _}) -> - let direct ppf () = - match kind with - | Indirect -> () - | Direct closure_id -> fprintf ppf "*[%a]" Closure_id.print closure_id - in - let inlined ppf () = - match inlined with - | Always_inlined -> fprintf ppf "" - | Never_inlined -> fprintf ppf "" - | Hint_inlined -> fprintf ppf "" - | Unroll i -> fprintf ppf "" i - | Default_inlined -> () - in - let probe ppf () = - match probe with - | None -> () - | Some {name; enabled_at_init = _} -> fprintf ppf "" name - in - fprintf ppf "@[<2>(apply%a%a%a%a<%s>%a@ %a%a)@]" direct () - print_call_attrs (mode, reg_close) - inlined () probe () - (Debuginfo.to_string dbg) - Printlambda.layout result_layout - Variable.print func Variable.print_list args - | Assign { being_assigned; new_value; } -> - fprintf ppf "@[<2>(assign@ %a@ %a)@]" - Mutable_variable.print being_assigned - Variable.print new_value - | Send { kind; meth; obj; args; mode; reg_close; - result_layout = _; dbg = _; } -> - let print_args ppf args = - List.iter (fun l -> fprintf ppf "@ %a" Variable.print l) args - in - let kind = - match kind with - | Self -> "self" - | Public -> "public" - | Cached -> "cached" - in - fprintf ppf "@[<2>(send%s%a@ %a@ %a%a)@]" kind - print_call_attrs (mode, reg_close) - Variable.print obj Variable.print meth - print_args args - | Proved_unreachable -> - fprintf ppf "unreachable" - | Let { var = id; defining_expr = arg; body; _ } -> - let rec letbody (ul : t) = - match ul with - | Let { var = id; defining_expr = arg; body; _ } -> - fprintf ppf "@ @[<2>%a@ %a@]" Variable.print id print_named arg; - letbody body - | _ -> ul - in - fprintf ppf "@[<2>(let@ @[(@[<2>%a@ %a@]" - Variable.print id print_named arg; - let expr = letbody body in - fprintf ppf ")@]@ %a)@]" lam expr - | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> - let print_kind ppf (kind : Lambda.layout) = - match kind with - | Pvalue Pgenval -> () - | _ -> Format.fprintf ppf " %a" Printlambda.layout kind - in - fprintf ppf "@[<2>(let_mutable%a@ @[<2>%a@ %a@]@ %a)@]" - print_kind contents_kind - Mutable_variable.print mut_var - Variable.print var - lam body - | Let_rec(id_arg_list, body) -> - let bindings ppf id_arg_list = - let spc = ref false in - List.iter - (fun (id, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<2>%a@ %a@]" Variable.print id print_named l) - id_arg_list in - fprintf ppf - "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body - | Switch(larg, sw) -> - let switch ppf (sw : switch) = - let spc = ref false in - List.iter - (fun (n, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case int %i:@ %a@]" n lam l) - sw.consts; - List.iter - (fun (n, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case tag %i:@ %a@]" n lam l) - sw.blocks ; - begin match sw.failaction with - | None -> () - | Some l -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam l - end in - fprintf ppf - "@[<1>(%s(%i,%i) %a@ @[%a@])@]" - (match sw.failaction with None -> "switch*" | _ -> "switch") - (Int.Set.cardinal sw.numconsts) - (Int.Set.cardinal sw.numblocks) - Variable.print larg switch sw - | String_switch(arg, cases, default, _kind) -> - let switch ppf cases = - let spc = ref false in - List.iter - (fun (s, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) - cases; - begin match default with - | Some default -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam default - | None -> () - end in - fprintf ppf - "@[<1>(stringswitch %a@ @[%a@])@]" Variable.print arg switch cases - | Static_raise (i, ls) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" Variable.print l) largs in - fprintf ppf "@[<2>(exit@ %a%a)@]" Static_exception.print i lams ls; - | Static_catch(i, vars, lbody, lhandler, _kind) -> - fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%a%a)@ %a)@]" - lam lbody Static_exception.print i - (fun ppf vars -> match vars with - | [] -> () - | _ -> - List.iter - (fun (x, _layout) -> fprintf ppf " %a" Variable.print x) - vars) - vars - lam lhandler - | Try_with(lbody, param, lhandler, _kind) -> - fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" - lam lbody Variable.print param lam lhandler - | If_then_else(lcond, lif, lelse, _kind) -> - fprintf ppf "@[<2>(if@ %a@ then begin@ %a@ end else begin@ %a@ end)@]" - Variable.print lcond - lam lif lam lelse - | While(lcond, lbody) -> - fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody - | For { bound_var; from_value; to_value; direction; body; } -> - fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" - Variable.print bound_var Variable.print from_value - (match direction with - Asttypes.Upto -> "to" | Asttypes.Downto -> "downto") - Variable.print to_value lam body - | Region body -> - fprintf ppf "@[<2>(region@ %a)@]" lam body - | Exclave body -> - fprintf ppf "@[<2>(exclave@ %a)@]" lam body - -and print_named ppf (named : named) = - match named with - | Symbol (symbol) -> Symbol.print ppf symbol - | Const (cst) -> fprintf ppf "Const(%a)" print_const cst - | Allocated_const (cst) -> fprintf ppf "Aconst(%a)" Allocated_const.print cst - | Read_mutable mut_var -> - fprintf ppf "Read_mut(%a)" Mutable_variable.print mut_var - | Read_symbol_field (symbol, field) -> - fprintf ppf "%a.(%d)" Symbol.print symbol field - | Project_closure (project_closure) -> - print_project_closure ppf project_closure - | Project_var (project_var) -> print_project_var ppf project_var - | Move_within_set_of_closures (move_within_set_of_closures) -> - print_move_within_set_of_closures ppf move_within_set_of_closures - | Set_of_closures (set_of_closures) -> - print_set_of_closures ppf set_of_closures - | Prim(prim, args, dbg) -> - fprintf ppf "@[<2>(%a<%s>%a)@]" Printclambda_primitives.primitive prim - (Debuginfo.to_string dbg) - Variable.print_list args - | Expr expr -> - fprintf ppf "*%a" lam expr - (* lam ppf expr *) - -and print_function_declaration ppf var (f : function_declaration) = - let params ppf = - List.iter (fprintf ppf "@ %a" Parameter.print) in - let stub = - if f.stub then - " *stub*" - else - "" - in - let is_a_functor = - if f.is_a_functor then - " *functor*" - else - "" - in - let inline = - match f.inline with - | Always_inline -> " *inline*" - | Available_inline -> " *inline_available*" - | Never_inline -> " *never_inline*" - | Unroll _ -> " *unroll*" - | Default_inline -> "" - in - let specialise = - match f.specialise with - | Always_specialise -> " *specialise*" - | Never_specialise -> " *never_specialise*" - | Default_specialise -> "" - in - fprintf ppf "@[<2>(%a%s%s%s%s%a@ =@ fun@[<2>%a@] ->@ @[<2>%a@])@]@ " - Variable.print var stub is_a_functor inline specialise - Printlambda.check_attribute f.check - params f.params lam f.body - -and print_set_of_closures ppf (set_of_closures : set_of_closures) = - match set_of_closures with - | { function_decls; free_vars; specialised_args; alloc_mode } -> - let funs ppf = - Variable.Map.iter (print_function_declaration ppf) - in - let vars ppf = - Variable.Map.iter (fun id v -> - fprintf ppf "@ %a -rename-> %a" - Variable.print id print_specialised_to v) - in - let spec ppf spec_args = - if not (Variable.Map.is_empty spec_args) - then begin - fprintf ppf "@ "; - Variable.Map.iter (fun id (spec_to : specialised_to) -> - fprintf ppf "@ %a := %a" - Variable.print id print_specialised_to spec_to) - spec_args - end - in - let alloc_mode = match alloc_mode with - | Alloc_heap -> "Alloc_heap" - | Alloc_local -> "Alloc_local" - in - fprintf ppf "@[<2>(set_of_closures id=%a@ %a@ @[<2>free_vars={%a@ }@]@ \ - @[<2>specialised_args={%a})@]@ \ - @[<2>direct_call_surrogates=%a@]@ \ - @[<2>alloc_mode=%s@]@ \ - @[<2>set_of_closures_origin=%a@]@]]" - Set_of_closures_id.print function_decls.set_of_closures_id - funs function_decls.funs - vars free_vars - spec specialised_args - (Variable.Map.print Variable.print) - set_of_closures.direct_call_surrogates - alloc_mode - Set_of_closures_origin.print function_decls.set_of_closures_origin - -and print_const ppf (c : const) = - match c with - | Int n -> fprintf ppf "%i" n - | Char c -> fprintf ppf "%C" c - -let print_function_declarations ppf (fd : function_declarations) = - let funs ppf = - Variable.Map.iter (print_function_declaration ppf) - in - fprintf ppf "@[<2>(%a)(origin = %a)@]" funs fd.funs - Set_of_closures_origin.print fd.set_of_closures_origin - -let print ppf flam = - fprintf ppf "%a@." lam flam - -let print_function_declaration ppf (var, decl) = - print_function_declaration ppf var decl - -let print_constant_defining_value ppf (const : constant_defining_value) = - match const with - | Allocated_const const -> - fprintf ppf "(Allocated_const %a)" Allocated_const.print const - | Block (tag, []) -> fprintf ppf "(Atom (tag %d))" (Tag.to_int tag) - | Block (tag, fields) -> - let print_field ppf (field : constant_defining_value_block_field) = - match field with - | Symbol symbol -> Symbol.print ppf symbol - | Const const -> print_const ppf const - in - let print_fields ppf = - List.iter (fprintf ppf "@ %a" print_field) - in - fprintf ppf "(Block (tag %d, %a))" (Tag.to_int tag) - print_fields fields - | Set_of_closures set_of_closures -> - fprintf ppf "@[<2>(Set_of_closures (@ %a))@]" print_set_of_closures - set_of_closures - | Project_closure (set_of_closures, closure_id) -> - fprintf ppf "(Project_closure (%a, %a))" Symbol.print set_of_closures - Closure_id.print closure_id - -let rec print_program_body ppf (program : program_body) = - let symbol_binding ppf (symbol, constant_defining_value) = - fprintf ppf "@[<2>(%a@ %a)@]" - Symbol.print symbol - print_constant_defining_value constant_defining_value - in - match program with - | Let_symbol (symbol, constant_defining_value, body) -> - let rec extract acc (ul : program_body) = - match ul with - | Let_symbol (symbol, constant_defining_value, body) -> - extract ((symbol, constant_defining_value) :: acc) body - | _ -> - List.rev acc, ul - in - let defs, program = extract [symbol, constant_defining_value] body in - fprintf ppf - "@[<2>let_symbol@ @[%a@]@]@." - (Format.pp_print_list symbol_binding) defs; - print_program_body ppf program - | Let_rec_symbol (defs, program) -> - fprintf ppf - "@[<2>let_rec_symbol@ @[%a@]@]@." - (Format.pp_print_list symbol_binding) defs; - print_program_body ppf program - | Initialize_symbol (symbol, tag, fields, program) -> - fprintf ppf "@[<2>initialize_symbol@ (@[<2>%a@ %a@ %a@])@]@." - Symbol.print symbol - Tag.print tag - (Format.pp_print_list lam) fields; - print_program_body ppf program - | Effect (expr, program) -> - fprintf ppf "@[<2>effect@ %a@]@." - lam expr; - print_program_body ppf program; - | End root -> fprintf ppf "End %a" Symbol.print root - -let print_program ppf program = - Symbol.Set.iter (fun symbol -> - fprintf ppf "@[import_symbol@ %a@]@." Symbol.print symbol) - program.imported_symbols; - print_program_body ppf program.program_body - -let rec variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument - ?ignore_uses_in_project_var ~all_used_variables tree = - match tree with - | Var var -> Variable.Set.singleton var - | _ -> - let free = ref Variable.Set.empty in - let bound = ref Variable.Set.empty in - let free_variables ids = free := Variable.Set.union ids !free in - let free_variable fv = free := Variable.Set.add fv !free in - let bound_variable id = bound := Variable.Set.add id !bound in - (* N.B. This function assumes that all bound identifiers are distinct. *) - let rec aux (flam : t) : unit = - match flam with - | Var var -> free_variable var - | Apply { func; args; kind = _; dbg = _} -> - begin match ignore_uses_as_callee with - | None -> free_variable func - | Some () -> () - end; - begin match ignore_uses_as_argument with - | None -> List.iter free_variable args - | Some () -> () - end - | Let { var; free_vars_of_defining_expr; free_vars_of_body; - defining_expr; body; _ } -> - bound_variable var; - if all_used_variables - || Option.is_some ignore_uses_as_callee - || Option.is_some ignore_uses_as_argument - || Option.is_some ignore_uses_in_project_var - then begin - (* In these cases we can't benefit from the pre-computed free - variable sets. *) - free_variables - (variables_usage_named ?ignore_uses_in_project_var - ?ignore_uses_as_callee ?ignore_uses_as_argument - ~all_used_variables defining_expr); - aux body - end else begin - free_variables free_vars_of_defining_expr; - free_variables free_vars_of_body - end - | Let_mutable { initial_value = var; body; _ } -> - free_variable var; - aux body - | Let_rec (bindings, body) -> - List.iter (fun (var, defining_expr) -> - bound_variable var; - free_variables - (variables_usage_named ?ignore_uses_in_project_var - ~all_used_variables defining_expr)) - bindings; - aux body - | Switch (scrutinee, switch) -> - free_variable scrutinee; - List.iter (fun (_, e) -> aux e) switch.consts; - List.iter (fun (_, e) -> aux e) switch.blocks; - Option.iter aux switch.failaction - | String_switch (scrutinee, cases, failaction, _kind) -> - free_variable scrutinee; - List.iter (fun (_, e) -> aux e) cases; - Option.iter aux failaction - | Static_raise (_, es) -> - List.iter free_variable es - | Static_catch (_, vars, e1, e2, _) -> - List.iter (fun (var, _layout) -> bound_variable var) vars; - aux e1; - aux e2 - | Try_with (e1, var, e2, _kind) -> - aux e1; - bound_variable var; - aux e2 - | If_then_else (var, e1, e2, _kind) -> - free_variable var; - aux e1; - aux e2 - | While (e1, e2) -> - aux e1; - aux e2 - | For { bound_var; from_value; to_value; direction = _; body; } -> - bound_variable bound_var; - free_variable from_value; - free_variable to_value; - aux body - | Assign { being_assigned = _; new_value; } -> - free_variable new_value - | Send { kind = _; meth; obj; args; dbg = _ } -> - free_variable meth; - free_variable obj; - List.iter free_variable args; - | Region body -> - aux body - | Exclave body -> - aux body - | Proved_unreachable -> () - in - aux tree; - if all_used_variables then - !free - else - Variable.Set.diff !free !bound - -and variables_usage_named ?ignore_uses_in_project_var - ?ignore_uses_as_callee ?ignore_uses_as_argument - ~all_used_variables named = - let free = ref Variable.Set.empty in - let free_variable fv = free := Variable.Set.add fv !free in - begin match named with - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ -> () - | Set_of_closures { free_vars; specialised_args; _ } -> - (* Sets of closures are, well, closed---except for the free variable and - specialised argument lists, which may identify variables currently in - scope outside of the closure. *) - Variable.Map.iter (fun _ (renamed_to : specialised_to) -> - (* We don't need to do anything with [renamed_to.projectee.var], if - it is present, since it would only be another free variable - in the same set of closures. *) - free_variable renamed_to.var) - free_vars; - Variable.Map.iter (fun _ (spec_to : specialised_to) -> - (* We don't need to do anything with [spec_to.projectee.var], if - it is present, since it would only be another specialised arg - in the same set of closures. *) - free_variable spec_to.var) - specialised_args - | Project_closure { set_of_closures; closure_id = _ } -> - free_variable set_of_closures - | Project_var { closure; closure_id = _; var = _ } -> - begin match ignore_uses_in_project_var with - | None -> free_variable closure - | Some () -> () - end - | Move_within_set_of_closures { closure; start_from = _; move_to = _ } -> - free_variable closure - | Prim (_, args, _) -> List.iter free_variable args - | Expr flam -> - free := Variable.Set.union - (variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument - ~all_used_variables flam) !free - end; - !free - -let free_variables ?ignore_uses_as_callee ?ignore_uses_as_argument - ?ignore_uses_in_project_var tree = - variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument - ?ignore_uses_in_project_var ~all_used_variables:false tree - -let free_variables_named ?ignore_uses_in_project_var named = - variables_usage_named ?ignore_uses_in_project_var - ~all_used_variables:false named - -let used_variables ?ignore_uses_as_callee ?ignore_uses_as_argument - ?ignore_uses_in_project_var tree = - variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument - ?ignore_uses_in_project_var ~all_used_variables:true tree - -let used_variables_named ?ignore_uses_in_project_var named = - variables_usage_named ?ignore_uses_in_project_var - ~all_used_variables:true named - -let create_let var defining_expr body : t = - begin match !Clflags.dump_flambda_let with - | None -> () - | Some stamp -> - Variable.debug_when_stamp_matches var ~stamp ~f:(fun () -> - Printf.eprintf "Creation of [Let] with stamp %d:\n%s\n%!" - stamp - (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int))) - end; - let defining_expr, free_vars_of_defining_expr = - match defining_expr with - | Expr (Let { var = var1; defining_expr; body = Var var2; - free_vars_of_defining_expr; _ }) when Variable.equal var1 var2 -> - defining_expr, free_vars_of_defining_expr - (* TODO: This let-conversion is blocked by Region constructors. - It might be worth optimising this. *) - | _ -> defining_expr, free_variables_named defining_expr - in - Let { - var; - defining_expr; - body; - free_vars_of_defining_expr; - free_vars_of_body = free_variables body; - } - -let map_defining_expr_of_let let_expr ~f = - let defining_expr = f let_expr.defining_expr in - if defining_expr == let_expr.defining_expr then - Let let_expr - else - let free_vars_of_defining_expr = - free_variables_named defining_expr - in - Let { - var = let_expr.var; - defining_expr; - body = let_expr.body; - free_vars_of_defining_expr; - free_vars_of_body = let_expr.free_vars_of_body; - } - -let iter_lets t ~for_defining_expr ~for_last_body ~for_each_let = - let rec loop (t : t) = - match t with - | Let { var; defining_expr; body; _ } -> - for_each_let t; - for_defining_expr var defining_expr; - loop body - | t -> - for_last_body t - in - loop t - -let map_lets t ~for_defining_expr ~for_last_body ~after_rebuild = - let rec loop (t : t) ~rev_lets = - match t with - | Let { var; defining_expr; body; _ } -> - let new_defining_expr = - for_defining_expr var defining_expr - in - let original = - if new_defining_expr == defining_expr then - Some t - else - None - in - let rev_lets = (var, new_defining_expr, original) :: rev_lets in - loop body ~rev_lets - | t -> - let last_body = for_last_body t in - (* As soon as we see a change, we have to rebuild that [Let] and every - outer one. *) - let seen_change = ref (not (last_body == t)) in - List.fold_left (fun t (var, defining_expr, original) -> - let let_expr = - match original with - | Some original when not !seen_change -> original - | Some _ | None -> - seen_change := true; - create_let var defining_expr t - in - let new_let = after_rebuild let_expr in - if not (new_let == let_expr) then begin - seen_change := true - end; - new_let) - last_body - rev_lets - in - loop t ~rev_lets:[] - -(** CR-someday lwhite: Why not use two functions? *) -type maybe_named = - | Is_expr of t - | Is_named of named - -let iter_general ~toplevel f f_named maybe_named = - let rec aux (t : t) = - match t with - | Let _ -> - iter_lets t - ~for_defining_expr:(fun _var named -> aux_named named) - ~for_last_body:aux - ~for_each_let:f - | _ -> - f t; - match t with - | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable - | Static_raise _ -> () - | Let _ -> assert false - | Let_mutable { body; _ } -> - aux body - | Let_rec (defs, body) -> - List.iter (fun (_,l) -> aux_named l) defs; - aux body - | Try_with (f1,_,f2, _) - | While (f1,f2) - | Static_catch (_,_,f1,f2, _) -> - aux f1; aux f2 - | For { body; _ } -> aux body - | If_then_else (_, f1, f2, _) -> - aux f1; aux f2 - | Switch (_, sw) -> - List.iter (fun (_,l) -> aux l) sw.consts; - List.iter (fun (_,l) -> aux l) sw.blocks; - Option.iter aux sw.failaction - | String_switch (_, sw, def, _) -> - List.iter (fun (_,l) -> aux l) sw; - Option.iter aux def - | Region body -> - aux body - | Exclave body -> - aux body - and aux_named (named : named) = - f_named named; - match named with - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ - | Project_closure _ | Project_var _ | Move_within_set_of_closures _ - | Prim _ -> () - | Set_of_closures ({ function_decls = funcs; free_vars = _; - specialised_args = _}) -> - if not toplevel then begin - Variable.Map.iter (fun _ (decl : function_declaration) -> - aux decl.body) - funcs.funs - end - | Expr flam -> aux flam - in - match maybe_named with - | Is_expr expr -> aux expr - | Is_named named -> aux_named named - -module With_free_variables = struct - type 'a t = - | Expr : expr * Variable.Set.t -> expr t - | Named : named * Variable.Set.t -> named t - - let of_defining_expr_of_let let_expr = - Named (let_expr.defining_expr, let_expr.free_vars_of_defining_expr) - - let of_body_of_let let_expr = - Expr (let_expr.body, let_expr.free_vars_of_body) - - let of_expr expr = - Expr (expr, free_variables expr) - - let of_named named = - Named (named, free_variables_named named) - - let create_let_reusing_defining_expr var (t : named t) body = - match t with - | Named (defining_expr, free_vars_of_defining_expr) -> - Let { - var; - defining_expr; - body; - free_vars_of_defining_expr; - free_vars_of_body = free_variables body; - } - - let create_let_reusing_body var defining_expr (t : expr t) = - match t with - | Expr (body, free_vars_of_body) -> - Let { - var; - defining_expr; - body; - free_vars_of_defining_expr = free_variables_named defining_expr; - free_vars_of_body; - } - - let create_let_reusing_both var (t1 : named t) (t2 : expr t) = - match t1, t2 with - | Named (defining_expr, free_vars_of_defining_expr), - Expr (body, free_vars_of_body) -> - Let { - var; - defining_expr; - body; - free_vars_of_defining_expr; - free_vars_of_body; - } - - let expr (t : expr t) = - match t with - | Expr (expr, free_vars) -> Named (Expr expr, free_vars) - - let contents (type a) (t : a t) : a = - match t with - | Expr (expr, _) -> expr - | Named (named, _) -> named - - let free_variables (type a) (t : a t) = - match t with - | Expr (_, free_vars) -> free_vars - | Named (_, free_vars) -> free_vars -end - -let fold_lets_option - t ~init - ~(for_defining_expr:('a -> Variable.t -> named -> 'a * Variable.t * named)) - ~for_last_body - ~(filter_defining_expr:('b -> Variable.t -> named -> Variable.Set.t -> - 'b * Variable.t * named option)) = - let finish ~last_body ~acc ~rev_lets = - let module W = With_free_variables in - let acc, t = - List.fold_left (fun (acc, t) (var, defining_expr) -> - let free_vars_of_body = W.free_variables t in - let acc, var, defining_expr = - filter_defining_expr acc var defining_expr free_vars_of_body - in - let t = - match defining_expr with - | None -> t - | Some defining_expr -> - W.of_expr (W.create_let_reusing_body var defining_expr t) - in - acc, t) - (acc, W.of_expr last_body) - rev_lets - in - W.contents t, acc - in - let rec loop (t : t) ~acc ~rev_lets = - match t with - | Let { var; defining_expr; body; _ } -> - let acc, var, defining_expr = - for_defining_expr acc var defining_expr - in - let rev_lets = (var, defining_expr) :: rev_lets in - loop body ~acc ~rev_lets - | t -> - let last_body, acc = for_last_body acc t in - finish ~last_body ~acc ~rev_lets - in - loop t ~acc:init ~rev_lets:[] - -let free_symbols_helper symbols (named : named) = - match named with - | Symbol symbol - | Read_symbol_field (symbol, _) -> symbols := Symbol.Set.add symbol !symbols - | Set_of_closures set_of_closures -> - Variable.Map.iter (fun _ (function_decl : function_declaration) -> - symbols := Symbol.Set.union function_decl.free_symbols !symbols) - set_of_closures.function_decls.funs - | _ -> () - -let free_symbols expr = - let symbols = ref Symbol.Set.empty in - iter_general ~toplevel:true - (fun (_ : t) -> ()) - (fun (named : named) -> free_symbols_helper symbols named) - (Is_expr expr); - !symbols - -let free_symbols_named named = - let symbols = ref Symbol.Set.empty in - iter_general ~toplevel:true - (fun (_ : t) -> ()) - (fun (named : named) -> free_symbols_helper symbols named) - (Is_named named); - !symbols - -let free_symbols_allocated_constant_helper symbols - (const : constant_defining_value) = - match const with - | Allocated_const _ -> () - | Block (_, fields) -> - List.iter - (function - | (Symbol s : constant_defining_value_block_field) -> - symbols := Symbol.Set.add s !symbols - | (Const _ : constant_defining_value_block_field) -> ()) - fields - | Set_of_closures set_of_closures -> - symbols := Symbol.Set.union !symbols - (free_symbols_named (Set_of_closures set_of_closures)) - | Project_closure (s, _) -> - symbols := Symbol.Set.add s !symbols - -let free_symbols_program (program : program) = - let symbols = ref Symbol.Set.empty in - let rec loop (program : program_body) = - match program with - | Let_symbol (_, const, program) -> - free_symbols_allocated_constant_helper symbols const; - loop program - | Let_rec_symbol (defs, program) -> - List.iter (fun (_, const) -> - free_symbols_allocated_constant_helper symbols const) - defs; - loop program - | Initialize_symbol (_, _, fields, program) -> - List.iter (fun field -> - symbols := Symbol.Set.union !symbols (free_symbols field)) - fields; - loop program - | Effect (expr, program) -> - symbols := Symbol.Set.union !symbols (free_symbols expr); - loop program - | End symbol -> symbols := Symbol.Set.add symbol !symbols - in - (* Note that there is no need to count the [imported_symbols]. *) - loop program.program_body; - !symbols - -let update_body_of_function_declaration (func_decl: function_declaration) - ~body : function_declaration = - { closure_origin = func_decl.closure_origin; - params = func_decl.params; - return_layout = func_decl.return_layout; - alloc_mode = func_decl.alloc_mode; - region = func_decl.region; - body; - free_variables = free_variables body; - free_symbols = free_symbols body; - stub = func_decl.stub; - dbg = func_decl.dbg; - inline = func_decl.inline; - check = func_decl.check; - specialise = func_decl.specialise; - is_a_functor = func_decl.is_a_functor; - poll = func_decl.poll; - } - -let rec check_param_modes mode = function - | [] -> () - | p :: params -> - let m = Parameter.alloc_mode p in - if not (Lambda.sub_mode mode m) then - Misc.fatal_errorf "Nonmonotonic partial modes"; - check_param_modes m params - -let create_function_declaration ~params ~alloc_mode ~region ~body ~stub - ~(return_layout : Lambda.layout) - ~(inline : Lambda.inline_attribute) - ~(specialise : Lambda.specialise_attribute) - ~(check : Lambda.check_attribute) - ~is_a_functor - ~closure_origin ~poll - : function_declaration = - begin match stub, inline with - | true, (Never_inline | Default_inline) - | false, (Never_inline | Default_inline - | Always_inline | Available_inline | Unroll _) -> () - | true, (Always_inline | Available_inline | Unroll _) -> - Misc.fatal_errorf - "Stubs may not be annotated as [Always_inline], \ - [Available_inline] or [Unroll]: %a" - print body - end; - begin match stub, specialise with - | true, (Never_specialise | Default_specialise) - | false, (Never_specialise | Default_specialise | Always_specialise) -> () - | true, Always_specialise -> - Misc.fatal_errorf - "Stubs may not be annotated as [Always_specialise]: %a" - print body - end; - let dbg_origin = Closure_origin.debug_info closure_origin in - check_param_modes alloc_mode params; - { closure_origin; - params; - return_layout; - alloc_mode; - region; - body; - free_variables = free_variables body; - free_symbols = free_symbols body; - stub; - dbg = dbg_origin; - inline; - specialise; - check; - is_a_functor; - poll; - } - -let update_function_declaration_body fun_decl ~body = - let free_variables = free_variables body in - let free_symbols = free_symbols body in - { fun_decl with body; free_variables; free_symbols } - -let create_function_declarations ~is_classic_mode ~funs = - let compilation_unit = Compilation_unit.get_current_exn () in - let set_of_closures_id = Set_of_closures_id.create compilation_unit in - let set_of_closures_origin = - Set_of_closures_origin.create set_of_closures_id - in - { is_classic_mode; - set_of_closures_id; - set_of_closures_origin; - funs; - } - -let create_function_declarations_with_origin - ~is_classic_mode ~funs ~set_of_closures_origin = - let compilation_unit = Compilation_unit.get_current_exn () in - let set_of_closures_id = Set_of_closures_id.create compilation_unit in - { is_classic_mode; - set_of_closures_id; - set_of_closures_origin; - funs; - } - -let update_function_declarations function_decls ~funs = - let is_classic_mode = function_decls.is_classic_mode in - let compilation_unit = Compilation_unit.get_current_exn () in - let set_of_closures_id = Set_of_closures_id.create compilation_unit in - let set_of_closures_origin = function_decls.set_of_closures_origin in - { is_classic_mode; - set_of_closures_id; - set_of_closures_origin; - funs; - } - -let create_function_declarations_with_closures_origin - ~is_classic_mode ~funs ~set_of_closures_origin = - let compilation_unit = Compilation_unit.get_current_exn () in - let set_of_closures_id = Set_of_closures_id.create compilation_unit in - { is_classic_mode; - set_of_closures_id; - set_of_closures_origin; - funs - } - -let import_function_declarations_for_pack function_decls - import_set_of_closures_id import_set_of_closures_origin = - let is_classic_mode = function_decls.is_classic_mode in - let set_of_closures_id = - import_set_of_closures_id function_decls.set_of_closures_id - in - let set_of_closures_origin = - import_set_of_closures_origin function_decls.set_of_closures_origin - in - let funs = function_decls.funs in - { is_classic_mode; - set_of_closures_id; - set_of_closures_origin; - funs; - } - -let create_set_of_closures ~function_decls ~free_vars ~specialised_args - ~direct_call_surrogates = - if !Clflags.flambda_invariant_checks then begin - let all_fun_vars = Variable.Map.keys function_decls.funs in - let expected_free_vars = - Variable.Map.fold (fun _fun_var function_decl expected_free_vars -> - let free_vars = - Variable.Set.diff function_decl.free_variables - (Variable.Set.union (Parameter.Set.vars function_decl.params) - all_fun_vars) - in - Variable.Set.union free_vars expected_free_vars) - function_decls.funs - Variable.Set.empty - in - (* CR-soon pchambart: We do not seem to be able to maintain the - invariant that if a variable is not used inside the closure, it - is not used outside either. This would be a nice property for - better dead code elimination during inline_and_simplify, but it - is not obvious how to ensure that. - - This would be true when the function is known never to have - been inlined. - - Note that something like that may maybe enforceable in - inline_and_simplify, but there is no way to do that on other - passes. - - mshinwell: see CR in Flambda_invariants about this too - *) - let free_vars_domain = Variable.Map.keys free_vars in - if not (Variable.Set.subset expected_free_vars free_vars_domain) then begin - Misc.fatal_errorf "create_set_of_closures: [free_vars] mapping of \ - variables bound by the closure(s) is wrong. (Must map at least \ - %a but only maps %a.)@ \nfunction_decls:@ %a" - Variable.Set.print expected_free_vars - Variable.Set.print free_vars_domain - print_function_declarations function_decls - end; - let all_params = - Variable.Map.fold (fun _fun_var function_decl all_params -> - Variable.Set.union (Parameter.Set.vars function_decl.params) - all_params) - function_decls.funs - Variable.Set.empty - in - let spec_args_domain = Variable.Map.keys specialised_args in - if not (Variable.Set.subset spec_args_domain all_params) then begin - Misc.fatal_errorf "create_set_of_closures: [specialised_args] \ - maps variable(s) that are not parameters of the given function \ - declarations. specialised_args domain=%a all_params=%a \n\ - function_decls:@ %a" - Variable.Set.print spec_args_domain - Variable.Set.print all_params - print_function_declarations function_decls - end - end; - let alloc_mode = - match Variable.Map.data function_decls.funs with - | f :: fs -> - assert (List.for_all (fun (g : function_declaration) -> - Lambda.eq_mode f.alloc_mode g.alloc_mode) fs); - f.alloc_mode - | [] -> assert false - in - { function_decls; - free_vars; - specialised_args; - direct_call_surrogates; - alloc_mode - } - -let used_params function_decl = - Variable.Set.filter - (fun param -> Variable.Set.mem param function_decl.free_variables) - (Parameter.Set.vars function_decl.params) - -let compare_const (c1:const) (c2:const) = - match c1, c2 with - | Int i1, Int i2 -> compare i1 i2 - | Char i1, Char i2 -> Char.compare i1 i2 - | Int _, Char _ -> -1 - | Char _, Int _ -> 1 - -let compare_constant_defining_value_block_field - (c1:constant_defining_value_block_field) - (c2:constant_defining_value_block_field) = - match c1, c2 with - | Symbol s1, Symbol s2 -> Symbol.compare s1 s2 - | Const c1, Const c2 -> compare_const c1 c2 - | Symbol _, Const _ -> -1 - | Const _, Symbol _ -> 1 - -module Constant_defining_value = struct - type t = constant_defining_value - - include Identifiable.Make (struct - type nonrec t = t - - let compare (t1 : t) (t2 : t) = - match t1, t2 with - | Allocated_const c1, Allocated_const c2 -> - Allocated_const.compare c1 c2 - | Block (tag1, fields1), Block (tag2, fields2) -> - let c = Tag.compare tag1 tag2 in - if c <> 0 then c - else - Misc.Stdlib.List.compare compare_constant_defining_value_block_field - fields1 fields2 - | Set_of_closures set1, Set_of_closures set2 -> - Set_of_closures_id.compare set1.function_decls.set_of_closures_id - set2.function_decls.set_of_closures_id - | Project_closure (set1, closure_id1), - Project_closure (set2, closure_id2) -> - let c = Symbol.compare set1 set2 in - if c <> 0 then c - else Closure_id.compare closure_id1 closure_id2 - | Allocated_const _, Block _ -> -1 - | Allocated_const _, Set_of_closures _ -> -1 - | Allocated_const _, Project_closure _ -> -1 - | Block _, Allocated_const _ -> 1 - | Block _, Set_of_closures _ -> -1 - | Block _, Project_closure _ -> -1 - | Set_of_closures _, Allocated_const _ -> 1 - | Set_of_closures _, Block _ -> 1 - | Set_of_closures _, Project_closure _ -> -1 - | Project_closure _, Allocated_const _ -> 1 - | Project_closure _, Block _ -> 1 - | Project_closure _, Set_of_closures _ -> 1 - - let equal t1 t2 = - t1 == t2 || compare t1 t2 = 0 - - let hash = Hashtbl.hash - - let print = print_constant_defining_value - - let output o v = - output_string o (Format.asprintf "%a" print v) - end) -end - -let equal_call_kind (call_kind1 : call_kind) (call_kind2 : call_kind) = - match call_kind1, call_kind2 with - | Indirect, Indirect -> true - | Direct cid1, Direct cid2 -> Closure_id.equal cid1 cid2 - | (Indirect | Direct _), _ -> false - -let equal_specialised_to (spec_to1 : specialised_to) - (spec_to2 : specialised_to) = - Variable.equal spec_to1.var spec_to2.var - && begin - match spec_to1.projection, spec_to2.projection with - | None, None -> true - | Some _, None | None, Some _ -> false - | Some proj1, Some proj2 -> Projection.equal proj1 proj2 - end - && Lambda.equal_layout spec_to1.kind spec_to2.kind - -let compare_project_var = Projection.compare_project_var -let compare_project_closure = Projection.compare_project_closure -let compare_move_within_set_of_closures = - Projection.compare_move_within_set_of_closures - -module Layouts = struct - - type t = { - vars : Lambda.layout Variable.Map.t; - mut_vars : Lambda.layout Mutable_variable.Map.t; - } - - let empty = { - vars = Variable.Map.empty; - mut_vars = Mutable_variable.Map.empty; - } - - let add layouts var layout = - { layouts with vars = Variable.Map.add var layout layouts.vars } - - let add_mut layouts var layout = - { layouts with mut_vars = Mutable_variable.Map.add var layout layouts.mut_vars } - - let find layouts var = - Variable.Map.find var layouts.vars - - let find_mut layouts var = - Mutable_variable.Map.find var layouts.mut_vars - -end - -let rec result_layout_named ~(layouts : Layouts.t) (named : named) = - match named with - | Expr expr -> - result_layout ~layouts expr - | Prim (Popaque, [arg], _) -> - Layouts.find layouts arg - | Prim (Popaque, ([] | _ :: _ :: _), _) -> - assert false - | Prim (p, _, _) -> - Clambda_primitives.result_layout p - | Const (Int _) - | Const (Char _) -> - Lambda.layout_int - | Symbol _ - | Allocated_const _ - | Read_symbol_field _ - | Set_of_closures _ - | Project_closure _ - | Move_within_set_of_closures _ -> - Lambda.layout_any_value - | Project_var { kind; _ } -> - kind - | Read_mutable var -> - Layouts.find_mut layouts var - -and result_layout ~layouts (expr : expr) = - match expr with - | Var v -> - Layouts.find layouts v - | Let { var; defining_expr; body; _ } -> - let layout = result_layout_named ~layouts defining_expr in - let layouts = Layouts.add layouts var layout in - result_layout ~layouts body - | Let_rec (defs, body) -> - let layouts = - List.fold_left (fun layouts (var, _) -> - Layouts.add layouts var Lambda.layout_letrec) - layouts defs - in - result_layout ~layouts body - | Assign _ - | While _ - | For _ -> - Lambda.layout_unit - | Region expr - | Exclave expr -> - result_layout ~layouts expr - | Static_raise _ - | Proved_unreachable -> - Lambda.layout_bottom - | Static_catch (_, _, _, _, result_layout) - | Apply { result_layout } - | Send { result_layout } - | Switch (_, { kind = result_layout }) - | String_switch (_, _, _, result_layout) - | Try_with (_, _, _, result_layout) - | If_then_else (_, _, _, result_layout) -> - result_layout - | Let_mutable { var; contents_kind; body; _ } -> - let layouts = Layouts.add_mut layouts var contents_kind in - result_layout ~layouts body diff --git a/middle_end/flambda/flambda.mli b/middle_end/flambda/flambda.mli deleted file mode 100644 index 7f400b14ae9..00000000000 --- a/middle_end/flambda/flambda.mli +++ /dev/null @@ -1,738 +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"] - -(** Intermediate language used for tree-based analysis and optimization. *) - -(** Whether the callee in a function application is known at compile time. *) -type call_kind = - | Indirect - | Direct of Closure_id.t - -(** Simple constants. ("Structured constants" are rewritten to invocations - of [Pmakeblock] so that they easily take part in optimizations.) *) -type const = - | Int of int - | Char of char - (** [Char] is kept separate from [Int] to improve printing *) - -(** The application of a function to a list of arguments. *) -type apply = { - (* CR-soon mshinwell: rename func -> callee, and - lhs_of_application -> callee *) - func : Variable.t; - args : Variable.t list; - result_layout : Lambda.layout; - kind : call_kind; - dbg : Debuginfo.t; - reg_close : Lambda.region_close; - mode : Lambda.alloc_mode; - inlined : Lambda.inlined_attribute; - (** Instructions from the source code as to whether the callee should - be inlined. *) - specialise : Lambda.specialise_attribute; - (** Instructions from the source code as to whether the callee should - be specialised. *) - probe : Lambda.probe; - (** Instruction from the source as to whether the call is a probe *) -} - -(** The update of a mutable variable. Mutable variables are distinct from - immutable variables in Flambda. *) -type assign = { - being_assigned : Mutable_variable.t; - new_value : Variable.t; -} - -(** The invocation of a method. *) -type send = { - kind : Lambda.meth_kind; - meth : Variable.t; - obj : Variable.t; - args : Variable.t list; - dbg : Debuginfo.t; - reg_close : Lambda.region_close; - mode : Lambda.alloc_mode; - result_layout : Lambda.layout; -} - -(** For details on these types, see projection.mli. *) -type project_closure = Projection.project_closure -type move_within_set_of_closures = Projection.move_within_set_of_closures -type project_var = Projection.project_var - -(** See [free_vars] and [specialised_args], below. *) -(* CR-someday mshinwell: move to separate module and make [Identifiable]. - (Or maybe nearly Identifiable; having a special map that enforces invariants - might be good.) *) -type specialised_to = { - var : Variable.t; - (** The "outer variable". *) - projection : Projection.t option; - (** The [projecting_from] value (see projection.mli) of any [projection] - must be another free variable or specialised argument (depending on - whether this record type is involved in [free_vars] or - [specialised_args] respectively) in the same set of closures. - As such, this field describes a relation of projections between - either the [free_vars] or the [specialised_args]. *) - kind : Lambda.layout; -} - -(** Flambda terms are partitioned in a pseudo-ANF manner; many terms are - required to be [let]-bound. This in particular ensures there is always - a variable name for an expression that may be lifted out (for example - if it is found to be constant). - Note: All bound variables in Flambda terms must be distinct. - [Flambda_invariants] verifies this. *) -type t = - | Var of Variable.t - | Let of let_expr - | Let_mutable of let_mutable - | Let_rec of (Variable.t * named) list * t - (** CR-someday lwhite: give Let_rec the same fields as Let. *) - | Apply of apply - | Send of send - | Assign of assign - | If_then_else of Variable.t * t * t * Lambda.layout - | Switch of Variable.t * switch - | String_switch of Variable.t * (string * t) list * t option - * Lambda.layout - (** Restrictions on [Lambda.Lstringswitch] also apply to [String_switch]. *) - | Static_raise of Static_exception.t * Variable.t list - | Static_catch of Static_exception.t * ( Variable.t * Lambda.layout ) list * t * t * Lambda.layout - | Try_with of t * Variable.t * t * Lambda.layout - | While of t * t - | For of for_loop - | Region of t - | Exclave of t - | Proved_unreachable - -(** Values of type [named] will always be [let]-bound to a [Variable.t]. *) -and named = - | Symbol of Symbol.t - | Const of const - | Allocated_const of Allocated_const.t - | Read_mutable of Mutable_variable.t - | Read_symbol_field of Symbol.t * int - (** During the lifting of [let] bindings to [program] constructions after - closure conversion, we generate symbols and their corresponding - definitions (which may or may not be constant), together with field - accesses to such symbols. We would like it to be the case that such - field accesses are simplified to the relevant component of the - symbol concerned. (The rationale is to generate efficient code and - share constants as expected: see e.g. tests/asmcomp/staticalloc.ml.) - The components of the symbol would be identified by other symbols. - This sort of access pattern is feasible because the top-level structure - of symbols is statically allocated and fixed at compile time. - It may seem that [Prim (Pfield, ...)] expressions could be used to - perform the field accesses. However for simplicity, to avoid having to - keep track of properties of individual fields of blocks, - [Inconstant_idents] never deems a [Prim (Pfield, ...)] expression to be - constant. This would in general prevent field accesses to symbols from - being simplified in the way we would like, since [Lift_constants] would - not assign new symbols (i.e. the things we would like to simplify to) - to the various projections from the symbols in question. - To circumvent this problem we use [Read_symbol_field] when generating - projections from the top level of symbols. Owing to the properties of - symbols described above, such expressions may be eligible for declaration - as constant by [Inconstant_idents] (and thus themselves lifted to another - symbol), without any further complication. - [Read_symbol_field] may only be used when the definition of the symbol - is in scope in the [program]. For external unresolved symbols, [Pfield] - may still be used; it will be changed to [Read_symbol_field] by - [Inline_and_simplify] when (and if) the symbol is imported. *) - | Set_of_closures of set_of_closures - | Project_closure of project_closure - | Move_within_set_of_closures of move_within_set_of_closures - | Project_var of project_var - | Prim of Clambda_primitives.primitive * Variable.t list * Debuginfo.t - | Expr of t (** ANF escape hatch. *) - -(* CR-someday mshinwell: use [letcont]-style construct to remove e.g. - [While] and [For]. *) -(* CR-someday mshinwell: try to produce a tighter definition of a "switch" - (and translate to that earlier) so that middle- and back-end code for - these can be reduced. *) -(* CR-someday mshinwell: remove [Expr], but to do this easily would probably - require a continuation-binding construct. *) -(* CR-someday mshinwell: Since we lack expression identifiers on every term, - we should probably introduce [Mutable_var] into [named] if we introduce - more complicated analyses on these in the future. Alternatively, maybe - consider removing mutable variables altogether. *) - -and let_expr = private { - var : Variable.t; - defining_expr : named; - body : t; - (* CR-someday mshinwell: we could consider having these be keys into some - kind of global cache, to reduce memory usage. *) - free_vars_of_defining_expr : Variable.Set.t; - (** A cache of the free variables in the defining expression of the [let]. *) - free_vars_of_body : Variable.Set.t; - (** A cache of the free variables of the body of the [let]. This is an - important optimization. *) -} - -and let_mutable = { - var : Mutable_variable.t; - initial_value : Variable.t; - contents_kind : Lambda.layout; - body : t; -} - -(** 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 ([Move_within_set_of_closures]) 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. -*) -and set_of_closures = private { - function_decls : function_declarations; - (* CR-soon mshinwell: consider renaming [free_vars]. Also, it's still really - confusing which side of this map to use when. "Vars bound by the - closure" is the domain. - Another example of when this is confusing: - let bound_vars_approx = - Variable.Map.map (Env.find_approx env) set.free_vars - in - in [Build_export_info]. *) - (* CR-soon mshinwell: I'd like to arrange these maps so that it's impossible - to put invalid projection information into them (in particular, so that - we enforce that the relation stays within the domain of the map). *) - free_vars : specialised_to Variable.Map.t; - (** Mapping from all variables free in the body of the [function_decls] to - variables in scope at the definition point of the [set_of_closures]. - The domain of this map is sometimes known as the "variables bound by - the closure". *) - specialised_args : specialised_to Variable.Map.t; - (** Parameters whose corresponding arguments are known to always alias a - particular value. These are the only parameters that may, during - [Inline_and_simplify], have non-unknown approximations. - - An argument may only be specialised to a variable in the scope of the - corresponding set of closures declaration. Usually, that variable - itself also appears in the position of the specialised argument at - all call sites of the function. However it may also be the case (for - example in code generated as a result of [Augment_specialised_args]) - that the various call sites of such a function have differing - variables in the position of the specialised argument. This is - permissible *so long as it is certain they all alias the same value*. - Great care must be taken in transformations that result in this - situation since there are no invariant checks for correctness. - - As an example, supposing all call sites of f are represented here: - [let x = ... in - let f a b c = ... in - let y = ... in - f x y 1; - f x y 1] - the specialised arguments of f can (but does not necessarily) contain - the association [a] -> [x], but cannot contain [b] -> [y] because [f] - is not in the scope of [y]. If f were the recursive function - [let rec f a b c = f a 1 2 in], [a] -> [x] would still be a valid - specialised argument because all recursive calls maintain the invariant. - - This information is used for optimization purposes, if such a binding is - known, it is possible to specialise the body of the function according - to its parameter. This is usually introduced when specialising a - recursive function, for instance. - [let rec map f = function - | [] -> [] - | h :: t -> f h :: map f t - let map_succ l = - let succ x = x + 1 in - map succ l] - [map] can be duplicated in [map_succ] to be specialised for the argument - [f]. This will result in - [let map_succ l = - let succ x = x + 1 in - let rec map f = function - | [] -> [] - | h :: t -> f h :: map f t in - map succ l] - with map having [f] -> [succ] in its [specialised_args] field. - - Specialised argument information for arguments that are used must - never be erased. This ensures that specialised arguments whose - approximations describe closures maintain those approximations, which - is essential to transport the closure freshening information to the - point of use (e.g. a [Project_var] from such an argument). - *) - direct_call_surrogates : Variable.t Variable.Map.t; - (** If [direct_call_surrogates] maps [fun_var1] to [fun_var2] then direct - calls to [fun_var1] should be redirected to [fun_var2]. This is used - to reduce the overhead of transformations that introduce wrapper - functions (which will be inlined at direct call sites, but will - penalise indirect call sites). - [direct_call_surrogates] may not be transitively closed. *) - alloc_mode : Lambda.alloc_mode; - (** Whether these closures are allocated on the heap or locally. *) -} - -and function_declarations = private { - is_classic_mode: bool; - (** Indicates whether this [function_declarations] was compiled - with -Oclassic. *) - set_of_closures_id : Set_of_closures_id.t; - (** An identifier (unique across all Flambda trees currently in memory) - of the set of closures associated with this set of function - declarations. *) - set_of_closures_origin : Set_of_closures_origin.t; - (** An identifier of the original set of closures on which this set of - function declarations is based. Used to prevent different - specialisations of the same functions from being inlined/specialised - within each other. *) - funs : function_declaration Variable.Map.t; - (** The function(s) defined by the set of function declarations. The - keys of this map are often referred to in the code as "fun_var"s. *) -} - -and function_declaration = private { - closure_origin: Closure_origin.t; - params : Parameter.t list; - return_layout : Lambda.layout; - alloc_mode : Lambda.alloc_mode; - region : bool; - body : t; - (* CR-soon mshinwell: inconsistent naming free_variables/free_vars here and - above *) - free_variables : Variable.Set.t; - (** All variables free in the *body* of the function. For example, a - variable that is bound as one of the function's parameters will still - be included in this set. This field is present as an optimization. *) - free_symbols : Symbol.Set.t; - (** All symbols that occur in the function's body. (Symbols can never be - bound in a function's body; the only thing that binds symbols is the - [program] constructions below.) *) - stub : bool; - (** 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. *) - dbg : Debuginfo.t; - (** Debug info for the function declaration. *) - inline : Lambda.inline_attribute; - (** Inlining requirements from the source code. *) - specialise : Lambda.specialise_attribute; - (** Specialising requirements from the source code. *) - check : Lambda.check_attribute; - (** Check function properties requirements from the source code *) - is_a_functor : bool; - (** Whether the function is known definitively to be a functor. *) - poll: Lambda.poll_attribute; - (** Behaviour for polls *) -} - -(** Equivalent to the similar type in [Lambda]. *) -and switch = { - numconsts : Numbers.Int.Set.t; (** Integer cases *) - consts : (int * t) list; (** Integer cases *) - numblocks : Numbers.Int.Set.t; (** Number of tag block cases *) - blocks : (int * t) list; (** Tag block cases *) - failaction : t option; (** Action to take if none matched *) - kind : Lambda.layout -} - -(** Equivalent to the similar type in [Lambda]. *) -and for_loop = { - bound_var : Variable.t; - from_value : Variable.t; - to_value : Variable.t; - direction : Asttypes.direction_flag; - body : t -} - -(** Like a subset of [Flambda.named], except that instead of [Variable.t]s we - have [Symbol.t]s, and everything is a constant (i.e. with a fixed value - known at compile time). Values of this type describe constants that will - be directly assigned to symbols in the object file (see below). *) -and constant_defining_value = - | Allocated_const of Allocated_const.t - (** A single constant. These are never "simple constants" (type [const]) - but instead more complicated constructions. *) - | Block of Tag.t * constant_defining_value_block_field list - (** A pre-allocated block full of constants (either simple constants - or references to other constants, see below). *) - | Set_of_closures of set_of_closures - (** A closed (and thus constant) set of closures. (That is to say, - [free_vars] must be empty.) *) - | Project_closure of Symbol.t * Closure_id.t - (** Selection of one closure from a constant set of closures. - Analogous to the equivalent operation on expressions. *) - -and constant_defining_value_block_field = - | Symbol of Symbol.t - | Const of const - -module Constant_defining_value : - Identifiable.S with type t = constant_defining_value - -type expr = t - -(** A "program" is the contents of one compilation unit. It describes the - various values that are assigned to symbols (and in some cases fields of - such symbols) in the object file. As such, it is closely related to - the compilation of toplevel modules. *) -type program_body = - | Let_symbol of Symbol.t * constant_defining_value * program_body - (** Define the given symbol to have the given constant value. *) - | Let_rec_symbol of (Symbol.t * constant_defining_value) list * program_body - (** As for [Let_symbol], but recursive. This is needed to treat examples - like this, where a constant set of closures is lifted to toplevel: - - let rec f x = f x - - After lifting this produces (in pseudo-Flambda): - - Let_rec_symbol set_of_closures_symbol = - (Set_of_closures { f x -> - let applied_function = Symbol f_closure in - Apply (applied_function, x) }) - and f_closure = Project_closure (set_of_closures_symbol, f) - - Use of [Let_rec_symbol], by virtue of the special handling in - [Inline_and_simplify.define_let_rec_symbol_approx], enables the - approximation of the set of closures to be present in order to - correctly simplify the [Project_closure] construction. (See - [Inline_and_simplify.simplify_project_closure] for that part.) *) - | Initialize_symbol of Symbol.t * Tag.t * t list * program_body - (** Define the given symbol as a constant block of the given size and - tag; but with a possibly non-constant initializer. The initializer - will be executed at most once (from the entry point of the compilation - unit). *) - | Effect of t * program_body - (** Cause the given expression, which may have a side effect, to be - executed. The resulting value is discarded. [Effect] constructions - are never re-ordered. *) - | End of Symbol.t - (** [End] accepts the root symbol: the only symbol that can never be - eliminated. *) - -type program = { - imported_symbols : Symbol.Set.t; - program_body : program_body; -} - -(** Compute the free variables of a term. (This is O(1) for [Let]s). - If [ignore_uses_as_callee], all free variables inside [Apply] expressions - are ignored. Likewise [ignore_uses_in_project_var] for [Project_var] - expressions. -*) -val free_variables - : ?ignore_uses_as_callee:unit - -> ?ignore_uses_as_argument:unit - -> ?ignore_uses_in_project_var:unit - -> t - -> Variable.Set.t - -(** Compute the free variables of a named expression. *) -val free_variables_named - : ?ignore_uses_in_project_var:unit - -> named - -> Variable.Set.t - -(** Compute _all_ variables occurring inside an expression. *) -val used_variables - : ?ignore_uses_as_callee:unit - -> ?ignore_uses_as_argument:unit - -> ?ignore_uses_in_project_var:unit - -> t - -> Variable.Set.t - -(** Compute _all_ variables occurring inside a named expression. *) -val used_variables_named - : ?ignore_uses_in_project_var:unit - -> named - -> Variable.Set.t - -val free_symbols : expr -> Symbol.Set.t - -val free_symbols_named : named -> Symbol.Set.t - -val free_symbols_program : program -> Symbol.Set.t - -(** Used to avoid exceeding the stack limit when handling expressions with - multiple consecutive nested [Let]-expressions. This saves rewriting large - simplification functions in CPS. This function provides for the - rewriting or elimination of expressions during the fold. *) -val fold_lets_option - : t - -> init:'a - -> for_defining_expr:('a -> Variable.t -> named -> 'a * Variable.t * named) - -> for_last_body:('a -> t -> t * 'b) - (* CR-someday mshinwell: consider making [filter_defining_expr] - optional *) - -> filter_defining_expr:('b -> Variable.t -> named -> Variable.Set.t -> - 'b * Variable.t * named option) - -> t * 'b - -(** Like [fold_lets_option], but just a map. *) -val map_lets - : t - -> for_defining_expr:(Variable.t -> named -> named) - -> for_last_body:(t -> t) - -> after_rebuild:(t -> t) - -> t - -(** Like [map_lets], but just an iterator. *) -val iter_lets - : t - -> for_defining_expr:(Variable.t -> named -> unit) - -> for_last_body:(t -> unit) - -> for_each_let:(t -> unit) - -> unit - -(** Creates a [Let] expression. (This computes the free variables of the - defining expression and the body.) *) -val create_let : Variable.t -> named -> t -> t - -(** Apply the specified function [f] to the defining expression of the given - [Let]-expression, returning a new [Let]. *) -val map_defining_expr_of_let : let_expr -> f:(named -> named) -> t - -(** A module for the manipulation of terms where the recomputation of free - variable sets is to be kept to a minimum. *) -module With_free_variables : sig - type 'a t - - (** O(1) time. *) - val of_defining_expr_of_let : let_expr -> named t - - (** O(1) time. *) - val of_body_of_let : let_expr -> expr t - - (** Takes the time required to calculate the free variables of the given - term (proportional to the size of the term, except that the calculation - for [Let] is O(1)). *) - val of_expr : expr -> expr t - - val of_named : named -> named t - - (** Takes the time required to calculate the free variables of the given - [expr]. *) - val create_let_reusing_defining_expr - : Variable.t - -> named t - -> expr - -> expr - - (** Takes the time required to calculate the free variables of the given - [named]. *) - val create_let_reusing_body - : Variable.t - -> named - -> expr t - -> expr - - (** O(1) time. *) - val create_let_reusing_both - : Variable.t - -> named t - -> expr t - -> expr - - (** The equivalent of the [Expr] constructor. *) - val expr : expr t -> named t - - val contents : 'a t -> 'a - - (** O(1) time. *) - val free_variables : _ t -> Variable.Set.t -end - -(** Create a function declaration. This calculates the free variables and - symbols occurring in the specified [body]. *) -val create_function_declaration - : params:Parameter.t list - -> alloc_mode:Lambda.alloc_mode - -> region:bool - -> body:t - -> stub:bool - -> return_layout:Lambda.layout - -> inline:Lambda.inline_attribute - -> specialise:Lambda.specialise_attribute - -> check:Lambda.check_attribute - -> is_a_functor:bool - -> closure_origin:Closure_origin.t - -> poll:Lambda.poll_attribute - -> function_declaration - -(** Create a function declaration based on another function declaration *) -val update_function_declaration_body - : function_declaration - -> body:t - -> function_declaration - -(** Create a set of function declarations given the individual declarations. *) -val create_function_declarations - : is_classic_mode:bool - -> funs:function_declaration Variable.Map.t - -> function_declarations - -(** Create a set of function declarations with a given set of closures - origin. *) -val create_function_declarations_with_origin - : is_classic_mode:bool - -> funs:function_declaration Variable.Map.t - -> set_of_closures_origin:Set_of_closures_origin.t - -> function_declarations - -(** Change only the code of a function declaration. *) -val update_body_of_function_declaration - : function_declaration - -> body:expr - -> function_declaration - -(** Create a set of function declarations based on another set of function - declarations. *) -val update_function_declarations - : function_declarations - -> funs:function_declaration Variable.Map.t - -> function_declarations - -val create_function_declarations_with_closures_origin - : is_classic_mode: bool - -> funs:function_declaration Variable.Map.t - -> set_of_closures_origin:Set_of_closures_origin.t - -> function_declarations - -val import_function_declarations_for_pack - : function_declarations - -> (Set_of_closures_id.t -> Set_of_closures_id.t) - -> (Set_of_closures_origin.t -> Set_of_closures_origin.t) - -> function_declarations - -(** Create a set of closures. Checks are made to ensure that [free_vars] - and [specialised_args] are reasonable. *) -val create_set_of_closures - : function_decls:function_declarations - -> free_vars:specialised_to Variable.Map.t - -> specialised_args:specialised_to Variable.Map.t - -> direct_call_surrogates:Variable.t Variable.Map.t - -> set_of_closures - -(** Given a function declaration, find which of its parameters (if any) - are used in the body. *) -val used_params : function_declaration -> Variable.Set.t - -type maybe_named = - | Is_expr of t - | Is_named of named - -(** This function is designed for the internal use of [Flambda_iterators]. - See that module for iterators to be used over Flambda terms. *) -val iter_general - : toplevel:bool - -> (t -> unit) - -> (named -> unit) - -> maybe_named - -> unit - -val print : Format.formatter -> t -> unit - -val print_named : Format.formatter -> named -> unit - -val print_program : Format.formatter -> program -> unit - -val print_const : Format.formatter -> const -> unit - -val print_constant_defining_value - : Format.formatter - -> constant_defining_value - -> unit - -val print_function_declaration - : Format.formatter - -> Variable.t * function_declaration - -> unit - -val print_function_declarations - : Format.formatter - -> function_declarations - -> unit - -val print_project_closure - : Format.formatter - -> project_closure - -> unit - -val print_move_within_set_of_closures - : Format.formatter - -> move_within_set_of_closures - -> unit - -val print_project_var - : Format.formatter - -> project_var - -> unit - -val print_set_of_closures - : Format.formatter - -> set_of_closures - -> unit - -val print_specialised_to - : Format.formatter - -> specialised_to - -> unit - -val equal_call_kind - : call_kind - -> call_kind - -> bool - -val equal_specialised_to - : specialised_to - -> specialised_to - -> bool - -val compare_const - : const - -> const - -> int - -val compare_project_var : project_var -> project_var -> int - -val compare_move_within_set_of_closures - : move_within_set_of_closures - -> move_within_set_of_closures - -> int - -val compare_project_closure : project_closure -> project_closure -> int - -module Layouts : sig - type t - val empty : t - val add : t -> Variable.t -> Lambda.layout -> t - val add_mut : t -> Mutable_variable.t -> Lambda.layout -> t - val find : t -> Variable.t -> Lambda.layout - val find_mut : t -> Mutable_variable.t -> Lambda.layout -end - -val result_layout : layouts:Layouts.t -> expr -> Lambda.layout -val result_layout_named : layouts:Layouts.t -> named -> Lambda.layout diff --git a/middle_end/flambda/flambda_invariants.ml b/middle_end/flambda/flambda_invariants.ml deleted file mode 100644 index 37520f2e7f2..00000000000 --- a/middle_end/flambda/flambda_invariants.ml +++ /dev/null @@ -1,818 +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-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type flambda_kind = - | Normal - | Lifted - -(* Explicit "ignore" functions. We name every pattern variable, avoiding - underscores, to try to avoid accidentally failing to handle (for example) - a particular variable. - We also avoid explicit record field access during the checking functions, - preferring instead to use exhaustive record matches. -*) -(* CR-someday pchambart: for sum types, we should probably add an exhaustive - pattern in ignores functions to be reminded if a type change *) -let already_added_bound_variable_to_env (_ : Variable.t) = () -let will_traverse_named_expression_later (_ : Flambda.named) = () -let ignore_variable (_ : Variable.t) = () -let ignore_call_kind (_ : Flambda.call_kind) = () -let ignore_debuginfo (_ : Debuginfo.t) = () -let ignore_meth_kind (_ : Lambda.meth_kind) = () -let ignore_int (_ : int) = () -let ignore_int_set (_ : Numbers.Int.Set.t) = () -let ignore_bool (_ : bool) = () -let ignore_string (_ : string) = () -let ignore_static_exception (_ : Static_exception.t) = () -let ignore_direction_flag (_ : Asttypes.direction_flag) = () -let ignore_primitive ( _ : Clambda_primitives.primitive) = () -let ignore_const (_ : Flambda.const) = () -let ignore_allocated_const (_ : Allocated_const.t) = () -let ignore_set_of_closures_id (_ : Set_of_closures_id.t) = () -let ignore_set_of_closures_origin (_ : Set_of_closures_origin.t) = () -let ignore_closure_id (_ : Closure_id.t) = () -let ignore_var_within_closure (_ : Var_within_closure.t) = () -let ignore_tag (_ : Tag.t) = () -let ignore_inlined_attribute (_ : Lambda.inlined_attribute) = () -let ignore_specialise_attribute (_ : Lambda.specialise_attribute) = () -let ignore_probe (_ : Lambda.probe) = () -let ignore_layout (_ : Lambda.layout) = () - -exception Binding_occurrence_not_from_current_compilation_unit of Variable.t -exception Mutable_binding_occurrence_not_from_current_compilation_unit of - Mutable_variable.t -exception Binding_occurrence_of_variable_already_bound of Variable.t -exception Binding_occurrence_of_mutable_variable_already_bound of - Mutable_variable.t -exception Binding_occurrence_of_symbol_already_bound of Symbol.t -exception Unbound_variable of Variable.t -exception Unbound_mutable_variable of Mutable_variable.t -exception Unbound_symbol of Symbol.t -exception Vars_in_function_body_not_bound_by_closure_or_params of - Variable.Set.t * Flambda.set_of_closures * Variable.t -exception Function_decls_have_overlapping_parameters of Variable.Set.t -exception Specialised_arg_that_is_not_a_parameter of Variable.t -exception Projection_must_be_a_free_var of Projection.t -exception Projection_must_be_a_specialised_arg of Projection.t -exception Free_variables_set_is_lying of - Variable.t * Variable.Set.t * Variable.Set.t * Flambda.function_declaration -exception Set_of_closures_free_vars_map_has_wrong_range of Variable.Set.t -exception Static_exception_not_caught of Static_exception.t -exception Static_exception_caught_in_multiple_places of Static_exception.t -exception Sequential_logical_operator_primitives_must_be_expanded of - Clambda_primitives.primitive -exception Var_within_closure_bound_multiple_times of Var_within_closure.t -exception Declared_closure_from_another_unit of Compilation_unit.t -exception Closure_id_is_bound_multiple_times of Closure_id.t -exception Set_of_closures_id_is_bound_multiple_times of Set_of_closures_id.t -exception Unbound_closure_ids of Closure_id.Set.t -exception Unbound_vars_within_closures of Var_within_closure.Set.t -exception Move_to_a_closure_not_in_the_free_variables - of Variable.t * Variable.Set.t - -exception Flambda_invariants_failed - -(* CR-someday mshinwell: We should make "direct applications should not have - overapplication" be an invariant throughout. At the moment I think this is - only true after [Inline_and_simplify] has split overapplications. *) - -(* CR-someday mshinwell: What about checks for shadowed variables and - symbols? *) - -let variable_and_symbol_invariants (program : Flambda.program) = - let all_declared_variables = ref Variable.Set.empty in - let declare_variable var = - if Variable.Set.mem var !all_declared_variables then - raise (Binding_occurrence_of_variable_already_bound var); - all_declared_variables := Variable.Set.add var !all_declared_variables - in - let declare_variables vars = - Variable.Set.iter declare_variable vars - in - let all_declared_mutable_variables = ref Mutable_variable.Set.empty in - let declare_mutable_variable mut_var = - if Mutable_variable.Set.mem mut_var !all_declared_mutable_variables then - raise (Binding_occurrence_of_mutable_variable_already_bound mut_var); - all_declared_mutable_variables := - Mutable_variable.Set.add mut_var !all_declared_mutable_variables - in - let add_binding_occurrence (var_env, mut_var_env, sym_env) var = - let compilation_unit = Compilation_unit.get_current_exn () in - if not (Variable.in_compilation_unit var compilation_unit) then - raise (Binding_occurrence_not_from_current_compilation_unit var); - declare_variable var; - Variable.Set.add var var_env, mut_var_env, sym_env - in - let add_mutable_binding_occurrence (var_env, mut_var_env, sym_env) mut_var = - let compilation_unit = Compilation_unit.get_current_exn () in - if not (Mutable_variable.in_compilation_unit mut_var compilation_unit) then - raise (Mutable_binding_occurrence_not_from_current_compilation_unit - mut_var); - declare_mutable_variable mut_var; - var_env, Mutable_variable.Set.add mut_var mut_var_env, sym_env - in - let add_binding_occurrence_of_symbol (var_env, mut_var_env, sym_env) sym = - if Symbol.Set.mem sym sym_env then - raise (Binding_occurrence_of_symbol_already_bound sym) - else - var_env, mut_var_env, Symbol.Set.add sym sym_env - in - let add_binding_occurrences env vars = - List.fold_left (fun env var -> add_binding_occurrence env var) env vars - in - let check_variable_is_bound (var_env, _, _) var = - if not (Variable.Set.mem var var_env) then raise (Unbound_variable var) - in - let check_symbol_is_bound (_, _, sym_env) sym = - if not (Symbol.Set.mem sym sym_env) then raise (Unbound_symbol sym) - in - let check_variables_are_bound env vars = - List.iter (check_variable_is_bound env) vars - in - let check_mutable_variable_is_bound (_, mut_var_env, _) mut_var = - if not (Mutable_variable.Set.mem mut_var mut_var_env) then begin - raise (Unbound_mutable_variable mut_var) - end - in - let rec loop env (flam : Flambda.t) = - match flam with - (* Expressions that can bind [Variable.t]s: *) - | Let { var; defining_expr; body; _ } -> - loop_named env defining_expr; - loop (add_binding_occurrence env var) body - | Let_mutable { var = mut_var; initial_value = var; - body; contents_kind } -> - ignore_layout contents_kind; - check_variable_is_bound env var; - loop (add_mutable_binding_occurrence env mut_var) body - | Let_rec (defs, body) -> - let env = - List.fold_left (fun env (var, def) -> - will_traverse_named_expression_later def; - add_binding_occurrence env var) - env defs - in - List.iter (fun (var, def) -> - already_added_bound_variable_to_env var; - loop_named env def) defs; - loop env body - | For { bound_var; from_value; to_value; direction; body; } -> - ignore_direction_flag direction; - check_variable_is_bound env from_value; - check_variable_is_bound env to_value; - loop (add_binding_occurrence env bound_var) body - | Static_catch (static_exn, vars, body, handler, kind) -> - ignore_static_exception static_exn; - ignore_layout kind; - loop env body; - loop (add_binding_occurrences env (List.map fst vars)) handler - | Try_with (body, var, handler, kind) -> - loop env body; - ignore_layout kind; - loop (add_binding_occurrence env var) handler - (* Everything else: *) - | Var var -> check_variable_is_bound env var - | Apply { func; args; kind; dbg; inlined; specialise; probe; - reg_close = (Rc_close_at_apply|Rc_normal|Rc_nontail); - mode = (Alloc_heap|Alloc_local); result_layout } -> - check_variable_is_bound env func; - check_variables_are_bound env args; - ignore_call_kind kind; - ignore_debuginfo dbg; - ignore_inlined_attribute inlined; - ignore_specialise_attribute specialise; - ignore_probe probe; - ignore_layout result_layout - | Assign { being_assigned; new_value; } -> - check_mutable_variable_is_bound env being_assigned; - check_variable_is_bound env new_value - | Send { kind; meth; obj; args; dbg; - reg_close = (Rc_normal | Rc_close_at_apply | Rc_nontail); - mode = (Alloc_heap | Alloc_local); result_layout; } -> - ignore_meth_kind kind; - check_variable_is_bound env meth; - check_variable_is_bound env obj; - check_variables_are_bound env args; - ignore_debuginfo dbg; - ignore_layout result_layout - | If_then_else (cond, ifso, ifnot, kind) -> - check_variable_is_bound env cond; - ignore_layout kind; - loop env ifso; - loop env ifnot - | Switch (arg, { numconsts; consts; numblocks; blocks; failaction; kind }) -> - check_variable_is_bound env arg; - ignore_int_set numconsts; - ignore_int_set numblocks; - ignore_layout kind; - List.iter (fun (n, e) -> - ignore_int n; - loop env e) - (consts @ blocks); - Option.iter (loop env) failaction - | String_switch (arg, cases, e_opt, kind) -> - check_variable_is_bound env arg; - List.iter (fun (label, case) -> - ignore_string label; - loop env case) - cases; - ignore_layout kind; - Option.iter (loop env) e_opt - | Static_raise (static_exn, es) -> - ignore_static_exception static_exn; - List.iter (check_variable_is_bound env) es - | While (e1, e2) -> - loop env e1; - loop env e2 - | Region e -> - loop env e - | Exclave e -> - loop env e - | Proved_unreachable -> () - and loop_named env (named : Flambda.named) = - match named with - | Symbol symbol -> check_symbol_is_bound env symbol - | Const const -> ignore_const const - | Allocated_const const -> ignore_allocated_const const - | Read_mutable mut_var -> - check_mutable_variable_is_bound env mut_var - | Read_symbol_field (symbol, index) -> - check_symbol_is_bound env symbol; - assert (index >= 0) (* CR-someday mshinwell: add proper error *) - | Set_of_closures set_of_closures -> - loop_set_of_closures env set_of_closures - | Project_closure { set_of_closures; closure_id; } -> - check_variable_is_bound env set_of_closures; - ignore_closure_id closure_id - | Move_within_set_of_closures { closure; start_from; move_to; } -> - check_variable_is_bound env closure; - ignore_closure_id start_from; - ignore_closure_id move_to; - | Project_var { closure; closure_id; var; kind } -> - check_variable_is_bound env closure; - ignore_closure_id closure_id; - ignore_var_within_closure var; - ignore_layout kind - | Prim (prim, args, dbg) -> - ignore_primitive prim; - check_variables_are_bound env args; - ignore_debuginfo dbg - | Expr expr -> - loop env expr - and loop_set_of_closures env - ({ Flambda.function_decls; free_vars; specialised_args; - direct_call_surrogates = _; alloc_mode = _ } as set_of_closures) = - (* CR-soon mshinwell: check [direct_call_surrogates] *) - let { Flambda. is_classic_mode; - set_of_closures_id; set_of_closures_origin; funs; } = - function_decls - in - ignore (is_classic_mode : bool); - ignore_set_of_closures_id set_of_closures_id; - ignore_set_of_closures_origin set_of_closures_origin; - let functions_in_closure = Variable.Map.keys funs in - let variables_in_closure = - Variable.Map.fold (fun var (var_in_closure : Flambda.specialised_to) - variables_in_closure -> - (* [var] may occur in the body, but will effectively be renamed - to [var_in_closure], so the latter is what we check to make - sure it's bound. *) - ignore_variable var; - check_variable_is_bound env var_in_closure.var; - Variable.Set.add var variables_in_closure) - free_vars Variable.Set.empty - in - let all_params, all_free_vars = - Variable.Map.fold (fun fun_var function_decl acc -> - let all_params, all_free_vars = acc in - (* CR-soon mshinwell: check function_decl.all_symbols *) - let { Flambda.params; body; free_variables; stub; dbg; _ } = - function_decl - in - assert (Variable.Set.mem fun_var functions_in_closure); - ignore_bool stub; - ignore_debuginfo dbg; - (* Check that [free_variables], which is only present as an - optimization, is not lying. *) - let free_variables' = Flambda.free_variables body in - if not (Variable.Set.subset free_variables' free_variables) then - raise (Free_variables_set_is_lying (fun_var, - free_variables, free_variables', function_decl)); - (* Check that every variable free in the body of the function is - bound by either the set of closures or the parameter list. *) - let acceptable_free_variables = - Variable.Set.union - (Variable.Set.union variables_in_closure functions_in_closure) - (Parameter.Set.vars params) - in - let bad = - Variable.Set.diff free_variables acceptable_free_variables - in - if not (Variable.Set.is_empty bad) then begin - raise (Vars_in_function_body_not_bound_by_closure_or_params - (bad, set_of_closures, fun_var)) - end; - (* Check that parameters are unique across all functions in the - declaration. *) - let old_all_params_size = Variable.Set.cardinal all_params in - let params = Parameter.Set.vars params in - let params_size = Variable.Set.cardinal params in - let all_params = Variable.Set.union all_params params in - let all_params_size = Variable.Set.cardinal all_params in - if all_params_size <> old_all_params_size + params_size then begin - raise (Function_decls_have_overlapping_parameters all_params) - end; - (* Check that parameters and function variables are not - bound somewhere else in the program *) - declare_variables params; - declare_variable fun_var; - (* Check that the body of the functions is correctly structured *) - let body_env = - let (var_env, _, sym_env) = env in - let var_env = - Variable.Set.fold (fun var -> Variable.Set.add var) - free_variables var_env - in - (* Mutable variables cannot be captured by closures *) - let mut_env = Mutable_variable.Set.empty in - (var_env, mut_env, sym_env) - in - loop body_env body; - all_params, Variable.Set.union free_variables all_free_vars) - funs (Variable.Set.empty, Variable.Set.empty) - in - (* CR-soon pchambart: This is not a property that we can certainly - ensure. - If the function get inlined, it is possible for the inlined version - to still use that variable. To be able to ensure that, we need to - also ensure that the inlined version will certainly be transformed - in a same way that can drop the dependency. - mshinwell: This should get some thought after the first release to - decide for sure what to do. *) - (* Check that the free variables rewriting map in the set of closures - does not contain variables in its domain that are not actually free - variables of any of the function bodies. *) - let bad_free_vars = - Variable.Set.diff (Variable.Map.keys free_vars) all_free_vars - in -(* - if not (Variable.Set.is_empty bad_free_vars) then begin - raise (Set_of_closures_free_vars_map_has_wrong_range bad_free_vars) - end; -*) - (* CR-someday pchambart: Ignore it to avoid the warning: get rid of that - when the case is settled *) - ignore (Set_of_closures_free_vars_map_has_wrong_range bad_free_vars); - (* Check that free variables are not bound somewhere - else in the program *) - declare_variables (Variable.Map.keys free_vars); - (* Check that every "specialised arg" is a parameter of one of the - functions being declared, and that the variable to which the - parameter is being specialised is bound. *) - Variable.Map.iter (fun _inner_var - (specialised_to : Flambda.specialised_to) -> - check_variable_is_bound env specialised_to.var; - match specialised_to.projection with - | None -> () - | Some projection -> - let projecting_from = Projection.projecting_from projection in - if not (Variable.Map.mem projecting_from free_vars) - then begin - raise (Projection_must_be_a_free_var projection) - end) - free_vars; - Variable.Map.iter (fun being_specialised - (specialised_to : Flambda.specialised_to) -> - if not (Variable.Set.mem being_specialised all_params) then begin - raise (Specialised_arg_that_is_not_a_parameter being_specialised) - end; - check_variable_is_bound env specialised_to.var; - match specialised_to.projection with - | None -> () - | Some projection -> - let projecting_from = Projection.projecting_from projection in - if not (Variable.Map.mem projecting_from specialised_args) - then begin - raise (Projection_must_be_a_specialised_arg projection) - end) - specialised_args - in - let loop_constant_defining_value env - (const : Flambda.constant_defining_value) = - match const with - | Flambda.Allocated_const c -> - ignore_allocated_const c - | Flambda.Block (tag,fields) -> - ignore_tag tag; - List.iter (fun (fields : Flambda.constant_defining_value_block_field) -> - match fields with - | Const c -> ignore_const c - | Symbol s -> check_symbol_is_bound env s) - fields - | Flambda.Set_of_closures set_of_closures -> - loop_set_of_closures env set_of_closures; - (* Constant set of closures must not have free variables *) - if not (Variable.Map.is_empty set_of_closures.free_vars) then - assert false; (* TODO: correct error *) - if not (Variable.Map.is_empty set_of_closures.specialised_args) then - assert false; (* TODO: correct error *) - | Flambda.Project_closure (symbol,closure_id) -> - ignore_closure_id closure_id; - check_symbol_is_bound env symbol - in - let rec loop_program_body env (program : Flambda.program_body) = - match program with - | Let_rec_symbol (defs, program) -> - let env = - List.fold_left (fun env (symbol, _) -> - add_binding_occurrence_of_symbol env symbol) - env defs - in - List.iter (fun (_, def) -> - loop_constant_defining_value env def) - defs; - loop_program_body env program - | Let_symbol (symbol, def, program) -> - loop_constant_defining_value env def; - let env = add_binding_occurrence_of_symbol env symbol in - loop_program_body env program - | Initialize_symbol (symbol, _tag, fields, program) -> - List.iter (loop env) fields; - let env = add_binding_occurrence_of_symbol env symbol in - loop_program_body env program - | Effect (expr, program) -> - loop env expr; - loop_program_body env program - | End root -> - check_symbol_is_bound env root - in - let env = - Symbol.Set.fold (fun symbol env -> - add_binding_occurrence_of_symbol env symbol) - program.imported_symbols - (Variable.Set.empty, Mutable_variable.Set.empty, Symbol.Set.empty) - in - loop_program_body env program.program_body - -let primitive_invariants flam = - Flambda_iterators.iter_named (function - | Prim (prim, _, _) -> - begin match prim with - | Psequand | Psequor -> - raise (Sequential_logical_operator_primitives_must_be_expanded prim) - | _ -> () - end - | _ -> ()) - flam - -let declared_var_within_closure (flam:Flambda.program) = - let bound = ref Var_within_closure.Set.empty in - let bound_multiple_times = ref None in - let add_and_check var = - if Var_within_closure.Set.mem var !bound then begin - bound_multiple_times := Some var - end; - bound := Var_within_closure.Set.add var !bound - in - Flambda_iterators.iter_on_set_of_closures_of_program - ~f:(fun ~constant:_ { Flambda. free_vars; _ } -> - Variable.Map.iter (fun id _ -> - let var = Var_within_closure.wrap id in - add_and_check var) - free_vars) - flam; - !bound, !bound_multiple_times - -let no_var_within_closure_is_bound_multiple_times (flam:Flambda.program) = - match declared_var_within_closure flam with - | _, Some var -> raise (Var_within_closure_bound_multiple_times var) - | _, None -> () - -let every_declared_closure_is_from_current_compilation_unit flam = - let current_compilation_unit = Compilation_unit.get_current_exn () in - Flambda_iterators.iter_on_sets_of_closures (fun - { Flambda. function_decls; _ } -> - let compilation_unit = - Set_of_closures_id.get_compilation_unit - function_decls.set_of_closures_id - in - if not (Compilation_unit.equal compilation_unit current_compilation_unit) - then raise (Declared_closure_from_another_unit compilation_unit)) - flam - -let declared_closure_ids program = - let bound = ref Closure_id.Set.empty in - let bound_multiple_times = ref None in - let add_and_check var = - if Closure_id.Set.mem var !bound - then bound_multiple_times := Some var; - bound := Closure_id.Set.add var !bound - in - Flambda_iterators.iter_on_set_of_closures_of_program program - ~f:(fun ~constant:_ { Flambda. function_decls; _; } -> - Variable.Map.iter (fun id _ -> - let var = Closure_id.wrap id in - add_and_check var) - function_decls.funs); - !bound, !bound_multiple_times - -let no_closure_id_is_bound_multiple_times program = - match declared_closure_ids program with - | _, Some closure_id -> - raise (Closure_id_is_bound_multiple_times closure_id) - | _, None -> () - -let declared_set_of_closures_ids program = - let bound = ref Set_of_closures_id.Set.empty in - let bound_multiple_times = ref None in - let add_and_check var = - if Set_of_closures_id.Set.mem var !bound - then bound_multiple_times := Some var; - bound := Set_of_closures_id.Set.add var !bound - in - Flambda_iterators.iter_on_set_of_closures_of_program program - ~f:(fun ~constant:_ { Flambda. function_decls; _; } -> - add_and_check function_decls.set_of_closures_id); - !bound, !bound_multiple_times - -let no_set_of_closures_id_is_bound_multiple_times program = - match declared_set_of_closures_ids program with - | _, Some set_of_closures_id -> - raise (Set_of_closures_id_is_bound_multiple_times set_of_closures_id) - | _, None -> () - -let used_closure_ids (program:Flambda.program) = - let used = ref Closure_id.Set.empty in - let f (flam : Flambda.named) = - match flam with - | Project_closure { closure_id; _} -> - used := Closure_id.Set.add closure_id !used; - | Move_within_set_of_closures { closure = _; start_from; move_to; } -> - used := Closure_id.Set.add start_from !used; - used := Closure_id.Set.add move_to !used - | Project_var { closure = _; closure_id; var = _; kind = _ } -> - used := Closure_id.Set.add closure_id !used - | Set_of_closures _ | Symbol _ | Const _ | Allocated_const _ - | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _ -> () - in - (* CR-someday pchambart: check closure_ids of constant_defining_values' - project_closures *) - Flambda_iterators.iter_named_of_program ~f program; - !used - -let used_vars_within_closures (flam:Flambda.program) = - let used = ref Var_within_closure.Set.empty in - let f (flam : Flambda.named) = - match flam with - | Project_var { closure = _; closure_id = _; var; kind = _ } -> - used := Var_within_closure.Set.add var !used - | _ -> () - in - Flambda_iterators.iter_named_of_program ~f flam; - !used - -let every_used_function_from_current_compilation_unit_is_declared - (program:Flambda.program) = - let current_compilation_unit = Compilation_unit.get_current_exn () in - let declared, _ = declared_closure_ids program in - let used = used_closure_ids program in - let used_from_current_unit = - Closure_id.Set.filter (fun cu -> - Closure_id.in_compilation_unit cu current_compilation_unit) - used - in - let counter_examples = - Closure_id.Set.diff used_from_current_unit declared - in - if Closure_id.Set.is_empty counter_examples - then () - else raise (Unbound_closure_ids counter_examples) - -let every_used_var_within_closure_from_current_compilation_unit_is_declared - (flam:Flambda.program) = - let current_compilation_unit = Compilation_unit.get_current_exn () in - let declared, _ = declared_var_within_closure flam in - let used = used_vars_within_closures flam in - let used_from_current_unit = - Var_within_closure.Set.filter (fun cu -> - Var_within_closure.in_compilation_unit cu current_compilation_unit) - used - in - let counter_examples = - Var_within_closure.Set.diff used_from_current_unit declared in - if Var_within_closure.Set.is_empty counter_examples - then () - else raise (Unbound_vars_within_closures counter_examples) - -let every_static_exception_is_caught flam = - let check env (flam : Flambda.t) = - match flam with - | Static_raise (exn, _) -> - if not (Static_exception.Set.mem exn env) - then raise (Static_exception_not_caught exn) - | _ -> () - in - let rec loop env (flam : Flambda.t) = - match flam with - | Static_catch (i, _, body, handler, _kind) -> - let env = Static_exception.Set.add i env in - loop env handler; - loop env body - | exp -> - check env exp; - Flambda_iterators.apply_on_subexpressions (loop env) - (fun (_ : Flambda.named) -> ()) exp - in - loop Static_exception.Set.empty flam - -let every_static_exception_is_caught_at_a_single_position flam = - let caught = ref Static_exception.Set.empty in - let f (flam : Flambda.t) = - match flam with - | Static_catch (i, _, _body, _handler, _kind) -> - if Static_exception.Set.mem i !caught then - raise (Static_exception_caught_in_multiple_places i); - caught := Static_exception.Set.add i !caught - | _ -> () - in - Flambda_iterators.iter f (fun (_ : Flambda.named) -> ()) flam - -let _every_move_within_set_of_closures_is_to_a_function_in_the_free_vars - program = - let moves = ref Closure_id.Map.empty in - Flambda_iterators.iter_named_of_program program - ~f:(function - | Move_within_set_of_closures { start_from; move_to; _ } -> - let moved_to = - try Closure_id.Map.find start_from !moves with - | Not_found -> Closure_id.Set.empty - in - moves := - Closure_id.Map.add start_from - (Closure_id.Set.add move_to moved_to) - !moves - | _ -> ()); - Flambda_iterators.iter_on_set_of_closures_of_program program - ~f:(fun ~constant:_ { Flambda.function_decls = { funs; _ }; _ } -> - Variable.Map.iter (fun fun_var { Flambda.free_variables; _ } -> - match Closure_id.Map.find (Closure_id.wrap fun_var) !moves with - | exception Not_found -> () - | moved_to -> - let missing_dependencies = - Variable.Set.diff (Closure_id.unwrap_set moved_to) - free_variables - in - if not (Variable.Set.is_empty missing_dependencies) then - raise (Move_to_a_closure_not_in_the_free_variables - (fun_var, missing_dependencies))) - funs) - -let check_exn ?(kind=Normal) (flam:Flambda.program) = - ignore kind; - try - variable_and_symbol_invariants flam; - no_closure_id_is_bound_multiple_times flam; - no_set_of_closures_id_is_bound_multiple_times flam; - every_used_function_from_current_compilation_unit_is_declared flam; - no_var_within_closure_is_bound_multiple_times flam; - every_used_var_within_closure_from_current_compilation_unit_is_declared - flam; - (* CR-soon pchambart: This invariant is not maintained. It should be - either relaxed or reformulated. Currently, it is safe to disable it as - the potential related errors would result in fatal errors, not in - miscompilations *) - (* every_move_within_set_of_closures_is_to_a_function_in_the_free_vars - flam; *) - Flambda_iterators.iter_exprs_at_toplevel_of_program flam ~f:(fun flam -> - primitive_invariants flam; - every_static_exception_is_caught flam; - every_static_exception_is_caught_at_a_single_position flam; - every_declared_closure_is_from_current_compilation_unit flam) - with exn -> begin - (* CR-someday split printing code into its own function *) - begin match exn with - | Binding_occurrence_not_from_current_compilation_unit var -> - Format.eprintf ">> Binding occurrence of variable marked as not being \ - from the current compilation unit: %a" - Variable.print var - | Mutable_binding_occurrence_not_from_current_compilation_unit mut_var -> - Format.eprintf ">> Binding occurrence of mutable variable marked as not \ - being from the current compilation unit: %a" - Mutable_variable.print mut_var - | Binding_occurrence_of_variable_already_bound var -> - Format.eprintf ">> Binding occurrence of variable that was already \ - bound: %a" - Variable.print var - | Binding_occurrence_of_mutable_variable_already_bound mut_var -> - Format.eprintf ">> Binding occurrence of mutable variable that was \ - already bound: %a" - Mutable_variable.print mut_var - | Binding_occurrence_of_symbol_already_bound sym -> - Format.eprintf ">> Binding occurrence of symbol that was already \ - bound: %a" - Symbol.print sym - | Unbound_variable var -> - Format.eprintf ">> Unbound variable: %a" Variable.print var - | Unbound_mutable_variable mut_var -> - Format.eprintf ">> Unbound mutable variable: %a" - Mutable_variable.print mut_var - | Unbound_symbol sym -> - Format.eprintf ">> Unbound symbol: %a %s" - Symbol.print sym - (Printexc.raw_backtrace_to_string (Printexc.get_callstack 100)) - | Vars_in_function_body_not_bound_by_closure_or_params - (vars, set_of_closures, fun_var) -> - Format.eprintf ">> Variable(s) (%a) in the body of a function \ - declaration (fun_var = %a) that is not bound by either the closure \ - or the function's parameter list. Set of closures: %a" - Variable.Set.print vars - Variable.print fun_var - Flambda.print_set_of_closures set_of_closures - | Function_decls_have_overlapping_parameters vars -> - Format.eprintf ">> Function declarations whose parameters overlap: \ - %a" - Variable.Set.print vars - | Specialised_arg_that_is_not_a_parameter var -> - Format.eprintf ">> Variable in [specialised_args] that is not a \ - parameter of any of the function(s) in the corresponding \ - declaration(s): %a" - Variable.print var - | Projection_must_be_a_free_var var -> - Format.eprintf ">> Projection %a in [free_vars] from a variable that is \ - not a (inner) free variable of the set of closures" - Projection.print var - | Projection_must_be_a_specialised_arg var -> - Format.eprintf ">> Projection %a in [specialised_args] from a variable \ - that is not a (inner) specialised argument variable of the set of \ - closures" - Projection.print var - | Free_variables_set_is_lying (var, claimed, calculated, function_decl) -> - Format.eprintf ">> Function declaration whose [free_variables] set (%a) \ - is not a superset of the result of [Flambda.free_variables] \ - applied to the body of the function (%a). Declaration: %a" - Variable.Set.print claimed - Variable.Set.print calculated - Flambda.print_function_declaration (var, function_decl) - | Set_of_closures_free_vars_map_has_wrong_range vars -> - Format.eprintf ">> [free_vars] map in set of closures has in its range \ - variables that are not free variables of the corresponding \ - functions: %a" - Variable.Set.print vars - | Sequential_logical_operator_primitives_must_be_expanded prim -> - Format.eprintf ">> Sequential logical operator primitives must be \ - expanded (see closure_conversion.ml): %a" - Printclambda_primitives.primitive prim - | Var_within_closure_bound_multiple_times var -> - Format.eprintf ">> Variable within a closure is bound multiple times: \ - %a" - Var_within_closure.print var - | Closure_id_is_bound_multiple_times closure_id -> - Format.eprintf ">> Closure ID is bound multiple times: %a" - Closure_id.print closure_id - | Set_of_closures_id_is_bound_multiple_times set_of_closures_id -> - Format.eprintf ">> Set of closures ID is bound multiple times: %a" - Set_of_closures_id.print set_of_closures_id - | Declared_closure_from_another_unit compilation_unit -> - Format.eprintf ">> Closure declared as being from another compilation \ - unit: %a" - Compilation_unit.print compilation_unit - | Unbound_closure_ids closure_ids -> - Format.eprintf ">> Unbound closure ID(s) from the current compilation \ - unit: %a" - Closure_id.Set.print closure_ids - | Unbound_vars_within_closures vars_within_closures -> - Format.eprintf ">> Unbound variable(s) within closure(s) from the \ - current compilation_unit: %a" - Var_within_closure.Set.print vars_within_closures - | Static_exception_not_caught static_exn -> - Format.eprintf ">> Uncaught static exception: %a" - Static_exception.print static_exn - | Static_exception_caught_in_multiple_places static_exn -> - Format.eprintf ">> Static exception caught in multiple places: %a" - Static_exception.print static_exn - | Move_to_a_closure_not_in_the_free_variables (start_from, move_to) -> - Format.eprintf ">> A Move_within_set_of_closures from the closure %a \ - to closures that are not parts of its free variables: %a" - Variable.print start_from - Variable.Set.print move_to - | exn -> raise exn - end; - Format.eprintf "\n@?"; - raise Flambda_invariants_failed - end diff --git a/middle_end/flambda/flambda_invariants.mli b/middle_end/flambda/flambda_invariants.mli deleted file mode 100644 index 252578e88ec..00000000000 --- a/middle_end/flambda/flambda_invariants.mli +++ /dev/null @@ -1,28 +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"] - -type flambda_kind = - | Normal - | Lifted - -(** Checking of invariants on Flambda expressions. Raises an exception if - a check fails. *) -val check_exn - : ?kind:flambda_kind - -> Flambda.program - -> unit diff --git a/middle_end/flambda/flambda_iterators.ml b/middle_end/flambda/flambda_iterators.ml deleted file mode 100644 index 1d7aeaa83be..00000000000 --- a/middle_end/flambda/flambda_iterators.ml +++ /dev/null @@ -1,841 +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-66"] -open! Int_replace_polymorphic_compare - -let apply_on_subexpressions f f_named (flam : Flambda.t) = - match flam with - | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable - | Static_raise _ -> () - | Let { defining_expr; body; _ } -> - f_named defining_expr; - f body - | Let_mutable { body; _ } -> - f body - | Let_rec (defs, body) -> - List.iter (fun (_,l) -> f_named l) defs; - f body - | Switch (_, sw) -> - List.iter (fun (_,l) -> f l) sw.consts; - List.iter (fun (_,l) -> f l) sw.blocks; - Option.iter f sw.failaction - | String_switch (_, sw, def, _kind) -> - List.iter (fun (_,l) -> f l) sw; - Option.iter f def - | Static_catch (_,_,f1,f2, _) -> - f f1; f f2; - | Try_with (f1,_,f2, _kind) -> - f f1; f f2 - | If_then_else (_,f1, f2, _kind) -> - f f1;f f2 - | While (f1,f2) -> - f f1; f f2 - | For { body; _ } -> f body - | Region body -> f body - | Exclave body -> f body - -let rec list_map_sharing f l = - match l with - | [] -> l - | h :: t -> - let new_t = list_map_sharing f t in - let new_h = f h in - if h == new_h && t == new_t then - l - else - new_h :: new_t - -let may_map_sharing f v = - match v with - | None -> v - | Some s -> - let new_s = f s in - if s == new_s then - v - else - Some new_s - -let map_snd_sharing f ((a, b) as cpl) = - let new_b = f a b in - if b == new_b then - cpl - else - (a, new_b) - -let map_subexpressions_with_tail f f_named (tree:Flambda.t) : Flambda.t = - let f_tail v = f v ~tail:true in - let f_nontail v = f v ~tail:false in - match tree with - | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable - | Static_raise _ -> tree - | Let { var; defining_expr; body; _ } -> - let new_named = f_named var defining_expr in - let new_body = f_tail body in - if new_named == defining_expr && new_body == body then - tree - else - Flambda.create_let var new_named new_body - | Let_rec (defs, body) -> - let new_defs = - list_map_sharing (map_snd_sharing f_named) defs - in - let new_body = f_tail body in - if new_defs == defs && new_body == body then - tree - else - Let_rec (new_defs, new_body) - | Let_mutable mutable_let -> - let new_body = f_tail mutable_let.body in - if new_body == mutable_let.body then - tree - else - Let_mutable { mutable_let with body = new_body } - | Switch (arg, sw) -> - let aux = map_snd_sharing (fun _ v -> f_tail v) in - let new_consts = list_map_sharing aux sw.consts in - let new_blocks = list_map_sharing aux sw.blocks in - let new_failaction = may_map_sharing f_tail sw.failaction - in - if sw.failaction == new_failaction && - new_consts == sw.consts && - new_blocks == sw.blocks then - tree - else - let sw = - { sw with - failaction = new_failaction; - consts = new_consts; - blocks = new_blocks; - } - in - Switch (arg, sw) - | String_switch (arg, sw, def, kind) -> - let new_sw = list_map_sharing (map_snd_sharing (fun _ v -> f_tail v)) sw in - let new_def = may_map_sharing f_tail def in - if sw == new_sw && def == new_def then - tree - else - String_switch(arg, new_sw, new_def, kind) - | Static_catch (i, vars, body, handler, kind) -> - let new_body = f_tail body in - let new_handler = f_tail handler in - if new_body == body && new_handler == handler then - tree - else - Static_catch (i, vars, new_body, new_handler, kind) - | Try_with(body, id, handler, kind) -> - let new_body = f_tail body in - let new_handler = f_tail handler in - if body == new_body && handler == new_handler then - tree - else - Try_with(new_body, id, new_handler, kind) - | If_then_else(arg, ifso, ifnot, kind) -> - let new_ifso = f_tail ifso in - let new_ifnot = f_tail ifnot in - if new_ifso == ifso && new_ifnot == ifnot then - tree - else - If_then_else(arg, new_ifso, new_ifnot, kind) - | While(cond, body) -> - let new_cond = f_nontail cond in - let new_body = f_nontail body in - if new_cond == cond && new_body == body then - tree - else - While(new_cond, new_body) - | For { bound_var; from_value; to_value; direction; body; } -> - let new_body = f_nontail body in - if new_body == body then - tree - else - For { bound_var; from_value; to_value; direction; body = new_body; } - | Region body -> - let new_body = f_tail body in - if new_body == body then - tree - else - Region new_body - | Exclave body -> - let new_body = f_tail body in - if new_body == body then - tree - else - Exclave new_body - -let map_subexpressions f f_named tree = - map_subexpressions_with_tail (fun v ~tail:_ -> f v) f_named tree - -let map_tail_subexpressions f tree = - let f v ~tail = if tail then f v else v in - map_subexpressions_with_tail f (fun _ named -> named) tree - -let iter_general = Flambda.iter_general - -let iter f f_named t = iter_general ~toplevel:false f f_named (Is_expr t) -let iter_expr f t = iter f (fun _ -> ()) t -let iter_on_named f f_named t = - iter_general ~toplevel:false f f_named (Is_named t) -let iter_named f_named t = iter (fun (_ : Flambda.t) -> ()) f_named t -let iter_named_on_named f_named named = - iter_general ~toplevel:false (fun (_ : Flambda.t) -> ()) f_named - (Is_named named) - -let iter_toplevel f f_named t = - iter_general ~toplevel:true f f_named (Is_expr t) -let iter_named_toplevel f f_named named = - iter_general ~toplevel:true f f_named (Is_named named) - -let iter_all_immutable_let_and_let_rec_bindings t ~f = - iter_expr (function - | Let { var; defining_expr; _ } -> f var defining_expr - | Let_rec (defs, _) -> List.iter (fun (var, named) -> f var named) defs - | _ -> ()) - t - -let iter_all_toplevel_immutable_let_and_let_rec_bindings t ~f = - iter_general ~toplevel:true - (function - | Let { var; defining_expr; _ } -> f var defining_expr - | Let_rec (defs, _) -> List.iter (fun (var, named) -> f var named) defs - | _ -> ()) - (fun _ -> ()) - (Is_expr t) - -let iter_on_sets_of_closures f t = - iter_named (function - | Set_of_closures clos -> f clos - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ - | Project_closure _ | Move_within_set_of_closures _ | Project_var _ - | Prim _ | Expr _ -> ()) - t - -let iter_exprs_at_toplevel_of_program (program : Flambda.program) ~f = - let rec loop (program : Flambda.program_body) = - match program with - | Let_symbol (_, Set_of_closures set_of_closures, program) -> - Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) -> - f function_decl.body) - set_of_closures.function_decls.funs; - loop program - | Let_rec_symbol (defs, program) -> - List.iter (function - | (_, Flambda.Set_of_closures set_of_closures) -> - Variable.Map.iter - (fun _ (function_decl : Flambda.function_declaration) -> - f function_decl.body) - set_of_closures.function_decls.funs - | _ -> ()) defs; - loop program - | Let_symbol (_, _, program) -> - loop program - | Initialize_symbol (_, _, fields, program) -> - List.iter f fields; - loop program - | Effect (expr, program) -> - f expr; - loop program - | End _ -> () - in - loop program.program_body - -let iter_named_of_program program ~f = - iter_exprs_at_toplevel_of_program program ~f:(iter_named f) - -let iter_on_set_of_closures_of_program (program : Flambda.program) ~f = - let rec loop (program : Flambda.program_body) = - match program with - | Let_symbol (_, Set_of_closures set_of_closures, program) -> - f ~constant:true set_of_closures; - Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) -> - iter_on_sets_of_closures (f ~constant:false) function_decl.body) - set_of_closures.function_decls.funs; - loop program - | Let_rec_symbol (defs, program) -> - List.iter (function - | (_, Flambda.Set_of_closures set_of_closures) -> - f ~constant:true set_of_closures; - Variable.Map.iter - (fun _ (function_decl : Flambda.function_declaration) -> - iter_on_sets_of_closures (f ~constant:false) function_decl.body) - set_of_closures.function_decls.funs - | _ -> ()) defs; - loop program - | Let_symbol (_, _, program) -> - loop program - | Initialize_symbol (_, _, fields, program) -> - List.iter (iter_on_sets_of_closures (f ~constant:false)) fields; - loop program - | Effect (expr, program) -> - iter_on_sets_of_closures (f ~constant:false) expr; - loop program - | End _ -> () - in - loop program.program_body - -let iter_constant_defining_values_on_program (program : Flambda.program) ~f = - let rec loop (program : Flambda.program_body) = - match program with - | Let_symbol (_, const, program) -> - f const; - loop program - | Let_rec_symbol (defs, program) -> - List.iter (fun (_, const) -> f const) defs; - loop program - | Initialize_symbol (_, _, _, program) -> - loop program - | Effect (_, program) -> - loop program - | End _ -> () - in - loop program.program_body - -let map_general ~toplevel f f_named tree = - let rec aux (tree : Flambda.t) = - match tree with - | Let _ -> - Flambda.map_lets tree ~for_defining_expr:aux_named ~for_last_body:aux - ~after_rebuild:f - | _ -> - let exp : Flambda.t = - match tree with - | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable - | Static_raise _ -> tree - | Let _ -> assert false - | Let_mutable mutable_let -> - let new_body = aux mutable_let.body in - if new_body == mutable_let.body then - tree - else - Let_mutable { mutable_let with body = new_body } - | Let_rec (defs, body) -> - let done_something = ref false in - let defs = - List.map (fun (id, lam) -> - id, aux_named_done_something id lam done_something) - defs - in - let body = aux_done_something body done_something in - if not !done_something then - tree - else - Let_rec (defs, body) - | Switch (arg, sw) -> - let done_something = ref false in - let sw = - { sw with - failaction = - begin match sw.failaction with - | None -> None - | Some failaction -> - Some (aux_done_something failaction done_something) - end; - consts = - List.map (fun (i, v) -> - i, aux_done_something v done_something) - sw.consts; - blocks = - List.map (fun (i, v) -> - i, aux_done_something v done_something) - sw.blocks; - } - in - if not !done_something then - tree - else - Switch (arg, sw) - | String_switch (arg, sw, def, kind) -> - let done_something = ref false in - let sw = - List.map (fun (i, v) -> i, aux_done_something v done_something) sw - in - let def = - match def with - | None -> None - | Some def -> Some (aux_done_something def done_something) - in - if not !done_something then - tree - else - String_switch(arg, sw, def, kind) - | Static_catch (i, vars, body, handler, kind) -> - let new_body = aux body in - let new_handler = aux handler in - if new_body == body && new_handler == handler then - tree - else - Static_catch (i, vars, new_body, new_handler, kind) - | Try_with(body, id, handler, kind) -> - let new_body = aux body in - let new_handler = aux handler in - if new_body == body && new_handler == handler then - tree - else - Try_with (new_body, id, new_handler, kind) - | If_then_else (arg, ifso, ifnot, kind) -> - let new_ifso = aux ifso in - let new_ifnot = aux ifnot in - if new_ifso == ifso && new_ifnot == ifnot then - tree - else - If_then_else (arg, new_ifso, new_ifnot, kind) - | While (cond, body) -> - let new_cond = aux cond in - let new_body = aux body in - if new_cond == cond && new_body == body then - tree - else - While (new_cond, new_body) - | For { bound_var; from_value; to_value; direction; body; } -> - let new_body = aux body in - if new_body == body then - tree - else - For { bound_var; from_value; to_value; direction; - body = new_body; } - | Region body -> - let new_body = aux body in - if new_body == body then - tree - else - Region new_body - | Exclave body -> - let new_body = aux body in - if new_body == body then - tree - else - Exclave new_body - in - f exp - and aux_done_something expr done_something = - let new_expr = aux expr in - if not (new_expr == expr) then begin - done_something := true - end; - new_expr - and aux_named (id : Variable.t) (named : Flambda.named) = - let named : Flambda.named = - match named with - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Project_closure _ | Move_within_set_of_closures _ | Project_var _ - | Prim _ | Read_symbol_field _ -> named - | Set_of_closures ({ function_decls; free_vars; specialised_args; - direct_call_surrogates }) -> - if toplevel then named - else begin - let done_something = ref false in - let funs = - Variable.Map.map (fun (func_decl : Flambda.function_declaration) -> - let new_body = aux func_decl.body in - if new_body == func_decl.body then begin - func_decl - end else begin - done_something := true; - Flambda.update_function_declaration_body func_decl - ~body:new_body - end) - function_decls.funs - in - if not !done_something then - named - else - let function_decls = - Flambda.update_function_declarations function_decls ~funs - in - let set_of_closures = - Flambda.create_set_of_closures ~function_decls ~free_vars - ~specialised_args ~direct_call_surrogates - in - Set_of_closures set_of_closures - end - | Expr expr -> - let new_expr = aux expr in - if new_expr == expr then named - else Expr new_expr - in - f_named id named - and aux_named_done_something id named done_something = - let new_named = aux_named id named in - if not (new_named == named) then begin - done_something := true - end; - new_named - in - aux tree - -let iter_apply_on_program program ~f = - iter_exprs_at_toplevel_of_program program ~f:(fun expr -> - iter (function - | Apply apply -> f apply - | _ -> ()) - (fun _ -> ()) - expr) - -let map f f_named tree = - map_general ~toplevel:false f (fun _ n -> f_named n) tree -let map_expr f tree = map f (fun named -> named) tree -let map_named f_named tree = map (fun expr -> expr) f_named tree -let map_named_with_id f_named tree = - map_general ~toplevel:false (fun expr -> expr) f_named tree -let map_toplevel f f_named tree = - map_general ~toplevel:true f (fun _ n -> f_named n) tree -let map_toplevel_expr f_expr tree = - map_toplevel f_expr (fun named -> named) tree -let map_toplevel_named f_named tree = - map_toplevel (fun tree -> tree) f_named tree - -let map_symbols tree ~f = - map_named (function - | (Symbol sym) as named -> - let new_sym = f sym in - if new_sym == sym then - named - else - Symbol new_sym - | ((Read_symbol_field (sym, field)) as named) -> - let new_sym = f sym in - if new_sym == sym then - named - else - Read_symbol_field (new_sym, field) - | (Const _ | Allocated_const _ | Set_of_closures _ | Read_mutable _ - | Project_closure _ | Move_within_set_of_closures _ | Project_var _ - | Prim _ | Expr _) as named -> named) - tree - -let map_symbols_on_set_of_closures - ({ Flambda.function_decls; free_vars; specialised_args; - direct_call_surrogates; } as - set_of_closures) - ~f = - let done_something = ref false in - let funs = - Variable.Map.map (fun (func_decl : Flambda.function_declaration) -> - let body = map_symbols func_decl.body ~f in - if not (body == func_decl.body) then begin - done_something := true; - end; - Flambda.update_function_declaration_body func_decl ~body) - function_decls.funs - in - if not !done_something then - set_of_closures - else - let function_decls = - Flambda.update_function_declarations function_decls ~funs - in - Flambda.create_set_of_closures ~function_decls ~free_vars - ~specialised_args ~direct_call_surrogates - -let map_toplevel_sets_of_closures tree ~f = - map_toplevel_named (function - | (Set_of_closures set_of_closures) as named -> - let new_set_of_closures = f set_of_closures in - if new_set_of_closures == set_of_closures then - named - else - Set_of_closures new_set_of_closures - | (Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ - | Project_closure _ | Move_within_set_of_closures _ | Project_var _ - | Prim _ | Expr _) as named -> named) - tree - -let map_apply tree ~f = - map (function - | (Apply apply) as expr -> - let new_apply = f apply in - if new_apply == apply then - expr - else - Apply new_apply - | expr -> expr) - (fun named -> named) - tree - -let map_sets_of_closures tree ~f = - map_named (function - | (Set_of_closures set_of_closures) as named -> - let new_set_of_closures = f set_of_closures in - if new_set_of_closures == set_of_closures then - named - else - Set_of_closures new_set_of_closures - | (Symbol _ | Const _ | Allocated_const _ | Project_closure _ - | Move_within_set_of_closures _ | Project_var _ - | Prim _ | Expr _ | Read_mutable _ - | Read_symbol_field _) as named -> named) - tree - -let map_project_var_to_expr_opt tree ~f = - map_named (function - | (Project_var project_var) as named -> - begin match f project_var with - | None -> named - | Some expr -> Expr expr - end - | (Symbol _ | Const _ | Allocated_const _ - | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ - | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _) - as named -> named) - tree - -let map_project_var_to_named_opt tree ~f = - map_named (function - | (Project_var project_var) as named -> - begin match f project_var with - | None -> named - | Some named -> named - end - | (Symbol _ | Const _ | Allocated_const _ - | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ - | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _) - as named -> named) - tree - -let map_function_bodies (set_of_closures : Flambda.set_of_closures) ~f = - let done_something = ref false in - let funs = - Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> - let new_body = f function_decl.body in - if new_body == function_decl.body then - function_decl - else begin - done_something := true; - Flambda.update_function_declaration_body function_decl - ~body:new_body - end) - set_of_closures.function_decls.funs - in - if not !done_something then - set_of_closures - else - let function_decls = - Flambda.update_function_declarations set_of_closures.function_decls ~funs - in - Flambda.create_set_of_closures - ~function_decls - ~free_vars:set_of_closures.free_vars - ~specialised_args:set_of_closures.specialised_args - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - -let map_sets_of_closures_of_program (program : Flambda.program) - ~(f : Flambda.set_of_closures -> Flambda.set_of_closures) = - let rec loop (program : Flambda.program_body) : Flambda.program_body = - let map_constant_set_of_closures (set_of_closures:Flambda.set_of_closures) = - let done_something = ref false in - let function_decls = - let funs = - Variable.Map.map (fun - (function_decl : Flambda.function_declaration) -> - let body = map_sets_of_closures ~f function_decl.body in - if body == function_decl.body then - function_decl - else begin - done_something := true; - Flambda.update_function_declaration_body function_decl ~body - end) - set_of_closures.function_decls.funs - in - if not !done_something then - set_of_closures.function_decls - else - Flambda.update_function_declarations set_of_closures.function_decls - ~funs - in - let new_set_of_closures = f set_of_closures in - if new_set_of_closures == set_of_closures then - set_of_closures - else - Flambda.create_set_of_closures ~function_decls - ~free_vars:set_of_closures.free_vars - ~specialised_args:set_of_closures.specialised_args - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - match program with - | Let_symbol (symbol, Set_of_closures set_of_closures, program') -> - let new_set_of_closures = map_constant_set_of_closures set_of_closures in - let new_program' = loop program' in - if new_set_of_closures == set_of_closures - && new_program' == program' then - program - else - Let_symbol (symbol, Set_of_closures new_set_of_closures, new_program') - | Let_symbol (symbol, const, program') -> - let new_program' = loop program' in - if new_program' == program' then - program - else - Let_symbol (symbol, const, new_program') - | Let_rec_symbol (defs, program') -> - let done_something = ref false in - let defs = - List.map (function - | (var, Flambda.Set_of_closures set_of_closures) -> - let new_set_of_closures = - map_constant_set_of_closures set_of_closures - in - if not (new_set_of_closures == set_of_closures) then begin - done_something := true - end; - var, Flambda.Set_of_closures new_set_of_closures - | def -> def) - defs - in - let new_program' = loop program' in - if new_program' == program' && not !done_something then - program - else - Let_rec_symbol (defs, loop program') - | Initialize_symbol (symbol, tag, fields, program') -> - let done_something = ref false in - let fields = - List.map (fun field -> - let new_field = map_sets_of_closures field ~f in - if not (new_field == field) then begin - done_something := true - end; - new_field) - fields - in - let new_program' = loop program' in - if new_program' == program' && not !done_something then - program - else - Initialize_symbol (symbol, tag, fields, new_program') - | Effect (expr, program') -> - let new_expr = map_sets_of_closures expr ~f in - let new_program' = loop program' in - if new_expr == expr && new_program' == program' then - program - else - Effect (new_expr, new_program') - | End _ -> program - in - { program with - program_body = loop program.program_body; - } - -let map_exprs_at_toplevel_of_program (program : Flambda.program) - ~(f : Flambda.t -> Flambda.t) = - let rec loop (program : Flambda.program_body) : Flambda.program_body = - let map_constant_set_of_closures (set_of_closures:Flambda.set_of_closures) = - let done_something = ref false in - let funs = - Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> - let body = f function_decl.body in - if body == function_decl.body then - function_decl - else begin - done_something := true; - Flambda.update_function_declaration_body function_decl ~body - end) - set_of_closures.function_decls.funs - in - if not !done_something then - set_of_closures - else - let function_decls = - Flambda.update_function_declarations set_of_closures.function_decls - ~funs - in - Flambda.create_set_of_closures ~function_decls - ~free_vars:set_of_closures.free_vars - ~specialised_args:set_of_closures.specialised_args - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - (* CR-soon mshinwell: code very similar to the above function *) - match program with - | Let_symbol (symbol, Set_of_closures set_of_closures, program') -> - let new_set_of_closures = map_constant_set_of_closures set_of_closures in - let new_program' = loop program' in - if new_set_of_closures == set_of_closures - && new_program' == program' then - program - else - Let_symbol (symbol, Set_of_closures new_set_of_closures, new_program') - | Let_symbol (symbol, const, program') -> - let new_program' = loop program' in - if new_program' == program' then - program - else - Let_symbol (symbol, const, new_program') - | Let_rec_symbol (defs, program') -> - let done_something = ref false in - let defs = - List.map (function - | (var, Flambda.Set_of_closures set_of_closures) -> - let new_set_of_closures = - map_constant_set_of_closures set_of_closures - in - if not (new_set_of_closures == set_of_closures) then begin - done_something := true - end; - var, Flambda.Set_of_closures new_set_of_closures - | def -> def) - defs - in - let new_program' = loop program' in - if new_program' == program' && not !done_something then - program - else - Let_rec_symbol (defs, new_program') - | Initialize_symbol (symbol, tag, fields, program') -> - let done_something = ref false in - let fields = - List.map (fun field -> - let new_field = f field in - if not (new_field == field) then begin - done_something := true - end; - new_field) - fields - in - let new_program' = loop program' in - if new_program' == program' && not !done_something then - program - else - Initialize_symbol (symbol, tag, fields, new_program') - | Effect (expr, program') -> - let new_expr = f expr in - let new_program' = loop program' in - if new_expr == expr && new_program' == program' then - program - else - Effect (new_expr, new_program') - | End _ -> program - in - { program with - program_body = loop program.program_body; - } - -let map_named_of_program (program : Flambda.program) - ~(f : Variable.t -> Flambda.named -> Flambda.named) : Flambda.program = - map_exprs_at_toplevel_of_program program - ~f:(fun expr -> map_named_with_id f expr) - -let map_all_immutable_let_and_let_rec_bindings (expr : Flambda.t) - ~(f : Variable.t -> Flambda.named -> Flambda.named) : Flambda.t = - map_named_with_id f expr - -let fold_function_decls_ignoring_stubs - (set_of_closures : Flambda.set_of_closures) ~init ~f = - Variable.Map.fold (fun fun_var function_decl acc -> - f ~fun_var ~function_decl acc) - set_of_closures.function_decls.funs - init diff --git a/middle_end/flambda/flambda_iterators.mli b/middle_end/flambda/flambda_iterators.mli deleted file mode 100644 index d0cd3aff8ac..00000000000 --- a/middle_end/flambda/flambda_iterators.mli +++ /dev/null @@ -1,233 +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-soon mshinwell: we need to document whether these iterators follow any - particular order. *) - -(** Apply the given functions to the immediate subexpressions of the given - Flambda expression. For avoidance of doubt, if a subexpression is - [Expr], it is passed to the function taking [Flambda.named], rather - than being followed and passed to the function taking [Flambda.t]. *) -val apply_on_subexpressions - : (Flambda.t -> unit) - -> (Flambda.named -> unit) - -> Flambda.t - -> unit - -val map_subexpressions - : (Flambda.t -> Flambda.t) - -> (Variable.t -> Flambda.named -> Flambda.named) - -> Flambda.t - -> Flambda.t - -(** Apply the given function to the immediate subexpressions in tail position of - the given Flambda expression. In this case, we consider the body of a [try] - expression to be in tail position, though it's worth noting that a function - call in such a place is not a tail call. *) -val map_tail_subexpressions : (Flambda.t -> Flambda.t) -> Flambda.t -> Flambda.t - -(* CR-soon lwhite: add comment to clarify that these recurse unlike the - ones above *) -val iter - : (Flambda.t -> unit) - -> (Flambda.named -> unit) - -> Flambda.t - -> unit - -val iter_expr - : (Flambda.t -> unit) - -> Flambda.t - -> unit - -val iter_on_named - : (Flambda.t -> unit) - -> (Flambda.named -> unit) - -> Flambda.named - -> unit - -(* CR-someday mshinwell: we might need to add the corresponding variable to - the parameters of the user function for [iter_named] *) -val iter_named - : (Flambda.named -> unit) - -> Flambda.t - -> unit - -(* CR-someday lwhite: These names are pretty indecipherable, perhaps - create submodules for the normal and "on_named" variants of each - function. *) - -val iter_named_on_named - : (Flambda.named -> unit) - -> Flambda.named - -> unit - -(** [iter_toplevel f t] applies [f] on every toplevel subexpression of [t]. - In particular, it never applies [f] to the body of a function (which - will always be contained within an [Set_of_closures] expression). *) -val iter_toplevel - : (Flambda.t -> unit) - -> (Flambda.named -> unit) - -> Flambda.t - -> unit - -val iter_named_toplevel - : (Flambda.t -> unit) - -> (Flambda.named -> unit) - -> Flambda.named - -> unit - -val iter_on_sets_of_closures - : (Flambda.set_of_closures -> unit) - -> Flambda.t - -> unit - -val iter_on_set_of_closures_of_program - : Flambda.program - -> f:(constant:bool -> Flambda.set_of_closures -> unit) - -> unit - -val iter_all_immutable_let_and_let_rec_bindings - : Flambda.t - -> f:(Variable.t -> Flambda.named -> unit) - -> unit - -val iter_all_toplevel_immutable_let_and_let_rec_bindings - : Flambda.t - -> f:(Variable.t -> Flambda.named -> unit) - -> unit - -val iter_exprs_at_toplevel_of_program - : Flambda.program - -> f:(Flambda.t -> unit) - -> unit - -val iter_named_of_program - : Flambda.program - -> f:(Flambda.named -> unit) - -> unit - -val iter_constant_defining_values_on_program - : Flambda.program - -> f:(Flambda.constant_defining_value -> unit) - -> unit - -val iter_apply_on_program - : Flambda.program - -> f:(Flambda.apply -> unit) - -> unit - -val map - : (Flambda.t -> Flambda.t) - -> (Flambda.named -> Flambda.named) - -> Flambda.t - -> Flambda.t - -val map_expr - : (Flambda.t -> Flambda.t) - -> Flambda.t - -> Flambda.t - -val map_named - : (Flambda.named -> Flambda.named) - -> Flambda.t - -> Flambda.t - -val map_toplevel - : (Flambda.t -> Flambda.t) - -> (Flambda.named -> Flambda.named) - -> Flambda.t - -> Flambda.t - -val map_toplevel_expr - : (Flambda.t -> Flambda.t) - -> Flambda.t - -> Flambda.t - -val map_toplevel_named - : (Flambda.named -> Flambda.named) - -> Flambda.t - -> Flambda.t - -val map_symbols - : Flambda.t - -> f:(Symbol.t -> Symbol.t) - -> Flambda.t - -val map_symbols_on_set_of_closures - : Flambda.set_of_closures - -> f:(Symbol.t -> Symbol.t) - -> Flambda.set_of_closures - -val map_toplevel_sets_of_closures - : Flambda.t - -> f:(Flambda.set_of_closures -> Flambda.set_of_closures) - -> Flambda.t - -val map_apply - : Flambda.t - -> f:(Flambda.apply -> Flambda.apply) - -> Flambda.t - -val map_function_bodies - : Flambda.set_of_closures - -> f:(Flambda.t -> Flambda.t) - -> Flambda.set_of_closures - -val map_sets_of_closures - : Flambda.t - -> f:(Flambda.set_of_closures -> Flambda.set_of_closures) - -> Flambda.t - -val map_sets_of_closures_of_program - : Flambda.program - -> f:(Flambda.set_of_closures -> Flambda.set_of_closures) - -> Flambda.program - -val map_project_var_to_expr_opt - : Flambda.t - -> f:(Flambda.project_var -> Flambda.t option) - -> Flambda.t - -val map_project_var_to_named_opt - : Flambda.t - -> f:(Flambda.project_var -> Flambda.named option) - -> Flambda.t - -val map_exprs_at_toplevel_of_program - : Flambda.program - -> f:(Flambda.t -> Flambda.t) - -> Flambda.program - -val map_named_of_program - : Flambda.program - -> f:(Variable.t -> Flambda.named -> Flambda.named) - -> Flambda.program - -val map_all_immutable_let_and_let_rec_bindings - : Flambda.t - -> f:(Variable.t -> Flambda.named -> Flambda.named) - -> Flambda.t - -val fold_function_decls_ignoring_stubs - : Flambda.set_of_closures - -> init:'a - -> f:(fun_var:Variable.t - -> function_decl:Flambda.function_declaration - -> 'a - -> 'a) - -> 'a diff --git a/middle_end/flambda/flambda_middle_end.ml b/middle_end/flambda/flambda_middle_end.ml deleted file mode 100644 index feb12f60a97..00000000000 --- a/middle_end/flambda/flambda_middle_end.ml +++ /dev/null @@ -1,251 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 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-66"] -open! Int_replace_polymorphic_compare - -let _dump_function_sizes flam = - let than = max_int in - Flambda_iterators.iter_on_set_of_closures_of_program flam - ~f:(fun ~constant:_ (set_of_closures : Flambda.set_of_closures) -> - Variable.Map.iter (fun fun_var - (function_decl : Flambda.function_declaration) -> - let closure_id = Closure_id.wrap fun_var in - let symbol = Symbol_utils.Flambda.for_closure closure_id in - match Inlining_cost.lambda_smaller' function_decl.body ~than with - | Some size -> Format.eprintf "%a %d\n" Symbol.print symbol size - | None -> assert false) - set_of_closures.function_decls.funs) - -let lambda_to_flambda ~ppf_dump ~prefixname ~backend ~size ~filename - ~compilation_unit ~module_initializer = - Profile.record_call "flambda" (fun () -> - let previous_warning_reporter = !Location.warning_reporter in - let module WarningSet = - Set.Make (struct - type t = Location.t * Warnings.t - let compare = Stdlib.compare - end) - in - let warning_set = ref WarningSet.empty in - let flambda_warning_reporter loc w = - let elt = loc, w in - if not (WarningSet.mem elt !warning_set) then begin - warning_set := WarningSet.add elt !warning_set; - previous_warning_reporter loc w - end else None - in - Misc.protect_refs - [Misc.R (Location.warning_reporter, flambda_warning_reporter)] - (fun () -> - let pass_number = ref 0 in - let round_number = ref 0 in - let check flam = - if !Clflags.flambda_invariant_checks then begin - try Flambda_invariants.check_exn flam - with exn -> - Misc.fatal_errorf "After Flambda pass %d, round %d:@.%s:@.%a" - !pass_number !round_number (Printexc.to_string exn) - Flambda.print_program flam - end - in - let (+-+) flam (name, pass) = - incr pass_number; - if !Clflags.dump_flambda_verbose then begin - Format.fprintf ppf_dump "@.PASS: %s@." name; - Format.fprintf ppf_dump "Before pass %d, round %d:@ %a@." - !pass_number !round_number Flambda.print_program flam; - Format.fprintf ppf_dump "\n@?" - end; - let flam = Profile.record ~accumulate:true name pass flam in - if !Clflags.flambda_invariant_checks then begin - Profile.record ~accumulate:true "check" check flam - end; - flam - in - Profile.record_call ~accumulate:true "middle_end" (fun () -> - let flam = - Profile.record_call ~accumulate:true "closure_conversion" - (fun () -> - module_initializer - |> Closure_conversion.lambda_to_flambda ~backend - ~compilation_unit ~size ~filename) - in - Compiler_hooks.execute Compiler_hooks.Raw_flambda1 flam; - if !Clflags.dump_rawflambda - then - Format.fprintf ppf_dump "After closure conversion:@ %a@." - Flambda.print_program flam; - check flam; - let fast_mode flam = - pass_number := 0; - let round = 0 in - flam - +-+ ("lift_lets 1", Lift_code.lift_lets) - +-+ ("Lift_constants", Lift_constants.lift_constants ~backend) - +-+ ("Share_constants", Share_constants.share_constants) - +-+ ("Lift_let_to_initialize_symbol", - Lift_let_to_initialize_symbol.lift ~backend) - +-+ ("Inline_and_simplify", - Inline_and_simplify.run ~never_inline:false ~backend - ~prefixname ~round ~ppf_dump) - +-+ ("Remove_unused_closure_vars 2", - Remove_unused_closure_vars.remove_unused_closure_variables - ~remove_direct_call_surrogates:false) - +-+ ("Ref_to_variables", - Ref_to_variables.eliminate_ref) - +-+ ("Initialize_symbol_to_let_symbol", - Initialize_symbol_to_let_symbol.run) - in - let rec loop flam = - pass_number := 0; - let round = !round_number in - incr round_number; - if !round_number > (Clflags.rounds ()) then flam - else - flam - (* Beware: [Lift_constants] must be run before any pass that - might duplicate strings. *) - +-+ ("lift_lets 1", Lift_code.lift_lets) - +-+ ("Lift_constants", Lift_constants.lift_constants ~backend) - +-+ ("Share_constants", Share_constants.share_constants) - +-+ ("Remove_unused_program_constructs", - Remove_unused_program_constructs.remove_unused_program_constructs) - +-+ ("Lift_let_to_initialize_symbol", - Lift_let_to_initialize_symbol.lift ~backend) - +-+ ("lift_lets 2", Lift_code.lift_lets) - +-+ ("Remove_unused_closure_vars 1", - Remove_unused_closure_vars.remove_unused_closure_variables - ~remove_direct_call_surrogates:false) - +-+ ("Inline_and_simplify", - Inline_and_simplify.run ~never_inline:false ~backend - ~prefixname ~round ~ppf_dump) - +-+ ("Remove_unused_closure_vars 2", - Remove_unused_closure_vars.remove_unused_closure_variables - ~remove_direct_call_surrogates:false) - +-+ ("lift_lets 3", Lift_code.lift_lets) - +-+ ("Inline_and_simplify noinline", - Inline_and_simplify.run ~never_inline:true ~backend - ~prefixname ~round ~ppf_dump) - +-+ ("Remove_unused_closure_vars 3", - Remove_unused_closure_vars.remove_unused_closure_variables - ~remove_direct_call_surrogates:false) - +-+ ("Ref_to_variables", - Ref_to_variables.eliminate_ref) - +-+ ("Initialize_symbol_to_let_symbol", - Initialize_symbol_to_let_symbol.run) - |> loop - in - let back_end flam = - flam - +-+ ("Remove_unused_closure_vars", - Remove_unused_closure_vars.remove_unused_closure_variables - ~remove_direct_call_surrogates:true) - +-+ ("Lift_constants", Lift_constants.lift_constants ~backend) - +-+ ("Share_constants", Share_constants.share_constants) - +-+ ("Remove_unused_program_constructs", - Remove_unused_program_constructs.remove_unused_program_constructs) - in - let flam = - if !Clflags.classic_inlining then - fast_mode flam - else - loop flam - in - let flam = back_end flam in - (* Check that there aren't any unused "always inlined" attributes. *) - Flambda_iterators.iter_apply_on_program flam ~f:(fun apply -> - match apply.inlined with - | Default_inlined | Never_inlined | Hint_inlined -> () - | Always_inlined -> - (* CR-someday mshinwell: consider a different error message if - this triggers as a result of the propagation of a user's - attribute into the second part of an over application - (inline_and_simplify.ml line 710). *) - Location.prerr_warning (Debuginfo.to_location apply.dbg) - (Warnings.Inlining_impossible - "[@inlined] attribute was not used on this function \ - application (the optimizer did not know what function \ - was being applied)") - | Unroll _ -> - Location.prerr_warning (Debuginfo.to_location apply.dbg) - (Warnings.Inlining_impossible - "[@unrolled] attribute was not used on this function \ - application (the optimizer did not know what function \ - was being applied)")); - Compiler_hooks.execute Compiler_hooks.Flambda1 flam; - if !Clflags.dump_flambda - then - Format.fprintf ppf_dump "End of middle end:@ %a@." - Flambda.print_program flam; - check flam; - (* CR-someday mshinwell: add -d... option for this *) - (* dump_function_sizes flam ~backend; *) - flam)) - ) - -let flambda_raw_clambda_dump_if ppf - ({ Flambda_to_clambda. expr = ulambda; preallocated_blocks = _; - structured_constants; exported = _; } as input) = - Compiler_hooks.execute Compiler_hooks.Raw_clambda ulambda; - if !Clflags.dump_rawclambda then - begin - Format.fprintf ppf "@.clambda (before Un_anf):@."; - Printclambda.clambda ppf ulambda; - Symbol.Map.iter (fun sym cst -> - Format.fprintf ppf "%a:@ %a@." - Symbol.print sym - Printclambda.structured_constant cst) - structured_constants - end; - if !Clflags.dump_cmm then Format.fprintf ppf "@.cmm:@."; - input - -let lambda_to_clambda ~backend ~filename ~prefixname ~ppf_dump - (program : Lambda.program) = - let program = - lambda_to_flambda ~ppf_dump ~prefixname ~backend - ~size:program.main_module_block_size - ~filename - ~compilation_unit:program.compilation_unit - ~module_initializer:program.code - in - let export = Build_export_info.build_transient program in - let clambda, preallocated_blocks, constants = - Profile.record_call "backend" (fun () -> - (program, export) - |> Flambda_to_clambda.convert ~ppf_dump - |> flambda_raw_clambda_dump_if ppf_dump - |> (fun { Flambda_to_clambda. expr; preallocated_blocks; - structured_constants; exported; } -> - Compilenv.set_export_info exported; - let clambda = - Un_anf.apply ~what:(Symbol.for_current_unit ()) - ~ppf_dump expr - in - clambda, preallocated_blocks, structured_constants)) - in - let constants = - List.map (fun (symbol, definition) -> - { Clambda. - symbol = Symbol.linkage_name symbol |> Linkage_name.to_string; - exported = true; - definition; - provenance = None; - }) - (Symbol.Map.bindings constants) - in - clambda, preallocated_blocks, constants diff --git a/middle_end/flambda/flambda_middle_end.mli b/middle_end/flambda/flambda_middle_end.mli deleted file mode 100644 index e7bb7478b53..00000000000 --- a/middle_end/flambda/flambda_middle_end.mli +++ /dev/null @@ -1,27 +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"] - -(** Translate Lambda code to Flambda code, optimize it, and produce Clambda. *) - -val lambda_to_clambda - : backend:(module Backend_intf.S) - -> filename:string - -> prefixname:string - -> ppf_dump:Format.formatter - -> Lambda.program - -> Clambda.with_constants diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml deleted file mode 100644 index 5b1553cffc3..00000000000 --- a/middle_end/flambda/flambda_to_clambda.ml +++ /dev/null @@ -1,992 +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-69"] - -module V = Backend_var -module VP = Backend_var.With_provenance -module Int = Misc.Stdlib.Int - -type 'a for_one_or_more_units = { - fun_offset_table : int Closure_id.Map.t; - fv_offset_table : Closure_offsets.parts Var_within_closure.Map.t; - constant_closures : Closure_id.Set.t; - closures: Closure_id.Set.t; -} - -type t = { - current_unit : - Set_of_closures_id.t for_one_or_more_units; - imported_units : - Simple_value_approx.function_declarations for_one_or_more_units; - ppf_dump : Format.formatter; - mutable constants_for_instrumentation : - Clambda.ustructured_constant Symbol.Map.t; -} - -let get_fun_offset t closure_id = - let fun_offset_table = - if Closure_id.in_compilation_unit closure_id - (Compilation_unit.get_current_exn ()) - then - t.current_unit.fun_offset_table - else - t.imported_units.fun_offset_table - in - try Closure_id.Map.find closure_id fun_offset_table - with Not_found -> - Misc.fatal_errorf "Flambda_to_clambda: missing offset for closure %a" - Closure_id.print closure_id - -let get_fv_offset t var_within_closure = - let fv_offset_table = - if Var_within_closure.in_compilation_unit var_within_closure - (Compilation_unit.get_current_exn ()) - then t.current_unit.fv_offset_table - else t.imported_units.fv_offset_table - in - try Var_within_closure.Map.find var_within_closure fv_offset_table - with Not_found -> - Misc.fatal_errorf "Flambda_to_clambda: missing offset for variable %a" - Var_within_closure.print var_within_closure - -let is_function_constant t closure_id = - if Closure_id.Set.mem closure_id t.current_unit.closures then - Closure_id.Set.mem closure_id t.current_unit.constant_closures - else if Closure_id.Set.mem closure_id t.imported_units.closures then - Closure_id.Set.mem closure_id t.imported_units.constant_closures - else - Misc.fatal_errorf "Flambda_to_clambda: missing closure %a" - Closure_id.print closure_id - -(* Instrumentation of closure and field accesses to try to catch compiler - bugs. *) - -let check_closure t ulam named : Clambda.ulambda = - if not !Clflags.clambda_checks then ulam - else - let desc = - Primitive.simple_on_values ~name:"caml_check_value_is_closure" - ~arity:2 ~alloc:false - in - let str = Format.asprintf "%a" Flambda.print_named named in - let sym = Symbol.for_new_const_in_current_unit () in - t.constants_for_instrumentation <- - Symbol.Map.add sym (Clambda.Uconst_string str) - t.constants_for_instrumentation; - let sym = Symbol.linkage_name sym |> Linkage_name.to_string in - Uprim (Pccall desc, - [ulam; Clambda.Uconst (Uconst_ref (sym, None))], - Debuginfo.none) - -let clambda_arity (func : Flambda.function_declaration) : Clambda.arity = - let nlocal = - func.params - |> List.filter (fun p -> - Lambda.is_local_mode (Parameter.alloc_mode p)) - |> List.length - in - { - function_kind = Curried {nlocal} ; - params_layout = List.map Parameter.kind func.params ; - return_layout = func.return_layout ; - } - -let check_field t ulam pos named_opt : Clambda.ulambda = - if not !Clflags.clambda_checks then ulam - else - let desc = - Primitive.simple_on_values ~name:"caml_check_field_access" - ~arity:3 ~alloc:false - in - let str = - match named_opt with - | None -> "" - | Some named -> Format.asprintf "%a" Flambda.print_named named - in - let sym = Symbol.for_new_const_in_current_unit () in - t.constants_for_instrumentation <- - Symbol.Map.add sym (Clambda.Uconst_string str) - t.constants_for_instrumentation; - let sym = Symbol.linkage_name sym in - Uprim (Pccall desc, [ulam; Clambda.Uconst (Uconst_int pos); - Clambda.Uconst (Uconst_ref (sym |> Linkage_name.to_string, None))], - Debuginfo.none) - -module Env : sig - type t - - val empty : t - - val add_subst : t -> Variable.t -> Clambda.ulambda -> Lambda.layout -> t - val find_subst_exn : t -> Variable.t -> Clambda.ulambda * Lambda.layout - - val add_fresh_ident : t -> Variable.t -> Lambda.layout -> V.t * t - val ident_for_var_exn : t -> Variable.t -> V.t * Lambda.layout - - val add_fresh_mutable_ident : t -> Mutable_variable.t -> Lambda.layout -> V.t * t - val ident_for_mutable_var_exn : t -> Mutable_variable.t -> V.t * Lambda.layout - - val add_allocated_const : t -> Symbol.t -> Allocated_const.t -> t - val allocated_const_for_symbol : t -> Symbol.t -> Allocated_const.t option - - val keep_only_symbols : t -> t -end = struct - type t = - { subst : (Clambda.ulambda * Lambda.layout) Variable.Map.t; - var : (V.t * Lambda.layout) Variable.Map.t; - mutable_var : (V.t * Lambda.layout) Mutable_variable.Map.t; - allocated_constant_for_symbol : Allocated_const.t Symbol.Map.t; - } - - let empty = - { subst = Variable.Map.empty; - var = Variable.Map.empty; - mutable_var = Mutable_variable.Map.empty; - allocated_constant_for_symbol = Symbol.Map.empty; - } - - let add_subst t id subst layout = - { t with subst = Variable.Map.add id (subst, layout) t.subst } - - let find_subst_exn t id = Variable.Map.find id t.subst - - let ident_for_var_exn t id = Variable.Map.find id t.var - - let add_fresh_ident t var layout = - let id = V.create_local (Variable.name var) in - id, { t with var = Variable.Map.add var (id, layout) t.var } - - let ident_for_mutable_var_exn t mut_var = - Mutable_variable.Map.find mut_var t.mutable_var - - let add_fresh_mutable_ident t mut_var layout = - let id = V.create_local (Mutable_variable.name mut_var) in - let mutable_var = - Mutable_variable.Map.add mut_var (id, layout) t.mutable_var - in - id, { t with mutable_var; } - - let add_allocated_const t sym cons = - { t with - allocated_constant_for_symbol = - Symbol.Map.add sym cons t.allocated_constant_for_symbol; - } - - let allocated_const_for_symbol t sym = - try - Some (Symbol.Map.find sym t.allocated_constant_for_symbol) - with Not_found -> None - - let keep_only_symbols t = - { empty with - allocated_constant_for_symbol = t.allocated_constant_for_symbol; - } -end - -let subst_var env var : Clambda.ulambda * Lambda.layout = - try Env.find_subst_exn env var - with Not_found -> - try - let v, layout = Env.ident_for_var_exn env var in - Uvar v, layout - with Not_found -> - Misc.fatal_errorf "Flambda_to_clambda: unbound variable %a@." - Variable.print var - -let subst_vars env vars = List.map (subst_var env) vars - -let build_uoffset ulam offset : Clambda.ulambda = - if offset = 0 then ulam - else Uoffset (ulam, offset) - -let to_clambda_allocated_constant (const : Allocated_const.t) - : Clambda.ustructured_constant = - match const with - | Float f -> Uconst_float f - | Int32 i -> Uconst_int32 i - | Int64 i -> Uconst_int64 i - | Nativeint i -> Uconst_nativeint i - | Immutable_string s | String s -> Uconst_string s - | Immutable_float_array a | Float_array a -> Uconst_float_array a - -let to_uconst_symbol env symbol : Clambda.ustructured_constant option = - match Env.allocated_const_for_symbol env symbol with - | Some ((Float _ | Int32 _ | Int64 _ | Nativeint _) as const) -> - Some (to_clambda_allocated_constant const) - | None (* CR-soon mshinwell: Try to make this an error. *) - | Some _ -> None - -let to_clambda_symbol' env sym : Clambda.uconstant = - let lbl = Symbol.linkage_name sym |> Linkage_name.to_string in - Uconst_ref (lbl, to_uconst_symbol env sym) - -let to_clambda_symbol env sym : Clambda.ulambda = - Uconst (to_clambda_symbol' env sym) - -let to_clambda_const env (const : Flambda.constant_defining_value_block_field) - : Clambda.uconstant = - match const with - | Symbol symbol -> to_clambda_symbol' env symbol - | Const (Int i) -> Uconst_int i - | Const (Char c) -> Uconst_int (Char.code c) - -let layout_of_atom (atom : Closure_offsets.layout_atom) : Lambda.layout = - match atom with - | Value -> Pvalue Pgenval - | Value_int -> Pvalue Pintval - | Unboxed_float -> Punboxed_float - | Unboxed_int bi -> Punboxed_int bi - | Unboxed_vector bv -> Punboxed_vector bv - -let load_env_field ~fun_offset - ~closure_using_field (parts : Closure_offsets.parts) : Clambda.ulambda = - let rec rebuild (parts : Closure_offsets.parts) : Clambda.ulambda * Clambda_primitives.layout = - match parts with - | Atom { offset = var_offset; layout } -> - let pos = var_offset - fun_offset in - let layout = layout_of_atom layout in - Uprim (Pfield (pos, layout, Pointer, Immutable), - [closure_using_field pos], Debuginfo.none), layout - | Product parts -> - let parts = Array.to_list @@ Array.map rebuild parts in - let parts, layouts = List.split parts in - Uprim (Pmake_unboxed_product layouts, parts, Debuginfo.none), - Punboxed_product layouts - in - let expr, _layout = rebuild parts in - expr - -let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda * Lambda.layout = - match flam with - | Var var -> subst_var env var - | Let { var; defining_expr; body; _ } -> - let defining_expr, defining_expr_layout = to_clambda_named t env var defining_expr in - let id, env_body = Env.add_fresh_ident env var defining_expr_layout in - let body, body_layout = to_clambda t env_body body in - Ulet (Immutable, defining_expr_layout, VP.create id, defining_expr, body), - body_layout - | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> - let id, env_body = Env.add_fresh_mutable_ident env mut_var contents_kind in - let def, def_layout = subst_var env var in - assert(Lambda.compatible_layout def_layout contents_kind); - let body, body_layout = to_clambda t env_body body in - Ulet (Mutable, contents_kind, VP.create id, def, body), body_layout - | Let_rec (defs, body) -> - let env, defs = - List.fold_right (fun (var, def) (env, defs) -> - let id, env = Env.add_fresh_ident env var Lambda.layout_letrec in - env, (id, var, def) :: defs) - defs (env, []) - in - let defs = - List.map (fun (id, var, def) -> - let def, def_layout = to_clambda_named t env var def in - assert(Lambda.compatible_layout def_layout Lambda.layout_letrec); - VP.create id, def) - defs - in - let body, body_layout = to_clambda t env body in - Uletrec (defs, body), body_layout - | Apply { func; args; kind = Direct direct_func; probe; dbg; reg_close; mode; result_layout } -> - (* The closure _parameter_ of the function is added by cmmgen. - At the call site, for a direct call, the closure argument must be - explicitly added (by [to_clambda_direct_apply]); there is no special - handling of such in the direct call primitive. - For an indirect call, we do not need to do anything here; Cmmgen will - do the equivalent of the previous paragraph when it generates a direct - call to [caml_apply]. *) - to_clambda_direct_apply t func args direct_func probe dbg reg_close mode result_layout env, - result_layout - | Apply { func; args; kind = Indirect; probe = None; dbg; reg_close; mode; result_layout } -> - let callee, callee_layout = subst_var env func in - assert(Lambda.compatible_layout callee_layout Lambda.layout_function); - let args, args_layout = List.split (subst_vars env args) in - Ugeneric_apply (check_closure t callee (Flambda.Expr (Var func)), - args, args_layout, result_layout, (reg_close, mode), dbg), - result_layout - | Apply { probe = Some {name}; _ } -> - Misc.fatal_errorf "Cannot apply indirect handler for probe %s" name () - | Switch (arg, sw) -> - let aux () : Clambda.ulambda * Lambda.layout = - let const_index, const_actions = - to_clambda_switch t env sw.consts sw.numconsts sw.failaction sw.kind - in - let block_index, block_actions = - to_clambda_switch t env sw.blocks sw.numblocks sw.failaction sw.kind - in - let arg, arg_layout = subst_var env arg in - assert(Lambda.compatible_layout arg_layout Lambda.layout_any_value); - Uswitch (arg, - { us_index_consts = const_index; - us_actions_consts = const_actions; - us_index_blocks = block_index; - us_actions_blocks = block_actions; - }, - Debuginfo.none, sw.kind), (* debug info will be added by GPR#855 *) - sw.kind - in - (* Check that the [failaction] may be duplicated. If this is not the - case, share it through a static raise / static catch. *) - (* CR-someday pchambart for pchambart: This is overly simplified. - We should verify that this does not generates too bad code. - If it the case, handle some let cases. - *) - begin match sw.failaction with - | None -> aux () - | Some (Static_raise _) -> aux () - | Some failaction -> - let exn = Static_exception.create () in - let sw = - { sw with - failaction = Some (Flambda.Static_raise (exn, [])); - } - in - let expr : Flambda.t = - Static_catch (exn, [], Switch (arg, sw), failaction, sw.kind) - in - to_clambda t env expr - end - | String_switch (arg, sw, def, kind) -> - let arg, arg_layout = subst_var env arg in - assert(Lambda.compatible_layout arg_layout Lambda.layout_string); - let sw = - List.map (fun (s, e) -> - let e, layout = to_clambda t env e in - assert(Lambda.compatible_layout layout kind); - s, e - ) sw - in - let def = - Option.map (fun e -> - let e, layout = to_clambda t env e in - assert(Lambda.compatible_layout layout kind); - e - ) def - in - Ustringswitch (arg, sw, def, kind), kind - | Static_raise (static_exn, args) -> - (* CR pchambart: there probably should be an assertion that the - layouts matches the static_catch ones *) - let args = - List.map (fun arg -> - let arg, _layout = subst_var env arg in - arg - ) args - in - Ustaticfail (Static_exception.to_int static_exn, args), - Lambda.layout_bottom - | Static_catch (static_exn, vars, body, handler, kind) -> - let env_handler, ids = - List.fold_right (fun (var, layout) (env, ids) -> - let id, env = Env.add_fresh_ident env var layout in - env, (VP.create id, layout) :: ids) - vars (env, []) - in - let body, body_layout = to_clambda t env body in - let handler, handler_layout = to_clambda t env_handler handler in - assert(Lambda.compatible_layout body_layout kind); - assert(Lambda.compatible_layout handler_layout kind); - Ucatch (Static_exception.to_int static_exn, ids, - body, handler, kind), - kind - | Try_with (body, var, handler, kind) -> - let id, env_handler = Env.add_fresh_ident env var Lambda.layout_exception in - let body, body_layout = to_clambda t env body in - let handler, handler_layout = to_clambda t env_handler handler in - assert(Lambda.compatible_layout body_layout kind); - assert(Lambda.compatible_layout handler_layout kind); - Utrywith (body, VP.create id, handler, kind), - kind - | If_then_else (arg, ifso, ifnot, kind) -> - let arg, arg_layout = subst_var env arg in - let ifso, ifso_layout = to_clambda t env ifso in - let ifnot, ifnot_layout = to_clambda t env ifnot in - assert(Lambda.compatible_layout arg_layout Lambda.layout_any_value); - assert(Lambda.compatible_layout ifso_layout kind); - assert(Lambda.compatible_layout ifnot_layout kind); - Uifthenelse (arg, ifso, ifnot, kind), - kind - | While (cond, body) -> - let cond, cond_layout = to_clambda t env cond in - let body, body_layout = to_clambda t env body in - assert(Lambda.compatible_layout cond_layout Lambda.layout_any_value); - assert(Lambda.compatible_layout body_layout Lambda.layout_unit); - Uwhile (cond, body), - Lambda.layout_unit - | For { bound_var; from_value; to_value; direction; body } -> - let id, env_body = Env.add_fresh_ident env bound_var Lambda.layout_int in - let from_value, from_value_layout = subst_var env from_value in - let to_value, to_value_layout = subst_var env to_value in - let body, body_layout = to_clambda t env_body body in - assert(Lambda.compatible_layout from_value_layout Lambda.layout_int); - assert(Lambda.compatible_layout to_value_layout Lambda.layout_int); - assert(Lambda.compatible_layout body_layout Lambda.layout_unit); - Ufor (VP.create id, from_value, to_value, direction, body), - Lambda.layout_unit - | Assign { being_assigned; new_value } -> - let id, id_layout = - try Env.ident_for_mutable_var_exn env being_assigned - with Not_found -> - Misc.fatal_errorf "Unbound mutable variable %a in [Assign]: %a" - Mutable_variable.print being_assigned - Flambda.print flam - in - let new_value, new_value_layout = subst_var env new_value in - assert(Lambda.compatible_layout id_layout new_value_layout); - Uassign (id, new_value), - Lambda.layout_unit - | Send { kind; meth; obj; args; dbg; reg_close; mode; result_layout } -> - let args, args_layout = List.split (subst_vars env args) in - let meth, _meth_layout = subst_var env meth in - let obj, _obj_layout = subst_var env obj in - Usend (kind, meth, obj, - args, args_layout, result_layout, (reg_close,mode), dbg), - result_layout - | Region body -> - let body, body_layout = to_clambda t env body in - let is_trivial = - match body with - | Uvar _ | Uconst _ -> true - | _ -> false - in - if is_trivial then body, body_layout - else Uregion body, body_layout - | Exclave body -> - let body, body_layout = to_clambda t env body in - let is_trivial = - match body with - | Uvar _ | Uconst _ -> true - | _ -> false - in - if is_trivial then body, body_layout - else Uexclave body, body_layout - | Proved_unreachable -> Uunreachable, Lambda.layout_bottom - -and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda * Lambda.layout = - match named with - | Symbol sym -> to_clambda_symbol env sym, Lambda.layout_any_value - | Const (Int n) -> Uconst (Uconst_int n), Lambda.layout_int - | Const (Char c) -> Uconst (Uconst_int (Char.code c)), Lambda.layout_int - | Allocated_const _ -> - Misc.fatal_errorf "[Allocated_const] should have been lifted to a \ - [Let_symbol] construction before [Flambda_to_clambda]: %a = %a" - Variable.print var - Flambda.print_named named - | Read_mutable mut_var -> - begin try - let mut_var, layout = Env.ident_for_mutable_var_exn env mut_var in - Uvar mut_var, layout - with Not_found -> - Misc.fatal_errorf "Unbound mutable variable %a in [Read_mutable]: %a" - Mutable_variable.print mut_var - Flambda.print_named named - end - | Read_symbol_field (symbol, field) -> - Uprim (Pfield (field, Pvalue Pgenval, Pointer, Mutable), - [to_clambda_symbol env symbol], Debuginfo.none), - Lambda.layout_any_value - | Set_of_closures set_of_closures -> - to_clambda_set_of_closures t env set_of_closures, - Lambda.layout_any_value - | Project_closure { set_of_closures; closure_id } -> - (* Note that we must use [build_uoffset] to ensure that we do not generate - a [Uoffset] construction in the event that the offset is zero, otherwise - we might break pattern matches in Cmmgen (in particular for the - compilation of "let rec"). *) - let set_of_closures_expr, _layout_set_of_closures = - subst_var env set_of_closures - in - check_closure t ( - build_uoffset - (check_closure t set_of_closures_expr - (Flambda.Expr (Var set_of_closures))) - (get_fun_offset t closure_id)) - named, - Lambda.layout_function - | Move_within_set_of_closures { closure; start_from; move_to } -> - let closure_expr, _layout_closure = subst_var env closure in - check_closure t (build_uoffset - (check_closure t closure_expr - (Flambda.Expr (Var closure))) - ((get_fun_offset t move_to) - (get_fun_offset t start_from))) - named, - Lambda.layout_function - | Project_var { closure; var; closure_id; kind } -> begin - let ulam, _closure_layout = subst_var env closure in - let fun_offset = get_fun_offset t closure_id in - let var_offset = get_fv_offset t var in - let check_field pos = - check_field t (check_closure t ulam (Expr (Var closure))) - pos (Some named) - in - load_env_field ~fun_offset ~closure_using_field:check_field var_offset, - kind - end - | Prim (Pfield (index, layout, imm_or_ptr, sem), [block], dbg) -> - begin match layout with - | Pvalue _ -> () - | _ -> - Misc.fatal_errorf "Pfield can only be of layout value %a" - Flambda.print_named named - end; - let block, _block_layout = subst_var env block in - Uprim (Pfield (index, layout, imm_or_ptr, sem), - [check_field t block index None], dbg), - Lambda.layout_field - | Prim (Psetfield (index, maybe_ptr, init), [block; new_value], dbg) -> - let block, _block_layout = subst_var env block in - let new_value, _new_value_layout = subst_var env new_value in - Uprim (Psetfield (index, maybe_ptr, init), [ - check_field t block index None; - new_value; - ], dbg), - Lambda.layout_unit - | Prim (Popaque, args, dbg) -> - let arg = match args with - | [arg] -> arg - | [] | _ :: _ :: _ -> assert false - in - let arg, arg_layout = subst_var env arg in - Uprim (Popaque, [arg], dbg), - arg_layout - | Prim (p, args, dbg) -> - let args, _args_layout = List.split (subst_vars env args) in - let result_layout = Clambda_primitives.result_layout p in - Uprim (p, args, dbg), - result_layout - | Expr expr -> to_clambda t env expr - -and to_clambda_switch t env cases num_keys default kind = - let num_keys = - if Numbers.Int.Set.cardinal num_keys = 0 then 0 - else Numbers.Int.Set.max_elt num_keys + 1 - in - let store = Flambda_utils.Switch_storer.mk_store () in - let default_action = - match default with - | Some def when List.length cases < num_keys -> - store.act_store () def - | _ -> -1 - in - let index = Array.make num_keys default_action in - let smallest_key = ref num_keys in - List.iter - (fun (key, lam) -> - index.(key) <- store.act_store () lam; - smallest_key := Int.min key !smallest_key - ) - cases; - if !smallest_key < num_keys then begin - let action = ref index.(!smallest_key) in - Array.iteri - (fun i act -> - if act >= 0 then action := act else index.(i) <- !action) - index - end; - let actions = - Array.map (fun action -> - let action, action_layout = to_clambda t env action in - assert(Lambda.compatible_layout action_layout kind); - action - ) (store.act_get ()) - in - match actions with - | [| |] -> [| |], [| |] (* May happen when [default] is [None]. *) - | _ -> index, actions - -and to_clambda_direct_apply t func args direct_func probe dbg pos mode result_layout env - : Clambda.ulambda = - let closed = is_function_constant t direct_func in - let label = - Symbol_utils.Flambda.for_code_of_closure direct_func - |> Symbol.linkage_name - |> Linkage_name.to_string - in - let uargs = - let uargs, _uargs_layout = List.split (subst_vars env args) in - (* Remove the closure argument if the closure is closed. (Note that the - closure argument is always a variable, so we can be sure we are not - dropping any side effects.) *) - if closed then uargs else - let func, func_layout = subst_var env func in - assert(Lambda.compatible_layout func_layout Lambda.layout_function); - uargs @ [func] - in - Udirect_apply (label, uargs, probe, result_layout, (pos, mode), dbg) - -(* Describe how to build a runtime closure block that corresponds to the - given Flambda set of closures. - - For instance the closure for the following set of closures: - - let rec fun_a x = - if x <= 0 then 0 else fun_b (x-1) v1 - and fun_b x y = - if x <= 0 then 0 else v1 + v2 + y + fun_a (x-1) - - will be represented in memory as: - - [ closure header; fun_a; - 1; infix header; fun caml_curry_2; - 2; fun_b; v1; v2 ] - - fun_a and fun_b will take an additional parameter 'env' to - access their closure. It will be arranged such that in the body - of each function the env parameter points to its own code - pointer. For example, in fun_b it will be shifted by 3 words. - - Hence accessing v1 in the body of fun_a is accessing the - 6th field of 'env' and in the body of fun_b the 1st field. -*) -and to_clambda_set_of_closures t env - (({ function_decls; free_vars } : Flambda.set_of_closures) - as set_of_closures) : Clambda.ulambda = - let all_functions = Variable.Map.bindings function_decls.funs in - let env_var = V.create_local "env" in - let to_clambda_function - (closure_id, (function_decl : Flambda.function_declaration)) - : Clambda.ufunction = - let closure_id = Closure_id.wrap closure_id in - let fun_offset = - Closure_id.Map.find closure_id t.current_unit.fun_offset_table - in - let env = - (* Inside the body of the function, we cannot access variables - declared outside, so start with a suitably clean environment. - Note that we must not forget the information about which allocated - constants contain which unboxed values. *) - let env = Env.keep_only_symbols env in - (* Add the Clambda expressions for the free variables of the function - to the environment. *) - let add_env_free_variable id (spec_to : Flambda.specialised_to) env = - let var_offset = - try - Var_within_closure.Map.find - (Var_within_closure.wrap id) t.current_unit.fv_offset_table - with Not_found -> - Misc.fatal_errorf "Clambda.to_clambda_set_of_closures: offset for \ - free variable %a is unknown. Set of closures: %a" - Variable.print id - Flambda.print_set_of_closures set_of_closures - in - let expr = - let closure_using_field _pos = Clambda.Uvar env_var in - load_env_field ~fun_offset ~closure_using_field var_offset - in - Env.add_subst env id expr spec_to.kind - in - let env = Variable.Map.fold add_env_free_variable free_vars env in - (* Add the Clambda expressions for all functions defined in the current - set of closures to the environment. The various functions may be - retrieved by moving within the runtime closure, starting from the - current function's closure. *) - let add_env_function pos env (id, _) = - let offset = - Closure_id.Map.find (Closure_id.wrap id) - t.current_unit.fun_offset_table - in - let exp : Clambda.ulambda = Uoffset (Uvar env_var, offset - pos) in - Env.add_subst env id exp Lambda.layout_function - in - List.fold_left (add_env_function fun_offset) env all_functions - in - let env_body, params = - List.fold_right (fun param (env, params) -> - let id, env = - Env.add_fresh_ident env - (Parameter.var param) (Parameter.kind param) - in - env, VP.create id :: params) - function_decl.params (env, []) - in - let label = - Symbol_utils.Flambda.for_code_of_closure closure_id - |> Symbol.linkage_name - |> Linkage_name.to_string - in - let body, _body_layout = to_clambda t env_body function_decl.body in - { label; - arity = clambda_arity function_decl; - params = params @ [VP.create env_var]; - body; - dbg = function_decl.dbg; - env = Some env_var; - poll = function_decl.poll; - mode = set_of_closures.alloc_mode; - check = function_decl.check; - } - in - let functions = List.map to_clambda_function all_functions in - let not_scanned_fv, scanned_fv = - let free_vars = Variable.Map.bindings free_vars in - List.fold_left (fun acc (_var, (free_var : Flambda.specialised_to)) -> - let f (not_scanned_fv, scanned_fv) - (expr: Clambda.ulambda) (atom : Closure_offsets.layout_atom) = - match atom with - | Value -> not_scanned_fv, (expr :: scanned_fv) - | Value_int | Unboxed_float | Unboxed_int _ | Unboxed_vector _ -> - (expr :: not_scanned_fv, scanned_fv) - in - let closure, var_layout = subst_var env free_var.var in - assert(Lambda.compatible_layout var_layout free_var.kind); - Clambda_layout.fold_left_layout f acc closure free_var.kind - ) ([],[]) free_vars - in - let not_scanned_slots, scanned_slots = List.rev not_scanned_fv, List.rev scanned_fv in - Uclosure { functions; not_scanned_slots; scanned_slots; } - -and to_clambda_closed_set_of_closures t env symbol - ({ function_decls; } : Flambda.set_of_closures) - : Clambda.ustructured_constant = - let functions = Variable.Map.bindings function_decls.funs in - let to_clambda_function (id, (function_decl : Flambda.function_declaration)) - : Clambda.ufunction = - (* All that we need in the environment, for translating one closure from - a closed set of closures, is the substitutions for variables bound to - the various closures in the set. Such closures will always be - referenced via symbols. *) - let env = - List.fold_left (fun env (var, _) -> - let closure_id = Closure_id.wrap var in - let symbol = Symbol_utils.Flambda.for_closure closure_id in - Env.add_subst env var (to_clambda_symbol env symbol) - Lambda.layout_function) - (Env.keep_only_symbols env) - functions - in - let env_body, params = - List.fold_right (fun param (env, params) -> - let id, env = - Env.add_fresh_ident env - (Parameter.var param) (Parameter.kind param) - in - env, VP.create id :: params) - function_decl.params (env, []) - in - let body = - let body, body_layout = to_clambda t env_body function_decl.body in - if not (Lambda.compatible_layout body_layout function_decl.return_layout) then - Misc.fatal_errorf "Incompatible layouts:@.body: %a@.function: %a@.%a@." - Printlambda.layout body_layout - Printlambda.layout function_decl.return_layout - Printclambda.clambda body; - Un_anf.apply ~ppf_dump:t.ppf_dump ~what:symbol body - in - assert ( - Option.equal (fun dbg1 dbg2 -> Debuginfo.compare dbg1 dbg2 = 0) - (Variable.debug_info id) (Some function_decl.dbg)); - let label = - Symbol_utils.Flambda.for_code_of_closure (Closure_id.wrap id) - |> Symbol.linkage_name - |> Linkage_name.to_string - in - { label; - arity = clambda_arity function_decl; - params; - body; - dbg = function_decl.dbg; - env = None; - poll = function_decl.poll; - mode = Lambda.alloc_heap; - check = function_decl.check; - } - in - let ufunct = List.map to_clambda_function functions in - let closure_lbl = Symbol.linkage_name symbol |> Linkage_name.to_string in - Uconst_closure (ufunct, closure_lbl, []) - -let to_clambda_initialize_symbol t env symbol fields : Clambda.ulambda = - let fields = - List.map (fun (index, expr) -> - let expr, expr_layout = to_clambda t env expr in - assert(Lambda.compatible_layout expr_layout Lambda.layout_any_value); - index, expr - ) fields - in - let build_setfield (index, field) : Clambda.ulambda = - (* Note that this will never cause a write barrier hit, owing to - the [Initialization]. *) - Uprim (Psetfield (index, Pointer, Root_initialization), - [to_clambda_symbol env symbol; field], - Debuginfo.none) - in - match fields with - | [] -> Uconst (Uconst_int 0) - | h :: t -> - List.fold_left (fun acc (p, field) -> - Clambda.Usequence (build_setfield (p, field), acc)) - (build_setfield h) t - -let accumulate_structured_constants t env symbol - (c : Flambda.constant_defining_value) acc = - match c with - | Allocated_const c -> - Symbol.Map.add symbol (to_clambda_allocated_constant c) acc - | Block (tag, fields) -> - let fields = List.map (to_clambda_const env) fields in - Symbol.Map.add symbol (Clambda.Uconst_block (Tag.to_int tag, fields)) acc - | Set_of_closures set_of_closures -> - let to_clambda_set_of_closures = - to_clambda_closed_set_of_closures t env symbol set_of_closures - in - Symbol.Map.add symbol to_clambda_set_of_closures acc - | Project_closure _ -> acc - -let to_clambda_program t env constants (program : Flambda.program) = - let rec loop env constants (program : Flambda.program_body) - : Clambda.ulambda * - Clambda.ustructured_constant Symbol.Map.t * - Clambda.preallocated_block list = - match program with - | Let_symbol (symbol, alloc, program) -> - (* Useful only for unboxing. Since floats and boxed integers will - never be part of a Let_rec_symbol, handling only the Let_symbol - is sufficient. *) - let env = - match alloc with - | Allocated_const const -> Env.add_allocated_const env symbol const - | _ -> env - in - let constants = - accumulate_structured_constants t env symbol alloc constants - in - loop env constants program - | Let_rec_symbol (defs, program) -> - let constants = - List.fold_left (fun constants (symbol, alloc) -> - accumulate_structured_constants t env symbol alloc constants) - constants defs - in - loop env constants program - | Initialize_symbol (symbol, tag, fields, program) -> - let fields = - List.mapi (fun i field -> - i, field, - Initialize_symbol_to_let_symbol.constant_field field) - fields - in - let init_fields = - List.filter_map (function - | (i, field, None) -> Some (i, field) - | (_, _, Some _) -> None) - fields - in - let constant_fields = - List.map (fun (_, _, constant_field) -> - match constant_field with - | None -> None - | Some (Flambda.Const const) -> - let n = - match const with - | Int i -> i - | Char c -> Char.code c - in - Some (Clambda.Uconst_field_int n) - | Some (Flambda.Symbol sym) -> - let lbl = Symbol.linkage_name sym |> Linkage_name.to_string in - Some (Clambda.Uconst_field_ref lbl)) - fields - in - let e1 = to_clambda_initialize_symbol t env symbol init_fields in - let preallocated_block : Clambda.preallocated_block = - { symbol = Symbol.linkage_name symbol |> Linkage_name.to_string; - exported = true; - tag = Tag.to_int tag; - fields = constant_fields; - provenance = None; - } - in - let e2, constants, preallocated_blocks = loop env constants program in - Usequence (e1, e2), constants, preallocated_block :: preallocated_blocks - | Effect (expr, program) -> - let e1, _e1_layout = to_clambda t env expr in - let e2, constants, preallocated_blocks = loop env constants program in - Usequence (e1, e2), constants, preallocated_blocks - | End _ -> - Uconst (Uconst_int 0), constants, [] - in - loop env constants program.program_body - -type result = { - expr : Clambda.ulambda; - preallocated_blocks : Clambda.preallocated_block list; - structured_constants : Clambda.ustructured_constant Symbol.Map.t; - exported : Export_info.t; -} - -let convert ~ppf_dump (program, exported_transient) : result = - let current_unit = - let closures = - Closure_id.Map.keys (Flambda_utils.make_closure_map program) - in - let constant_closures = - Flambda_utils.all_lifted_constant_closures program - in - let offsets = Closure_offsets.compute program in - { fun_offset_table = offsets.function_offsets; - fv_offset_table = offsets.free_variable_offsets; - constant_closures; - closures; - } - in - let imported_units = - let imported = Compilenv.approx_env () in - let closures = - Set_of_closures_id.Map.fold - (fun (_ : Set_of_closures_id.t) fun_decls acc -> - Variable.Map.fold - (fun var (_ : Simple_value_approx.function_declaration) acc -> - let closure_id = Closure_id.wrap var in - Closure_id.Set.add closure_id acc) - fun_decls.Simple_value_approx.funs - acc) - imported.sets_of_closures - Closure_id.Set.empty - in - { fun_offset_table = imported.offset_fun; - fv_offset_table = imported.offset_fv; - constant_closures = imported.constant_closures; - closures; - } - in - let t = - { current_unit; - imported_units; - constants_for_instrumentation = Symbol.Map.empty; - ppf_dump; - } - in - let expr, structured_constants, preallocated_blocks = - to_clambda_program t Env.empty Symbol.Map.empty program - in - let structured_constants = - Symbol.Map.disjoint_union structured_constants - t.constants_for_instrumentation - in - let exported = - if !Clflags.opaque then - Export_info.t_of_opaque_transient exported_transient - else - Export_info.t_of_transient exported_transient - ~program - ~local_offset_fun:current_unit.fun_offset_table - ~local_offset_fv:current_unit.fv_offset_table - ~imported_offset_fun:imported_units.fun_offset_table - ~imported_offset_fv:imported_units.fv_offset_table - ~constant_closures:current_unit.constant_closures - in - { expr; preallocated_blocks; structured_constants; exported; } diff --git a/middle_end/flambda/flambda_to_clambda.mli b/middle_end/flambda/flambda_to_clambda.mli deleted file mode 100644 index d08af3e2bad..00000000000 --- a/middle_end/flambda/flambda_to_clambda.mli +++ /dev/null @@ -1,41 +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"] - -type result = { - expr : Clambda.ulambda; - preallocated_blocks : Clambda.preallocated_block list; - structured_constants : Clambda.ustructured_constant Symbol.Map.t; - exported : Export_info.t; -} - -(** Convert an Flambda program, with associated proto-export information, - to Clambda. - This yields a Clambda expression together with augmented export - information and details about required statically-allocated values - (preallocated blocks, for [Initialize_symbol], and structured - constants). - - It is during this process that accesses to variables within - closures are transformed to field accesses within closure values. - For direct calls, the hidden closure parameter is added. Switch - tables are also built. -*) -val convert - : ppf_dump:Format.formatter - -> Flambda.program * Export_info.transient - -> result diff --git a/middle_end/flambda/flambda_utils.ml b/middle_end/flambda/flambda_utils.ml deleted file mode 100644 index 67444a34e7c..00000000000 --- a/middle_end/flambda/flambda_utils.ml +++ /dev/null @@ -1,941 +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-66"] -open! Int_replace_polymorphic_compare - -let name_expr ~name (named : Flambda.named) : Flambda.t = - let var = - Variable.create - ~current_compilation_unit:(Compilation_unit.get_current_exn ()) - name - in - Flambda.create_let var named (Var var) - -let name_expr_from_var ~var (named : Flambda.named) : Flambda.t = - let var = - Variable.rename - ~current_compilation_unit:(Compilation_unit.get_current_exn ()) - var - in - Flambda.create_let var named (Var var) - -let find_declaration cf ({ funs } : Flambda.function_declarations) = - Variable.Map.find (Closure_id.unwrap cf) funs - -let find_declaration_variable cf ({ funs } : Flambda.function_declarations) = - let var = Closure_id.unwrap cf in - if not (Variable.Map.mem var funs) - then raise Not_found - else var - -let find_free_variable cv ({ free_vars } : Flambda.set_of_closures) = - let var : Flambda.specialised_to = - Variable.Map.find (Var_within_closure.unwrap cv) free_vars - in - var.var - -let function_arity (f : Flambda.function_declaration) = List.length f.params - -let variables_bound_by_the_closure cf - (decls : Flambda.function_declarations) = - let func = find_declaration cf decls in - let params = Parameter.Set.vars func.params in - let functions = Variable.Map.keys decls.funs in - Variable.Set.diff - (Variable.Set.diff func.free_variables params) - functions - -let description_of_toplevel_node (expr : Flambda.t) = - match expr with - | Var id -> Format.asprintf "var %a" Variable.print id - | Apply _ -> "apply" - | Assign _ -> "assign" - | Send _ -> "send" - | Proved_unreachable -> "unreachable" - | Let { var; _ } -> Format.asprintf "let %a" Variable.print var - | Let_mutable _ -> "let_mutable" - | Let_rec _ -> "letrec" - | If_then_else _ -> "if" - | Switch _ -> "switch" - | String_switch _ -> "stringswitch" - | Static_raise _ -> "staticraise" - | Static_catch _ -> "catch" - | Try_with _ -> "trywith" - | While _ -> "while" - | For _ -> "for" - | Region _ -> "region" - | Exclave _ -> "exclave" - -let equal_direction_flag - (x : Asttypes.direction_flag) - (y : Asttypes.direction_flag) = - match x, y with - | Upto, Upto -> true - | Downto, Downto -> true - | (Upto | Downto), _ -> false - -let rec same (l1 : Flambda.t) (l2 : Flambda.t) = - l1 == l2 || (* it is ok for the string case: if they are physically the same, - it is the same original branch *) - match (l1, l2) with - | Var v1 , Var v2 -> Variable.equal v1 v2 - | Var _, _ | _, Var _ -> false - | Apply a1 , Apply a2 -> - Flambda.equal_call_kind a1.kind a2.kind - && Variable.equal a1.func a2.func - && Misc.Stdlib.List.equal Variable.equal a1.args a2.args - | Apply _, _ | _, Apply _ -> false - | Let { var = var1; defining_expr = defining_expr1; body = body1; _ }, - Let { var = var2; defining_expr = defining_expr2; body = body2; _ } -> - Variable.equal var1 var2 && same_named defining_expr1 defining_expr2 - && same body1 body2 - | Let _, _ | _, Let _ -> false - | Let_mutable {var = mv1; initial_value = v1; contents_kind = ck1; body = b1}, - Let_mutable {var = mv2; initial_value = v2; contents_kind = ck2; body = b2} - -> - Mutable_variable.equal mv1 mv2 - && Variable.equal v1 v2 - && Lambda.equal_layout ck1 ck2 - && same b1 b2 - | Let_mutable _, _ | _, Let_mutable _ -> false - | Let_rec (bl1, a1), Let_rec (bl2, a2) -> - Misc.Stdlib.List.equal samebinding bl1 bl2 && same a1 a2 - | Let_rec _, _ | _, Let_rec _ -> false - | Switch (a1, s1), Switch (a2, s2) -> - Variable.equal a1 a2 && sameswitch s1 s2 - | Switch _, _ | _, Switch _ -> false - | String_switch (a1, s1, d1, k1), String_switch (a2, s2, d2, k2) -> - Variable.equal a1 a2 - && Misc.Stdlib.List.equal - (fun (s1, e1) (s2, e2) -> String.equal s1 s2 && same e1 e2) s1 s2 - && Option.equal same d1 d2 - && Lambda.equal_layout k1 k2 - | String_switch _, _ | _, String_switch _ -> false - | Static_raise (e1, a1), Static_raise (e2, a2) -> - Static_exception.equal e1 e2 && Misc.Stdlib.List.equal Variable.equal a1 a2 - | Static_raise _, _ | _, Static_raise _ -> false - | Static_catch (s1, v1, a1, b1, k1), Static_catch (s2, v2, a2, b2, k2) -> - Static_exception.equal s1 s2 - && Misc.Stdlib.List.equal - (fun (v1, l1) (v2, l2) -> Variable.equal v1 v2 && Lambda.equal_layout l1 l2) - v1 v2 - && same a1 a2 - && same b1 b2 - && Lambda.equal_layout k1 k2 - | Static_catch _, _ | _, Static_catch _ -> false - | Try_with (a1, v1, b1, k1), Try_with (a2, v2, b2, k2) -> - same a1 a2 && Variable.equal v1 v2 && same b1 b2 - && Lambda.equal_layout k1 k2 - | Try_with _, _ | _, Try_with _ -> false - | If_then_else (a1, b1, c1, k1), If_then_else (a2, b2, c2, k2) -> - Variable.equal a1 a2 && same b1 b2 && same c1 c2 - && Lambda.equal_layout k1 k2 - | If_then_else _, _ | _, If_then_else _ -> false - | While (a1, b1), While (a2, b2) -> - same a1 a2 && same b1 b2 - | While _, _ | _, While _ -> false - | For { bound_var = bound_var1; from_value = from_value1; - to_value = to_value1; direction = direction1; body = body1; }, - For { bound_var = bound_var2; from_value = from_value2; - to_value = to_value2; direction = direction2; body = body2; } -> - Variable.equal bound_var1 bound_var2 - && Variable.equal from_value1 from_value2 - && Variable.equal to_value1 to_value2 - && equal_direction_flag direction1 direction2 - && same body1 body2 - | For _, _ | _, For _ -> false - | Region body1, Region body2 -> - same body1 body2 - | Region _, _ | _, Region _ -> false - | Exclave body1, Exclave body2 -> - same body1 body2 - | Exclave _, _ | _, Exclave _ -> false - | Assign { being_assigned = being_assigned1; new_value = new_value1; }, - Assign { being_assigned = being_assigned2; new_value = new_value2; } -> - Mutable_variable.equal being_assigned1 being_assigned2 - && Variable.equal new_value1 new_value2 - | Assign _, _ | _, Assign _ -> false - | Send { kind = kind1; meth = meth1; obj = obj1; args = args1; dbg = _; }, - Send { kind = kind2; meth = meth2; obj = obj2; args = args2; dbg = _; } -> - Lambda.equal_meth_kind kind1 kind2 - && Variable.equal meth1 meth2 - && Variable.equal obj1 obj2 - && Misc.Stdlib.List.equal Variable.equal args1 args2 - | Send _, _ | _, Send _ -> false - | Proved_unreachable, Proved_unreachable -> true - -and same_named (named1 : Flambda.named) (named2 : Flambda.named) = - match named1, named2 with - | Symbol s1 , Symbol s2 -> Symbol.equal s1 s2 - | Symbol _, _ | _, Symbol _ -> false - | Const c1, Const c2 -> Flambda.compare_const c1 c2 = 0 - | Const _, _ | _, Const _ -> false - | Allocated_const c1, Allocated_const c2 -> - Allocated_const.compare c1 c2 = 0 - | Allocated_const _, _ | _, Allocated_const _ -> false - | Read_mutable mv1, Read_mutable mv2 -> Mutable_variable.equal mv1 mv2 - | Read_mutable _, _ | _, Read_mutable _ -> false - | Read_symbol_field (s1, i1), Read_symbol_field (s2, i2) -> - Symbol.equal s1 s2 && i1 = i2 - | Read_symbol_field _, _ | _, Read_symbol_field _ -> false - | Set_of_closures s1, Set_of_closures s2 -> same_set_of_closures s1 s2 - | Set_of_closures _, _ | _, Set_of_closures _ -> false - | Project_closure f1, Project_closure f2 -> same_project_closure f1 f2 - | Project_closure _, _ | _, Project_closure _ -> false - | Project_var v1, Project_var v2 -> - Variable.equal v1.closure v2.closure - && Closure_id.equal v1.closure_id v2.closure_id - && Var_within_closure.equal v1.var v2.var - | Project_var _, _ | _, Project_var _ -> false - | Move_within_set_of_closures m1, Move_within_set_of_closures m2 -> - same_move_within_set_of_closures m1 m2 - | Move_within_set_of_closures _, _ | _, Move_within_set_of_closures _ -> - false - | Prim (p1, al1, _), Prim (p2, al2, _) -> - Clambda_primitives.equal p1 p2 - && Misc.Stdlib.List.equal Variable.equal al1 al2 - | Prim _, _ | _, Prim _ -> false - | Expr e1, Expr e2 -> same e1 e2 - -and sameclosure (c1 : Flambda.function_declaration) - (c2 : Flambda.function_declaration) = - Misc.Stdlib.List.equal Parameter.equal c1.params c2.params - && same c1.body c2.body - -and same_set_of_closures (c1 : Flambda.set_of_closures) - (c2 : Flambda.set_of_closures) = - Variable.Map.equal sameclosure c1.function_decls.funs c2.function_decls.funs - && Variable.Map.equal Flambda.equal_specialised_to - c1.free_vars c2.free_vars - && Variable.Map.equal Flambda.equal_specialised_to c1.specialised_args - c2.specialised_args - -and same_project_closure (s1 : Flambda.project_closure) - (s2 : Flambda.project_closure) = - Variable.equal s1.set_of_closures s2.set_of_closures - && Closure_id.equal s1.closure_id s2.closure_id - -and same_move_within_set_of_closures (m1 : Flambda.move_within_set_of_closures) - (m2 : Flambda.move_within_set_of_closures) = - Variable.equal m1.closure m2.closure - && Closure_id.equal m1.start_from m2.start_from - && Closure_id.equal m1.move_to m2.move_to - -and samebinding (v1, n1) (v2, n2) = - Variable.equal v1 v2 && same_named n1 n2 - -and sameswitch (fs1 : Flambda.switch) (fs2 : Flambda.switch) = - let samecase (n1, a1) (n2, a2) = n1 = n2 && same a1 a2 in - Numbers.Int.Set.equal fs1.numconsts fs2.numconsts - && Numbers.Int.Set.equal fs1.numblocks fs2.numblocks - && Misc.Stdlib.List.equal samecase fs1.consts fs2.consts - && Misc.Stdlib.List.equal samecase fs1.blocks fs2.blocks - && Option.equal same fs1.failaction fs2.failaction - && Lambda.equal_layout fs1.kind fs2.kind - -let can_be_merged = same - -(* CR-soon mshinwell: this should use the explicit ignore functions *) -let toplevel_substitution sb tree = - let sb' = sb in - let sb v = try Variable.Map.find v sb with Not_found -> v in - let aux (flam : Flambda.t) : Flambda.t = - match flam with - | Var var -> - let var = sb var in - Var var - | Let_mutable mutable_let -> - let initial_value = sb mutable_let.initial_value in - Let_mutable { mutable_let with initial_value } - | Assign { being_assigned; new_value; } -> - let new_value = sb new_value in - Assign { being_assigned; new_value; } - | Apply { func; args; kind; dbg; reg_close; mode; - inlined; specialise; probe; result_layout; } -> - let func = sb func in - let args = List.map sb args in - Apply { func; args; kind; dbg; reg_close; mode; - inlined; specialise; probe; result_layout; } - | If_then_else (cond, e1, e2, kind) -> - let cond = sb cond in - If_then_else (cond, e1, e2, kind) - | Switch (cond, sw) -> - let cond = sb cond in - Switch (cond, sw) - | String_switch (cond, branches, def, kind) -> - let cond = sb cond in - String_switch (cond, branches, def, kind) - | Send { kind; meth; obj; args; dbg; reg_close; mode; result_layout } -> - let meth = sb meth in - let obj = sb obj in - let args = List.map sb args in - Send { kind; meth; obj; args; dbg; reg_close; mode; result_layout } - | For { bound_var; from_value; to_value; direction; body } -> - let from_value = sb from_value in - let to_value = sb to_value in - For { bound_var; from_value; to_value; direction; body } - | Static_raise (static_exn, args) -> - let args = List.map sb args in - Static_raise (static_exn, args) - | Static_catch _ | Try_with _ | While _ | Region _ | Exclave _ - | Let _ | Let_rec _ | Proved_unreachable -> flam - in - let aux_named (named : Flambda.named) : Flambda.named = - match named with - | Symbol _ | Const _ | Expr _ -> named - | Allocated_const _ | Read_mutable _ -> named - | Read_symbol_field _ -> named - | Set_of_closures set_of_closures -> - let set_of_closures = - Flambda.create_set_of_closures - ~function_decls:set_of_closures.function_decls - ~free_vars: - (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - { spec_to with var = sb spec_to.var; }) - set_of_closures.free_vars) - ~specialised_args: - (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - { spec_to with var = sb spec_to.var; }) - set_of_closures.specialised_args) - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - Set_of_closures set_of_closures - | Project_closure project_closure -> - Project_closure { - project_closure with - set_of_closures = sb project_closure.set_of_closures; - } - | Move_within_set_of_closures move_within_set_of_closures -> - Move_within_set_of_closures { - move_within_set_of_closures with - closure = sb move_within_set_of_closures.closure; - } - | Project_var project_var -> - Project_var { - project_var with - closure = sb project_var.closure; - } - | Prim (prim, args, dbg) -> - Prim (prim, List.map sb args, dbg) - in - if Variable.Map.is_empty sb' then tree - else Flambda_iterators.map_toplevel aux aux_named tree - -(* CR-someday mshinwell: Fix [Flambda_iterators] so this can be implemented - properly. *) -let toplevel_substitution_named sb named = - let name = Internal_variable_names.toplevel_substitution_named in - let expr = name_expr named ~name in - match toplevel_substitution sb expr with - | Let let_expr -> let_expr.defining_expr - | _ -> assert false - -let make_closure_declaration - ~is_classic_mode ~id ~alloc_mode ~region ~body ~params ~return_layout ~free_variables : Flambda.t = - let param_set = Parameter.Set.vars params in - let free_variables_set = Variable.Map.keys free_variables in - if not (Variable.Set.subset param_set free_variables_set) then begin - Misc.fatal_error "Flambda_utils.make_closure_declaration" - end; - let sb = - Variable.Set.fold - (fun id sb -> Variable.Map.add id (Variable.rename id) sb) - free_variables_set Variable.Map.empty - in - (* CR-soon mshinwell: try to eliminate this [toplevel_substitution]. This - function is only called from [Inline_and_simplify], so we should be able - to do something similar to what happens in [Inlining_transforms] now. *) - let body = toplevel_substitution sb body in - let subst id = Variable.Map.find id sb in - let subst_param param = Parameter.map_var subst param in - let function_declaration = - Flambda.create_function_declaration - ~params:(List.map subst_param params) ~alloc_mode ~region - ~return_layout - ~body ~stub:true ~inline:Default_inline - ~specialise:Default_specialise ~check:Default_check ~is_a_functor:false - ~closure_origin:(Closure_origin.create (Closure_id.wrap id)) - ~poll:Default_poll - in - assert (Variable.Set.equal (Variable.Set.map subst free_variables_set) - function_declaration.free_variables); - let free_vars = - Variable.Map.fold (fun id id' fv' -> - let kind = Variable.Map.find id free_variables in - let spec_to : Flambda.specialised_to = - { var = id; - projection = None; - kind; - } - in - Variable.Map.add id' spec_to fv') - (Variable.Map.filter - (fun id _ -> not (Variable.Set.mem id param_set)) - sb) - Variable.Map.empty - in - let compilation_unit = Compilation_unit.get_current_exn () in - let set_of_closures_var = - Variable.create Internal_variable_names.set_of_closures - ~current_compilation_unit:compilation_unit - in - let set_of_closures = - let function_decls = - Flambda.create_function_declarations - ~is_classic_mode - ~funs:(Variable.Map.singleton id function_declaration) - in - Flambda.create_set_of_closures ~function_decls ~free_vars - ~specialised_args:Variable.Map.empty - ~direct_call_surrogates:Variable.Map.empty - in - let project_closure : Flambda.named = - Project_closure { - set_of_closures = set_of_closures_var; - closure_id = Closure_id.wrap id; - } - in - let project_closure_var = - Variable.create Internal_variable_names.project_closure - ~current_compilation_unit:compilation_unit - in - Flambda.create_let set_of_closures_var (Set_of_closures set_of_closures) - (Flambda.create_let project_closure_var project_closure - (Var (project_closure_var))) - -let bind ~bindings ~body = - List.fold_left (fun expr (var, var_def) -> - Flambda.create_let var var_def expr) - body bindings - -let all_lifted_constants (program : Flambda.program) = - let rec loop (program : Flambda.program_body) = - match program with - | Let_symbol (symbol, decl, program) -> (symbol, decl) :: (loop program) - | Let_rec_symbol (decls, program) -> - List.fold_left (fun l (symbol, decl) -> (symbol, decl) :: l) - (loop program) - decls - | Initialize_symbol (_, _, _, program) - | Effect (_, program) -> loop program - | End _ -> [] - in - loop program.program_body - -let all_lifted_constants_as_map program = - Symbol.Map.of_list (all_lifted_constants program) - -let initialize_symbols (program : Flambda.program) = - let rec loop (program : Flambda.program_body) = - match program with - | Initialize_symbol (symbol, tag, fields, program) -> - (symbol, tag, fields) :: (loop program) - | Effect (_, program) - | Let_symbol (_, _, program) - | Let_rec_symbol (_, program) -> loop program - | End _ -> [] - in - loop program.program_body - -let imported_symbols (program : Flambda.program) = - program.imported_symbols - -let needed_import_symbols (program : Flambda.program) = - let dependencies = Flambda.free_symbols_program program in - let defined_symbol = - Symbol.Set.union - (Symbol.Set.of_list - (List.map fst (all_lifted_constants program))) - (Symbol.Set.of_list - (List.map (fun (s, _, _) -> s) (initialize_symbols program))) - in - Symbol.Set.diff dependencies defined_symbol - -let introduce_needed_import_symbols program : Flambda.program = - { program with - imported_symbols = needed_import_symbols program; - } - -let root_symbol (program : Flambda.program) = - let rec loop (program : Flambda.program_body) = - match program with - | Effect (_, program) - | Let_symbol (_, _, program) - | Let_rec_symbol (_, program) - | Initialize_symbol (_, _, _, program) -> loop program - | End root -> - root - in - loop program.program_body - -let might_raise_static_exn flam stexn = - try - Flambda_iterators.iter_on_named - (function - | Flambda.Static_raise (ex, _) when Static_exception.equal ex stexn -> - raise Exit - | _ -> ()) - (fun _ -> ()) - flam; - false - with Exit -> true - -let make_closure_map program = - let map = ref Closure_id.Map.empty in - let add_set_of_closures ~constant:_ : Flambda.set_of_closures -> unit = fun - { function_decls } -> - Variable.Map.iter (fun var _ -> - let closure_id = Closure_id.wrap var in - let set_of_closures_id = function_decls.set_of_closures_id in - map := Closure_id.Map.add closure_id set_of_closures_id !map) - function_decls.funs - in - Flambda_iterators.iter_on_set_of_closures_of_program - program - ~f:add_set_of_closures; - !map - -let all_lifted_constant_closures program = - List.fold_left (fun unchanged flambda -> - match flambda with - | (_, Flambda.Set_of_closures { function_decls = { funs } }) -> - Variable.Map.fold - (fun key (_ : Flambda.function_declaration) acc -> - Closure_id.Set.add (Closure_id.wrap key) acc) - funs - unchanged - | _ -> unchanged) - Closure_id.Set.empty - (all_lifted_constants program) - -let all_lifted_constant_sets_of_closures program = - let set = ref Set_of_closures_id.Set.empty in - List.iter (function - | (_, Flambda.Set_of_closures { - function_decls = { set_of_closures_id } }) -> - set := Set_of_closures_id.Set.add set_of_closures_id !set - | _ -> ()) - (all_lifted_constants program); - !set - -let all_sets_of_closures program = - let list = ref [] in - Flambda_iterators.iter_on_set_of_closures_of_program program - ~f:(fun ~constant:_ set_of_closures -> - list := set_of_closures :: !list); - !list - -let all_sets_of_closures_map program = - let r = ref Set_of_closures_id.Map.empty in - Flambda_iterators.iter_on_set_of_closures_of_program program - ~f:(fun ~constant:_ set_of_closures -> - r := Set_of_closures_id.Map.add - set_of_closures.function_decls.set_of_closures_id - set_of_closures !r); - !r - -let substitute_named_for_variables - (substitution : Flambda.named Variable.Map.t) - (expr : Flambda.t) = - let bind var fresh_var (expr:Flambda.t) : Flambda.t = - let named = Variable.Map.find var substitution in - Flambda.create_let fresh_var named expr - in - let substitute_named bindings (named:Flambda.named) : Flambda.named = - let sb to_substitute = - try Variable.Map.find to_substitute bindings with - | Not_found -> - to_substitute - in - match named with - | Symbol _ | Const _ | Expr _ -> named - | Allocated_const _ | Read_mutable _ -> named - | Read_symbol_field _ -> named - | Set_of_closures set_of_closures -> - let set_of_closures = - Flambda.create_set_of_closures - ~function_decls:set_of_closures.function_decls - ~free_vars: - (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - { spec_to with var = sb spec_to.var; }) - set_of_closures.free_vars) - ~specialised_args: - (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - { spec_to with var = sb spec_to.var; }) - set_of_closures.specialised_args) - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - Set_of_closures set_of_closures - | Project_closure project_closure -> - Project_closure { - project_closure with - set_of_closures = sb project_closure.set_of_closures; - } - | Move_within_set_of_closures move_within_set_of_closures -> - Move_within_set_of_closures { - move_within_set_of_closures with - closure = sb move_within_set_of_closures.closure; - } - | Project_var project_var -> - Project_var { - project_var with - closure = sb project_var.closure; - } - | Prim (prim, args, dbg) -> - Prim (prim, List.map sb args, dbg) - in - let make_var_subst var = - if Variable.Map.mem var substitution then - let fresh = Variable.rename var in - fresh, (fun expr -> bind var fresh expr) - else - var, (fun x -> x) - in - let f (expr:Flambda.t) : Flambda.t = - match expr with - | Var v when Variable.Map.mem v substitution -> - let fresh = Variable.rename v in - bind v fresh (Var fresh) - | Var _ -> expr - | Let ({ var = v; defining_expr = named; _ } as let_expr) -> - let to_substitute = - Variable.Set.filter - (fun v -> Variable.Map.mem v substitution) - (Flambda.free_variables_named named) - in - if Variable.Set.is_empty to_substitute then - expr - else - let bindings = - Variable.Map.of_set (fun var -> Variable.rename var) to_substitute - in - let named = - substitute_named bindings named - in - let expr = - let module W = Flambda.With_free_variables in - W.create_let_reusing_body v named (W.of_body_of_let let_expr) - in - Variable.Map.fold (fun to_substitute fresh expr -> - bind to_substitute fresh expr) - bindings expr - | Let_mutable let_mutable when - Variable.Map.mem let_mutable.initial_value substitution -> - let fresh = Variable.rename let_mutable.initial_value in - bind let_mutable.initial_value fresh - (Let_mutable { let_mutable with initial_value = fresh }) - | Let_mutable _ -> - expr - | Let_rec (defs, body) -> - let free_variables_of_defs = - List.fold_left (fun set (_, named) -> - Variable.Set.union set (Flambda.free_variables_named named)) - Variable.Set.empty defs - in - let to_substitute = - Variable.Set.filter - (fun v -> Variable.Map.mem v substitution) - free_variables_of_defs - in - if Variable.Set.is_empty to_substitute then - expr - else begin - let bindings = - Variable.Map.of_set (fun var -> Variable.rename var) to_substitute - in - let defs = - List.map (fun (var, named) -> - var, substitute_named bindings named) - defs - in - let expr = - Flambda.Let_rec (defs, body) - in - Variable.Map.fold (fun to_substitute fresh expr -> - bind to_substitute fresh expr) - bindings expr - end - | If_then_else (cond, ifso, ifnot, kind) - when Variable.Map.mem cond substitution -> - let fresh = Variable.rename cond in - bind cond fresh (If_then_else (fresh, ifso, ifnot, kind)) - | If_then_else _ -> - expr - | Switch (cond, sw) when Variable.Map.mem cond substitution -> - let fresh = Variable.rename cond in - bind cond fresh (Switch (fresh, sw)) - | Switch _ -> - expr - | String_switch (cond, sw, def, kind) when Variable.Map.mem cond substitution -> - let fresh = Variable.rename cond in - bind cond fresh (String_switch (fresh, sw, def, kind)) - | String_switch _ -> - expr - | Assign { being_assigned; new_value } - when Variable.Map.mem new_value substitution -> - let fresh = Variable.rename new_value in - bind new_value fresh (Assign { being_assigned; new_value = fresh }) - | Assign _ -> - expr - | Static_raise (exn, args) -> - let args, bind_args = - List.split (List.map make_var_subst args) - in - List.fold_right (fun f expr -> f expr) bind_args @@ - Flambda.Static_raise (exn, args) - | For { bound_var; from_value; to_value; direction; body } -> - let from_value, bind_from_value = make_var_subst from_value in - let to_value, bind_to_value = make_var_subst to_value in - bind_from_value @@ - bind_to_value @@ - Flambda.For { bound_var; from_value; to_value; direction; body } - | Apply { func; args; kind; dbg; reg_close; mode; - inlined; specialise; probe; result_layout } -> - let func, bind_func = make_var_subst func in - let args, bind_args = - List.split (List.map make_var_subst args) - in - bind_func @@ - List.fold_right (fun f expr -> f expr) bind_args @@ - Flambda.Apply { func; args; kind; dbg; reg_close; mode; - inlined; specialise; probe; result_layout } - | Send { kind; meth; obj; args; dbg; reg_close; mode; result_layout } -> - let meth, bind_meth = make_var_subst meth in - let obj, bind_obj = make_var_subst obj in - let args, bind_args = - List.split (List.map make_var_subst args) - in - bind_meth @@ - bind_obj @@ - List.fold_right (fun f expr -> f expr) bind_args @@ - Flambda.Send { kind; meth; obj; args; dbg; reg_close; mode; result_layout } - | Proved_unreachable - | Region _ - | Exclave _ - | While _ - | Try_with _ - | Static_catch _ -> - (* No variables directly used in those expressions *) - expr - in - Flambda_iterators.map_toplevel f (fun v -> v) expr - -module Switch_storer = Switch.Store (struct - type t = Flambda.t - - (* An easily-comparable subset of [Flambda.t]: currently this only - supports that required to share switch branches. *) - type key = - | Var of Variable.t - | Let of Variable.t * key_named * key - | Static_raise of Static_exception.t * Variable.t list - and key_named = - | Symbol of Symbol.t - | Const of Flambda.const - | Prim of Clambda_primitives.primitive * Variable.t list - | Expr of key - - exception Not_comparable - - let rec make_expr_key (expr : Flambda.t) : key = - match expr with - | Var v -> Var v - | Let { var; defining_expr; body; } -> - Let (var, make_named_key defining_expr, make_expr_key body) - | Static_raise (e, args) -> Static_raise (e, args) - | _ -> raise Not_comparable - and make_named_key (named:Flambda.named) : key_named = - match named with - | Symbol s -> Symbol s - | Const c -> Const c - | Expr e -> Expr (make_expr_key e) - | Prim (prim, args, _dbg) -> Prim (prim, args) - | _ -> raise Not_comparable - - let make_key expr = - match make_expr_key expr with - | exception Not_comparable -> None - | key -> Some key - - let compare_key e1 e2 = - (* The environment [env] maps variables bound in [e2] to the corresponding - bound variables in [e1]. Every variable to compare in [e2] must have an - equivalent in [e1], otherwise the comparison wouldn't have gone - past the [Let] binding. Hence [Variable.Map.find] is safe here. *) - let compare_var env v1 v2 = - match Variable.Map.find v2 env with - | exception Not_found -> - (* The variable is free in the expression [e2], hence we can - compare it with [v1] directly. *) - Variable.compare v1 v2 - | bound -> - Variable.compare v1 bound - in - let rec compare_expr env (e1 : key) (e2 : key) : int = - match e1, e2 with - | Var v1, Var v2 -> - compare_var env v1 v2 - | Var _, (Let _| Static_raise _) -> -1 - | (Let _| Static_raise _), Var _ -> 1 - | Let (v1, n1, b1), Let (v2, n2, b2) -> - let comp_named = compare_named env n1 n2 in - if comp_named <> 0 then comp_named - else - let env = Variable.Map.add v2 v1 env in - compare_expr env b1 b2 - | Let _, Static_raise _ -> -1 - | Static_raise _, Let _ -> 1 - | Static_raise (sexn1, args1), Static_raise (sexn2, args2) -> - let comp_sexn = Static_exception.compare sexn1 sexn2 in - if comp_sexn <> 0 then comp_sexn - else Misc.Stdlib.List.compare (compare_var env) args1 args2 - and compare_named env (n1:key_named) (n2:key_named) : int = - match n1, n2 with - | Symbol s1, Symbol s2 -> Symbol.compare s1 s2 - | Symbol _, (Const _ | Expr _ | Prim _) -> -1 - | (Const _ | Expr _ | Prim _), Symbol _ -> 1 - | Const c1, Const c2 -> Flambda.compare_const c1 c2 - | Const _, (Expr _ | Prim _) -> -1 - | (Expr _ | Prim _), Const _ -> 1 - | Expr e1, Expr e2 -> compare_expr env e1 e2 - | Expr _, Prim _ -> -1 - | Prim _, Expr _ -> 1 - | Prim (prim1, args1), Prim (prim2, args2) -> - let comp_prim = Stdlib.compare prim1 prim2 in - if comp_prim <> 0 then comp_prim - else Misc.Stdlib.List.compare (compare_var env) args1 args2 - in - compare_expr Variable.Map.empty e1 e2 -end) - -let fun_vars_referenced_in_decls - (function_decls : Flambda.function_declarations) = - let fun_vars = Variable.Map.keys function_decls.funs in - let symbols_to_fun_vars = - Variable.Set.fold (fun fun_var symbols_to_fun_vars -> - let closure_id = Closure_id.wrap fun_var in - let symbol = Symbol_utils.Flambda.for_closure closure_id in - Symbol.Map.add symbol fun_var symbols_to_fun_vars) - fun_vars - Symbol.Map.empty - in - Variable.Map.map (fun (func_decl : Flambda.function_declaration) -> - let from_symbols = - Symbol.Set.fold (fun symbol fun_vars' -> - match Symbol.Map.find symbol symbols_to_fun_vars with - | exception Not_found -> fun_vars' - | fun_var -> - assert (Variable.Set.mem fun_var fun_vars); - Variable.Set.add fun_var fun_vars') - func_decl.free_symbols - Variable.Set.empty - in - let from_variables = - Variable.Set.inter func_decl.free_variables fun_vars - in - Variable.Set.union from_symbols from_variables) - function_decls.funs - -let closures_required_by_entry_point ~(entry_point : Closure_id.t) - (function_decls : Flambda.function_declarations) = - let dependencies = - fun_vars_referenced_in_decls function_decls - in - let set = ref Variable.Set.empty in - let queue = Queue.create () in - let add v = - if not (Variable.Set.mem v !set) then begin - set := Variable.Set.add v !set; - Queue.push v queue - end - in - add (Closure_id.unwrap entry_point); - while not (Queue.is_empty queue) do - let fun_var = Queue.pop queue in - match Variable.Map.find fun_var dependencies with - | exception Not_found -> () - | fun_dependencies -> - Variable.Set.iter (fun dep -> - if Variable.Map.mem dep function_decls.funs then - add dep) - fun_dependencies - done; - !set - -let all_functions_parameters (function_decls : Flambda.function_declarations) = - Variable.Map.fold (fun _ ({ params } : Flambda.function_declaration) set -> - Variable.Set.union set (Parameter.Set.vars params)) - function_decls.funs Variable.Set.empty - -let all_free_symbols (function_decls : Flambda.function_declarations) = - Variable.Map.fold (fun _ (function_decl : Flambda.function_declaration) - syms -> - Symbol.Set.union syms function_decl.free_symbols) - function_decls.funs Symbol.Set.empty - -let contains_stub (fun_decls : Flambda.function_declarations) = - let number_of_stub_functions = - Variable.Map.cardinal - (Variable.Map.filter (fun _ { Flambda.stub } -> stub) - fun_decls.funs) - in - number_of_stub_functions > 0 - -let clean_projections ~which_variables = - Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - match spec_to.projection with - | None -> spec_to - | Some projection -> - let from = Projection.projecting_from projection in - if Variable.Map.mem from which_variables then - spec_to - else - ({ spec_to with projection = None; } : Flambda.specialised_to)) - which_variables - -let projection_to_named (projection : Projection.t) : Flambda.named = - match projection with - | Project_var project_var -> Project_var project_var - | Project_closure project_closure -> Project_closure project_closure - | Move_within_set_of_closures move -> Move_within_set_of_closures move - | Field (field_index, var) -> - Prim (Pfield (field_index, Pvalue Pgenval, Pointer, Mutable), [var], - Debuginfo.none) - -type specialised_to_same_as = - | Not_specialised - | Specialised_and_aliased_to of Variable.Set.t - -let parameters_specialised_to_the_same_variable - ~(function_decls : Flambda.function_declarations) - ~(specialised_args : Flambda.specialised_to Variable.Map.t) = - let specialised_arg_aliasing = - (* For each external variable involved in a specialisation, which - internal variable(s) it maps to via that specialisation. *) - Variable.Map.transpose_keys_and_data_set - (Variable.Map.map (fun ({ var; _ } : Flambda.specialised_to) -> var) - specialised_args) - in - Variable.Map.map (fun ({ params; _ } : Flambda.function_declaration) -> - List.map (fun param -> - match Variable.Map.find (Parameter.var param) specialised_args with - | exception Not_found -> Not_specialised - | { var; _ } -> - Specialised_and_aliased_to - (Variable.Map.find var specialised_arg_aliasing)) - params) - function_decls.funs diff --git a/middle_end/flambda/flambda_utils.mli b/middle_end/flambda/flambda_utils.mli deleted file mode 100644 index 8112d93a7d7..00000000000 --- a/middle_end/flambda/flambda_utils.mli +++ /dev/null @@ -1,217 +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"] - -(** Utility functions for the Flambda intermediate language. *) - -(** Access functions *) - -(** [find_declaration f decl] raises [Not_found] if [f] is not in [decl]. *) -val find_declaration : - Closure_id.t -> Flambda.function_declarations -> Flambda.function_declaration - -(** [find_declaration_variable f decl] raises [Not_found] if [f] is not in - [decl]. *) -val find_declaration_variable : - Closure_id.t -> Flambda.function_declarations -> Variable.t - -(** [find_free_variable v clos] raises [Not_found] if [c] is not in [clos]. *) -val find_free_variable : - Var_within_closure.t -> Flambda.set_of_closures -> Variable.t - -(** Utility functions *) - -val function_arity : Flambda.function_declaration -> int - -(** Variables "bound by a closure" are those variables free in the - corresponding function's body that are neither: - - bound as parameters of that function; nor - - bound by the [let] binding that introduces the function declaration(s). - In particular, if [f], [g] and [h] are being introduced by a - simultaneous, possibly mutually-recursive [let] binding then none of - [f], [g] or [h] are bound in any of the closures for [f], [g] and [h]. -*) -val variables_bound_by_the_closure : - Closure_id.t -> Flambda.function_declarations -> Variable.Set.t - -(** If [can_be_merged f1 f2] is [true], it is safe to merge switch - branches containing [f1] and [f2]. *) -val can_be_merged : Flambda.t -> Flambda.t -> bool - -val description_of_toplevel_node : Flambda.t -> string - -(* Given an expression, freshen all variables within it, and form a function - whose body is the resulting expression. The variables specified by - [params] will become the parameters of the function; the closure will be - identified by [id]. [params] must only reference variables that are - free variables of [body]. *) -(* CR-soon mshinwell: consider improving name and names of arguments - lwhite: the params restriction seems odd, perhaps give a reason - in the comment. *) -val make_closure_declaration - : is_classic_mode:bool - -> id:Variable.t - -> alloc_mode:Lambda.alloc_mode - -> region:bool - -> body:Flambda.t - -> params:Parameter.t list - -> return_layout:Lambda.layout - -> free_variables:Lambda.layout Variable.Map.t - -> Flambda.t - -val toplevel_substitution - : Variable.t Variable.Map.t - -> Flambda.expr - -> Flambda.expr - -val toplevel_substitution_named - : Variable.t Variable.Map.t - -> Flambda.named - -> Flambda.named - -(** [bind [var1, expr1; ...; varN, exprN] body] binds using - [Immutable] [Let] expressions the given [(var, expr)] pairs around the - body. *) -val bind - : bindings:(Variable.t * Flambda.named) list - -> body:Flambda.t - -> Flambda.t - -val name_expr - : name:Internal_variable_names.t - -> Flambda.named - -> Flambda.t - -val name_expr_from_var - : var:Variable.t - -> Flambda.named - -> Flambda.t - -val initialize_symbols - : Flambda.program - -> (Symbol.t * Tag.t * Flambda.t list) list - -val imported_symbols : Flambda.program -> Symbol.Set.t - -val needed_import_symbols : Flambda.program -> Symbol.Set.t - -val introduce_needed_import_symbols : Flambda.program -> Flambda.program - -val root_symbol : Flambda.program -> Symbol.t - -(** Returns [true] iff the given term might raise the given static - exception. *) -val might_raise_static_exn : Flambda.named -> Static_exception.t -> bool - -(** Creates a map from closure IDs to set_of_closure IDs by iterating over - all sets of closures in the given program. *) -val make_closure_map - : Flambda.program - -> Set_of_closures_id.t Closure_id.Map.t - -(** The definitions of all constants that have been lifted out to [Let_symbol] - or [Let_rec_symbol] constructions. *) -val all_lifted_constants - : Flambda.program - -> (Symbol.t * Flambda.constant_defining_value) list - -(** Like [all_lifted_constant_symbols], but returns a map instead of a list. *) -val all_lifted_constants_as_map - : Flambda.program - -> Flambda.constant_defining_value Symbol.Map.t - -(** The identifiers of all constant sets of closures that have been lifted out - to [Let_symbol] or [Let_rec_symbol] constructions. *) -val all_lifted_constant_sets_of_closures - : Flambda.program - -> Set_of_closures_id.Set.t - -val all_lifted_constant_closures : Flambda.program -> Closure_id.Set.t - -(** All sets of closures in the given program (whether or not bound to a - symbol.) *) -val all_sets_of_closures : Flambda.program -> Flambda.set_of_closures list - -val all_sets_of_closures_map - : Flambda.program - -> Flambda.set_of_closures Set_of_closures_id.Map.t - -val substitute_named_for_variables - : Flambda.named Variable.Map.t - -> Flambda.t - -> Flambda.t - -(** For the compilation of switch statements. *) -module Switch_storer : sig - val mk_store : unit -> (Flambda.t, unit) Switch.t_store -end - -(** Within a set of function declarations there is a set of function bodies, - each of which may (or may not) reference one of the other functions in - the same set. Initially such intra-set references are by [Var]s (known - as "fun_var"s) but if the function is lifted by [Lift_constants] then the - references will be translated to [Symbol]s. This means that optimization - passes that need to identify whether a given "fun_var" (i.e. a key in the - [funs] map in a value of type [function_declarations]) is used in one of - the function bodies need to examine the [free_symbols] as well as the - [free_variables] members of [function_declarations]. This function makes - that process easier by computing all used "fun_var"s in the bodies of - the given set of function declarations, including the cases where the - references are [Symbol]s. The returned value is a map from "fun_var"s - to the "fun_var"s (if any) used in the body of the function associated - with that "fun_var". -*) -val fun_vars_referenced_in_decls - : Flambda.function_declarations - -> Variable.Set.t Variable.Map.t - -(** Computes the set of closure_id in the set of closures that are - required used (transitively) the entry_point *) -val closures_required_by_entry_point - : entry_point:Closure_id.t - -> Flambda.function_declarations - -> Variable.Set.t - -val all_functions_parameters : Flambda.function_declarations -> Variable.Set.t - -val all_free_symbols : Flambda.function_declarations -> Symbol.Set.t - -val contains_stub : Flambda.function_declarations -> bool - -(* Ensure that projection information is suitably erased from - free_vars and specialised_args if we have deleted the variable being - projected from. *) -val clean_projections - : which_variables : Flambda.specialised_to Variable.Map.t - -> Flambda.specialised_to Variable.Map.t - -val projection_to_named : Projection.t -> Flambda.named - -type specialised_to_same_as = - | Not_specialised - | Specialised_and_aliased_to of Variable.Set.t - -(** For each parameter in a given set of function declarations and the usual - specialised-args mapping, determine which other parameters are specialised - to the same variable as that parameter. - The result is presented as a map from [fun_vars] to lists, corresponding - componentwise to the usual [params] list in the corresponding function - declaration. *) -val parameters_specialised_to_the_same_variable - : function_decls:Flambda.function_declarations - -> specialised_args:Flambda.specialised_to Variable.Map.t - -> specialised_to_same_as list Variable.Map.t diff --git a/middle_end/flambda/freshening.ml b/middle_end/flambda/freshening.ml deleted file mode 100644 index 1ab4a1d67a7..00000000000 --- a/middle_end/flambda/freshening.ml +++ /dev/null @@ -1,463 +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-66"] -open! Int_replace_polymorphic_compare - -type tbl = { - sb_var : Variable.t Variable.Map.t; - sb_mutable_var : Mutable_variable.t Mutable_variable.Map.t; - sb_exn : Static_exception.t Static_exception.Map.t; - (* Used to handle substitution sequences: we cannot call the substitution - recursively because there can be name clashes. *) - back_var : Variable.t list Variable.Map.t; - back_mutable_var : Mutable_variable.t list Mutable_variable.Map.t; -} - -type t = - | Inactive - | Active of tbl - -type subst = t - -let empty_tbl = { - sb_var = Variable.Map.empty; - sb_mutable_var = Mutable_variable.Map.empty; - sb_exn = Static_exception.Map.empty; - back_var = Variable.Map.empty; - back_mutable_var = Mutable_variable.Map.empty; -} - -let print ppf = function - | Inactive -> Format.fprintf ppf "Inactive" - | Active tbl -> - Format.fprintf ppf "Active:@ "; - Variable.Map.iter (fun var1 var2 -> - Format.fprintf ppf "%a -> %a@ " - Variable.print var1 - Variable.print var2) - tbl.sb_var; - Mutable_variable.Map.iter (fun mut_var1 mut_var2 -> - Format.fprintf ppf "(mutable) %a -> %a@ " - Mutable_variable.print mut_var1 - Mutable_variable.print mut_var2) - tbl.sb_mutable_var; - Variable.Map.iter (fun var vars -> - Format.fprintf ppf "%a -> %a@ " - Variable.print var - Variable.Set.print (Variable.Set.of_list vars)) - tbl.back_var; - Mutable_variable.Map.iter (fun mut_var mut_vars -> - Format.fprintf ppf "(mutable) %a -> %a@ " - Mutable_variable.print mut_var - Mutable_variable.Set.print (Mutable_variable.Set.of_list mut_vars)) - tbl.back_mutable_var - -let empty = Inactive - -let is_empty = function - | Inactive -> true - | Active _ -> false - -let empty_preserving_activation_state = function - | Inactive -> Inactive - | Active _ -> Active empty_tbl - -let activate = function - | Inactive -> Active empty_tbl - | Active _ as t -> t - -let rec add_sb_var sb id id' = - let sb = { sb with sb_var = Variable.Map.add id id' sb.sb_var } in - let sb = - try let pre_vars = Variable.Map.find id sb.back_var in - List.fold_left (fun sb pre_id -> add_sb_var sb pre_id id') sb pre_vars - with Not_found -> sb in - let back_var = - let l = try Variable.Map.find id' sb.back_var with Not_found -> [] in - Variable.Map.add id' (id :: l) sb.back_var in - { sb with back_var } - -let rec add_sb_mutable_var sb id id' = - let sb = - { sb with - sb_mutable_var = Mutable_variable.Map.add id id' sb.sb_mutable_var; - } - in - let sb = - try - let pre_vars = Mutable_variable.Map.find id sb.back_mutable_var in - List.fold_left (fun sb pre_id -> add_sb_mutable_var sb pre_id id') - sb pre_vars - with Not_found -> sb in - let back_mutable_var = - let l = - try Mutable_variable.Map.find id' sb.back_mutable_var - with Not_found -> [] - in - Mutable_variable.Map.add id' (id :: l) sb.back_mutable_var - in - { sb with back_mutable_var } - -let apply_static_exception t i = - match t with - | Inactive -> - i - | Active t -> - try Static_exception.Map.find i t.sb_exn - with Not_found -> i - -let add_static_exception t i = - match t with - | Inactive -> i, t - | Active t -> - let i' = Static_exception.create () in - let sb_exn = - Static_exception.Map.add i i' t.sb_exn - in - i', Active { t with sb_exn; } - -let active_add_variable t id = - let id' = Variable.rename id in - let t = add_sb_var t id id' in - id', t - -let active_add_parameter t param = - let param' = Parameter.rename param in - let t = add_sb_var t (Parameter.var param) (Parameter.var param') in - param', t - -let add_variable t id = - match t with - | Inactive -> id, t - | Active t -> - let id', t = active_add_variable t id in - id', Active t - -let active_add_parameters' t (params:Parameter.t list) = - List.fold_right (fun param (params, t) -> - let param', t = active_add_parameter t param in - param' :: params, t) - params ([], t) - -let add_variables t defs = - List.fold_right (fun (id, data) (defs, t) -> - let id', t = add_variable t id in - (id', data) :: defs, t) defs ([], t) - -let add_variables' t ids = - List.fold_right (fun id (ids, t) -> - let id', t = add_variable t id in - id' :: ids, t) ids ([], t) - -let active_add_mutable_variable t id = - let id' = Mutable_variable.rename id in - let t = add_sb_mutable_var t id id' in - id', t - -let add_mutable_variable t id = - match t with - | Inactive -> id, t - | Active t -> - let id', t = active_add_mutable_variable t id in - id', Active t - -let active_find_var_exn t id = - try Variable.Map.find id t.sb_var with - | Not_found -> - Misc.fatal_error (Format.asprintf "find_var: can't find %a@." - Variable.print id) - -let apply_variable t var = - match t with - | Inactive -> var - | Active t -> - try Variable.Map.find var t.sb_var with - | Not_found -> var - -let apply_mutable_variable t mut_var = - match t with - | Inactive -> mut_var - | Active t -> - try Mutable_variable.Map.find mut_var t.sb_mutable_var with - | Not_found -> mut_var - -let rewrite_recursive_calls_with_symbols t - (function_declarations : Flambda.function_declarations) = - match t with - | Inactive -> function_declarations - | Active _ -> - let all_free_symbols = - Variable.Map.fold - (fun _ (function_decl : Flambda.function_declaration) - syms -> - Symbol.Set.union syms function_decl.free_symbols) - function_declarations.funs Symbol.Set.empty - in - let closure_symbols_used = ref false in - let closure_symbols = - Variable.Map.fold (fun var _ map -> - let closure_id = Closure_id.wrap var in - let sym = Symbol_utils.Flambda.for_closure closure_id in - if Symbol.Set.mem sym all_free_symbols then begin - closure_symbols_used := true; - Symbol.Map.add sym var map - end else begin - map - end) - function_declarations.funs Symbol.Map.empty - in - if not !closure_symbols_used then begin - (* Don't waste time rewriting the function declaration(s) if there - are no occurrences of any of the closure symbols. *) - function_declarations - end else begin - let funs = - Variable.Map.map (fun (ffun : Flambda.function_declaration) -> - let body = - Flambda_iterators.map_toplevel_named - (* CR-someday pchambart: This may be worth deep substituting - below the closures, but that means that we need to take care - of functions' free variables. *) - (function - | Symbol sym when Symbol.Map.mem sym closure_symbols -> - Expr (Var (Symbol.Map.find sym closure_symbols)) - | e -> e) - ffun.body - in - Flambda.update_body_of_function_declaration ffun ~body) - function_declarations.funs - in - Flambda.update_function_declarations function_declarations ~funs - end - -module Project_var = struct - type t = - { vars_within_closure : Var_within_closure.t Var_within_closure.Map.t; - closure_id : Closure_id.t Closure_id.Map.t } - - let empty = - { vars_within_closure = Var_within_closure.Map.empty; - closure_id = Closure_id.Map.empty; - } - - let print ppf t = - Format.fprintf ppf "{ vars_within_closure %a, closure_id %a }" - (Var_within_closure.Map.print Var_within_closure.print) - t.vars_within_closure - (Closure_id.Map.print Closure_id.print) - t.closure_id - - let new_subst_fv t id subst = - match subst with - | Inactive -> id, subst, t - | Active subst -> - let id' = Variable.rename id in - let subst = add_sb_var subst id id' in - let off = Var_within_closure.wrap id in - let off' = Var_within_closure.wrap id' in - let off_sb = Var_within_closure.Map.add off off' t.vars_within_closure in - id', Active subst, { t with vars_within_closure = off_sb; } - - let new_subst_fun t id subst = - let id' = Variable.rename id in - let subst = add_sb_var subst id id' in - let off = Closure_id.wrap id in - let off' = Closure_id.wrap id' in - let off_sb = Closure_id.Map.add off off' t.closure_id in - id', subst, { t with closure_id = off_sb; } - - (** Returns : - * The map of new_identifiers -> expression - * The new environment with added substitution - * a fresh ffunction_subst with only the substitution of free variables - *) - let subst_free_vars fv subst ~only_freshen_parameters - : (Flambda.specialised_to * _) Variable.Map.t * _ * _ = - Variable.Map.fold (fun id lam (fv, subst, t) -> - let id, subst, t = - if only_freshen_parameters then - id, subst, t - else - new_subst_fv t id subst - in - Variable.Map.add id lam fv, subst, t) - fv - (Variable.Map.empty, subst, empty) - - (** Returns : - * The function_declaration with renamed function identifiers - * The new environment with added substitution - * The ffunction_subst completed with function substitution - - subst_free_vars must have been used to build off_sb - *) - let func_decls_subst t (subst : subst) - (func_decls : Flambda.function_declarations) - ~only_freshen_parameters = - match subst with - | Inactive -> func_decls, subst, t - | Active subst -> - let subst_func_decl _fun_id (func_decl : Flambda.function_declaration) - subst = - let params, subst = active_add_parameters' subst func_decl.params in - (* Since all parameters are distinct, even between functions, we can - just use a single substitution. *) - let body = - Flambda_utils.toplevel_substitution subst.sb_var func_decl.body - in - let function_decl = - Flambda.create_function_declaration - ~params ~alloc_mode:func_decl.alloc_mode ~region:func_decl.region - ~return_layout:func_decl.return_layout - ~body - ~stub:func_decl.stub - ~inline:func_decl.inline ~specialise:func_decl.specialise - ~check:func_decl.check - ~is_a_functor:func_decl.is_a_functor - ~closure_origin:func_decl.closure_origin - ~poll:func_decl.poll - in - function_decl, subst - in - let subst, t = - if only_freshen_parameters then - subst, t - else - Variable.Map.fold (fun orig_id _func_decl (subst, t) -> - let _id, subst, t = new_subst_fun t orig_id subst in - subst, t) - func_decls.funs - (subst, t) - in - let funs, subst = - Variable.Map.fold (fun orig_id func_decl (funs, subst) -> - let func_decl, subst = subst_func_decl orig_id func_decl subst in - let id = - if only_freshen_parameters then orig_id - else active_find_var_exn subst orig_id - in - let funs = Variable.Map.add id func_decl funs in - funs, subst) - func_decls.funs - (Variable.Map.empty, subst) - in - let function_decls = - Flambda.update_function_declarations func_decls ~funs - in - function_decls, Active subst, t - - let apply_closure_id t closure_id = - try Closure_id.Map.find closure_id t.closure_id - with Not_found -> closure_id - - let apply_var_within_closure t var_in_closure = - try Var_within_closure.Map.find var_in_closure t.vars_within_closure - with Not_found -> var_in_closure - - module Compose (T : Identifiable.S) = struct - let compose ~earlier ~later = - if (T.Map.equal T.equal) earlier later - || T.Map.cardinal later = 0 - then - earlier - else - T.Map.mapi (fun src_var var -> - if T.Map.mem src_var later then begin - Misc.fatal_errorf "Freshening.Project_var.compose: domains \ - of substitutions must be disjoint. earlier=%a later=%a" - (T.Map.print T.print) earlier - (T.Map.print T.print) later - end; - match T.Map.find var later with - | exception Not_found -> var - | var -> var) - earlier - end - - module V = Compose (Var_within_closure) - module C = Compose (Closure_id) - - let compose ~earlier ~later : t = - { vars_within_closure = - V.compose ~earlier:earlier.vars_within_closure - ~later:later.vars_within_closure; - closure_id = - C.compose ~earlier:earlier.closure_id - ~later:later.closure_id; - } -end - -let apply_function_decls_and_free_vars t fv func_decls - ~only_freshen_parameters = - let module I = Project_var in - let fv, t, of_closures = I.subst_free_vars fv t ~only_freshen_parameters in - let func_decls, t, of_closures = - I.func_decls_subst of_closures t func_decls ~only_freshen_parameters - in - fv, func_decls, t, of_closures - -let does_not_freshen t vars = - match t with - | Inactive -> true - | Active subst -> - not (List.exists (fun var -> Variable.Map.mem var subst.sb_var) vars) - -let freshen_projection (projection : Projection.t) ~freshening - ~closure_freshening : Projection.t = - match projection with - | Project_var { closure; closure_id; var; kind } -> - Project_var { - closure = apply_variable freshening closure; - closure_id = Project_var.apply_closure_id closure_freshening closure_id; - var = Project_var.apply_var_within_closure closure_freshening var; - kind; - } - | Project_closure { set_of_closures; closure_id; } -> - Project_closure { - set_of_closures = apply_variable freshening set_of_closures; - closure_id = Project_var.apply_closure_id closure_freshening closure_id; - } - | Move_within_set_of_closures { closure; start_from; move_to; } -> - Move_within_set_of_closures { - closure = apply_variable freshening closure; - start_from = Project_var.apply_closure_id closure_freshening start_from; - move_to = Project_var.apply_closure_id closure_freshening move_to; - } - | Field (field_index, var) -> - Field (field_index, apply_variable freshening var) - -let freshen_projection_relation relation ~freshening ~closure_freshening = - Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - let projection = - match spec_to.projection with - | None -> None - | Some projection -> - Some (freshen_projection projection ~freshening ~closure_freshening) - in - { spec_to with projection; }) - relation - -let freshen_projection_relation' relation ~freshening ~closure_freshening = - Variable.Map.map (fun ((spec_to : Flambda.specialised_to), data) -> - let projection = - match spec_to.projection with - | None -> None - | Some projection -> - Some (freshen_projection projection ~freshening ~closure_freshening) - in - { spec_to with projection; }, data) - relation diff --git a/middle_end/flambda/freshening.mli b/middle_end/flambda/freshening.mli deleted file mode 100644 index 9ccde4f2120..00000000000 --- a/middle_end/flambda/freshening.mli +++ /dev/null @@ -1,166 +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"] - -(** Freshening of various identifiers. *) - -(** A table used for freshening variables and static exception identifiers. *) -type t -type subst = t - -(** The freshening that does nothing. This is the unique inactive - freshening. *) -val empty : t - -val is_empty : t -> bool - -(** Activate the freshening. Without activation, operations to request - freshenings have no effect (cf. the documentation below for - [add_variable]). As such, the inactive renaming is unique. *) -val activate : t -> t - -(** Given the inactive freshening, return the same; otherwise, return an - empty active freshening. *) -val empty_preserving_activation_state : t -> t - -(** [add_variable t var] - If [t] is active: - It returns a fresh variable [new_var] and adds [var] -> [new_var] - to the freshening. - If a renaming [other_var] -> [var] or [symbol] -> [var] was already - present in [t], it will also add [other_var] -> [new_var] and - [symbol] -> [new_var]. - If [t] is inactive, this is the identity. -*) -val add_variable : t -> Variable.t -> Variable.t * t - -(** Like [add_variable], but for multiple variables, each freshened - separately. *) -val add_variables' - : t - -> Variable.t list - -> Variable.t list * t - -(** Like [add_variables'], but passes through the second component of the - input list unchanged. *) -val add_variables - : t - -> (Variable.t * 'a) list - -> (Variable.t * 'a) list * t - -(** Like [add_variable], but for mutable variables. *) -val add_mutable_variable : t -> Mutable_variable.t -> Mutable_variable.t * t - -(** As for [add_variable], but for static exception identifiers. *) -val add_static_exception : t -> Static_exception.t -> Static_exception.t * t - -(** [apply_variable t var] applies the freshening [t] to [var]. - If no renaming is specified in [t] for [var] it is returned unchanged. *) -val apply_variable : t -> Variable.t -> Variable.t - -(** As for [apply_variable], but for mutable variables. *) -val apply_mutable_variable : t -> Mutable_variable.t -> Mutable_variable.t - -(** As for [apply_variable], but for static exception identifiers. *) -val apply_static_exception : t -> Static_exception.t -> Static_exception.t - -(** Replace recursive accesses to the closures in the set through - [Symbol] by the corresponding [Var]. This is used to recover - the recursive call when importing code from another compilation unit. - - If the renaming is inactive, this is the identity. -*) -val rewrite_recursive_calls_with_symbols - : t - -> Flambda.function_declarations - -> Flambda.function_declarations - -(* CR-soon mshinwell for mshinwell: maybe inaccurate module name, it freshens - closure IDs as well. Check use points though *) -module Project_var : sig - (** A table used for freshening of identifiers in [Project_closure] and - [Move_within_set_of_closures] ("ids of closures"); and [Project_var] - ("bound vars of closures") expressions. - - This information is propagated bottom up and populated when inlining a - function containing a closure declaration. - - For instance, - [let f x = - let g y = ... x ... in - ... g.x ... (Project_var x) - ... g 1 ... (Apply (Project_closure g ...)) - ] - - If f is inlined, g is renamed. The approximation of g will carry this - table such that later the access to the field x of g and selection of - g in the closure can be substituted. - *) - type t - - (* The freshening that does nothing. *) - val empty : t - - (** Composition of two freshenings. *) - val compose : earlier:t -> later:t -> t - - (** Freshen a closure ID based on the given renaming. The same ID is - returned if the renaming does not affect it. - If dealing with approximations, you probably want to use - [Simple_value_approx.freshen_and_check_closure_id] instead of this - function. - *) - val apply_closure_id : t -> Closure_id.t -> Closure_id.t - - (** Like [apply_closure_id], but for variables within closures. *) - val apply_var_within_closure - : t - -> Var_within_closure.t - -> Var_within_closure.t - - val print : Format.formatter -> t -> unit -end - -(* CR-soon mshinwell for mshinwell: add comment *) -val apply_function_decls_and_free_vars - : t - -> (Flambda.specialised_to * 'a) Variable.Map.t - -> Flambda.function_declarations - -> only_freshen_parameters:bool - -> (Flambda.specialised_to * 'a) Variable.Map.t - * Flambda.function_declarations - * t - * Project_var.t - -val does_not_freshen : t -> Variable.t list -> bool - -val print : Format.formatter -> t -> unit - -(** N.B. This does not freshen the domain of the supplied map, only the - range. *) -(* CR-someday mshinwell: consider fixing that *) -val freshen_projection_relation - : Flambda.specialised_to Variable.Map.t - -> freshening:t - -> closure_freshening:Project_var.t - -> Flambda.specialised_to Variable.Map.t - -val freshen_projection_relation' - : (Flambda.specialised_to * 'a) Variable.Map.t - -> freshening:t - -> closure_freshening:Project_var.t - -> (Flambda.specialised_to * 'a) Variable.Map.t diff --git a/middle_end/flambda/import_approx.ml b/middle_end/flambda/import_approx.ml deleted file mode 100644 index 2f9652af05d..00000000000 --- a/middle_end/flambda/import_approx.ml +++ /dev/null @@ -1,222 +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"] - -module A = Simple_value_approx - -let import_set_of_closures = - let import_function_declarations (clos : A.function_declarations) - : A.function_declarations = - (* CR-soon mshinwell for pchambart: Do we still need to do this - rewriting? I'm wondering if maybe we don't have to any more. *) - let sym_to_fun_var_map (clos : A.function_declarations) = - Variable.Map.fold (fun fun_var _ acc -> - let closure_id = Closure_id.wrap fun_var in - let sym = Symbol_utils.Flambda.for_closure closure_id in - Symbol.Map.add sym fun_var acc) - clos.funs Symbol.Map.empty - in - let sym_map = sym_to_fun_var_map clos in - let f_named (named : Flambda.named) = - match named with - | Symbol sym -> - begin try Flambda.Expr (Var (Symbol.Map.find sym sym_map)) with - | Not_found -> named - end - | named -> named - in - let funs = - Variable.Map.map (fun (function_decl : A.function_declaration) -> - A.update_function_declaration_body function_decl - (Flambda_iterators.map_toplevel_named f_named)) - clos.funs - in - A.update_function_declarations clos ~funs - in - let aux set_of_closures_id = - match - Compilenv.approx_for_global - (Set_of_closures_id.get_compilation_unit set_of_closures_id) - with - | None -> None - | Some ex_info -> - try - let function_declarations = - Set_of_closures_id.Map.find set_of_closures_id - ex_info.sets_of_closures - in - Some (import_function_declarations function_declarations) - with Not_found -> - Misc.fatal_error "Cannot find set of closures" - in - Set_of_closures_id.Tbl.memoize Compilenv.imported_sets_of_closures_table aux - -let rec import_ex ex = - let import_value_set_of_closures ~set_of_closures_id ~bound_vars ~free_vars - ~(ex_info : Export_info.t) ~what : A.value_set_of_closures option = - let bound_vars = Var_within_closure.Map.map import_approx bound_vars in - match import_set_of_closures set_of_closures_id with - | None -> None - | Some function_decls -> - (* CR-someday xclerc: add a test to the test suite to ensure that - classic mode behaves as expected. *) - let is_classic_mode = function_decls.is_classic_mode in - let invariant_params = - match - Set_of_closures_id.Map.find set_of_closures_id - ex_info.invariant_params - with - | exception Not_found -> - if is_classic_mode then - Variable.Map.empty - else - Misc.fatal_errorf "Set of closures ID %a not found in \ - invariant_params (when importing [%a: %s])" - Set_of_closures_id.print set_of_closures_id - Export_id.print ex - what - | found -> found - in - let recursive = - match - Set_of_closures_id.Map.find set_of_closures_id ex_info.recursive - with - | exception Not_found -> - if is_classic_mode then - Variable.Set.empty - else - Misc.fatal_errorf "Set of closures ID %a not found in \ - recursive (when importing [%a: %s])" - Set_of_closures_id.print set_of_closures_id - Export_id.print ex - what - | found -> found - in - Some (A.create_value_set_of_closures - ~function_decls - ~bound_vars - ~free_vars - ~invariant_params:(lazy invariant_params) - ~recursive:(lazy recursive) - ~specialised_args:Variable.Map.empty - ~freshening:Freshening.Project_var.empty - ~direct_call_surrogates:Closure_id.Map.empty) - in - let compilation_unit = Export_id.get_compilation_unit ex in - match Compilenv.approx_for_global compilation_unit with - | None -> A.value_unknown Other - | Some ex_info -> - match Export_info.find_description ex_info ex with - | exception Not_found -> - Misc.fatal_errorf "Cannot find export id %a" Export_id.print ex - | Value_unknown_descr -> A.value_unknown Other - | Value_int i -> A.value_int i - | Value_char c -> A.value_char c - | Value_float f -> A.value_float f - | Value_float_array float_array -> - begin match float_array.contents with - | Unknown_or_mutable -> - A.value_mutable_float_array ~size:float_array.size - | Contents contents -> - A.value_immutable_float_array - (Array.map (function - | None -> A.value_any_float - | Some f -> A.value_float f) - contents) - end - | Export_info.Value_boxed_int (t, i) -> A.value_boxed_int t i - | Value_string { size; contents } -> - let contents = - match contents with - | Unknown_or_mutable -> None - | Contents contents -> Some contents - in - A.value_string size contents - | Value_mutable_block _ -> A.value_unknown Other - | Value_block (tag, fields) -> - A.value_block tag (Array.map import_approx fields) - | Value_closure { closure_id; - set_of_closures = - { set_of_closures_id; bound_vars; free_vars; aliased_symbol } } -> - let value_set_of_closures = - import_value_set_of_closures - ~set_of_closures_id ~bound_vars ~free_vars ~ex_info - ~what:(Format.asprintf "Value_closure %a" Closure_id.print closure_id) - in - begin match value_set_of_closures with - | None -> A.value_unresolved (Set_of_closures_id set_of_closures_id) - | Some value_set_of_closures -> - A.value_closure ?set_of_closures_symbol:aliased_symbol - value_set_of_closures closure_id - end - | Value_set_of_closures - { set_of_closures_id; bound_vars; free_vars; aliased_symbol } -> - let value_set_of_closures = - import_value_set_of_closures ~set_of_closures_id - ~bound_vars ~free_vars ~ex_info ~what:"Value_set_of_closures" - in - match value_set_of_closures with - | None -> - A.value_unresolved (Set_of_closures_id set_of_closures_id) - | Some value_set_of_closures -> - let approx = A.value_set_of_closures value_set_of_closures in - match aliased_symbol with - | None -> approx - | Some symbol -> A.augment_with_symbol approx symbol - -and import_approx (ap : Export_info.approx) = - match ap with - | Value_unknown -> A.value_unknown Other - | Value_id ex -> A.value_extern ex - | Value_symbol sym -> A.value_symbol sym - -let import_symbol sym = - if Symbol.is_predef_exn sym then - A.value_unknown Other - else begin - let compilation_unit = Symbol.compilation_unit sym in - match Compilenv.approx_for_global compilation_unit with - | None -> A.value_unresolved (Symbol sym) - | Some export_info -> - match Symbol.Map.find sym export_info.symbol_id with - | approx -> A.augment_with_symbol (import_ex approx) sym - | exception Not_found -> - Misc.fatal_errorf - "Compilation unit = %a Cannot find symbol %a, all known:@ %a" - Compilation_unit.print compilation_unit - Symbol.print sym - (Symbol.Map.print Export_id.print) export_info.symbol_id - end - -(* Note for code reviewers: Observe that [really_import] iterates until - the approximation description is fully resolved (or a necessary .cmx - file is missing). *) - -let rec really_import (approx : A.descr) = - match approx with - | Value_extern ex -> really_import_ex ex - | Value_symbol sym -> really_import_symbol sym - | r -> r - -and really_import_ex ex = - really_import (import_ex ex).descr - -and really_import_symbol sym = - really_import (import_symbol sym).descr - -let really_import_approx (approx : Simple_value_approx.t) = - A.replace_description approx (really_import approx.descr) diff --git a/middle_end/flambda/import_approx.mli b/middle_end/flambda/import_approx.mli deleted file mode 100644 index 23d9d29482b..00000000000 --- a/middle_end/flambda/import_approx.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"] - -(** Create simple value approximations from the export information in - .cmx files. *) - -(** Given an approximation description, load .cmx files (possibly more - than one) until the description is fully resolved. If a necessary .cmx - file cannot be found, "unresolved" will be returned. *) -val really_import : Simple_value_approx.descr -> Simple_value_approx.descr - -(** Maps the description of the given approximation through [really_import]. *) -val really_import_approx : Simple_value_approx.t -> Simple_value_approx.t - -(** Read and convert the approximation of a given symbol from the - relevant .cmx file. Unlike the "really_" functions, this does not - continue to load .cmx files until the approximation is fully - resolved. *) -val import_symbol : Symbol.t -> Simple_value_approx.t diff --git a/middle_end/flambda/inconstant_idents.ml b/middle_end/flambda/inconstant_idents.ml deleted file mode 100644 index 4cd56fc86bf..00000000000 --- a/middle_end/flambda/inconstant_idents.ml +++ /dev/null @@ -1,510 +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-66"] -open! Int_replace_polymorphic_compare - -(* This cannot be done in a single simple pass due to expressions like: - - let rec ... = - ... - let rec f1 x = - let f2 y = - f1 rec_list - in - f2 v - and rec_list = f1 :: rec_list in - ... - - and v = ... - - f1, f2 and rec_list are constants iff v is a constant. - - To handle this we populate both a 'not constant' set NC and a set of - implications between variables. - - For example, the above code would generate the implications: - - f1 in NC => rec_list in NC - f2 in NC => f1 in NC - rec_list in NC => f2 in NC - v in NC => f1 in NC - - then if v is found to be in NC this will be propagated to place - f1, f2 and rec_list in NC as well. - -*) - -(* CR-someday lwhite: I think this pass could be combined with - alias_analysis and other parts of lift_constants into a single - type-based analysis which infers a "type" for each variable that is - either an allocated_constant expression or "not constant". Recursion - would be handled with unification variables. *) - -module Int = Numbers.Int -module Symbol_field = struct - type t = Symbol.t * Int.t - include Identifiable.Make (Identifiable.Pair (Symbol) (Int)) -end - -type dep = - | Closure of Set_of_closures_id.t - | Var of Variable.t - | Symbol of Symbol.t - | Symbol_field of Symbol_field.t - -type state = - | Not_constant - | Implication of dep list - -type result = { - id : state Variable.Tbl.t; - closure : state Set_of_closures_id.Tbl.t; -} - -module type Param = sig - val program : Flambda.program - val compilation_unit : Compilation_unit.t -end - -(* CR-soon mshinwell: consider removing functor *) -module Inconstants (P:Param) (Backend:Backend_intf.S) = struct - let program = P.program - let compilation_unit = P.compilation_unit - let imported_symbols = Flambda_utils.imported_symbols program - - (* Sets representing NC *) - let variables : state Variable.Tbl.t = Variable.Tbl.create 42 - let closures : state Set_of_closures_id.Tbl.t = - Set_of_closures_id.Tbl.create 42 - let symbols : state Symbol.Tbl.t = Symbol.Tbl.create 42 - let symbol_fields : state Symbol_field.Tbl.t = Symbol_field.Tbl.create 42 - - let mark_queue = Queue.create () - - (* CR-soon pchambart: We could probably improve that quite a lot by adding - (the future annotation) [@unrolled] at the right call sites. Or more - directly mark mark_dep as [@inline] and call it instead of mark_curr in - some situations. - *) - - (* adds 'dep in NC' *) - let rec mark_dep = function - | Var id -> begin - match Variable.Tbl.find variables id with - | Not_constant -> () - | Implication deps -> - Variable.Tbl.replace variables id Not_constant; - Queue.push deps mark_queue - | exception Not_found -> - Variable.Tbl.add variables id Not_constant - end - | Closure cl -> begin - match Set_of_closures_id.Tbl.find closures cl with - | Not_constant -> () - | Implication deps -> - Set_of_closures_id.Tbl.replace closures cl Not_constant; - Queue.push deps mark_queue - | exception Not_found -> - Set_of_closures_id.Tbl.add closures cl Not_constant - end - | Symbol s -> begin - match Symbol.Tbl.find symbols s with - | Not_constant -> () - | Implication deps -> - Symbol.Tbl.replace symbols s Not_constant; - Queue.push deps mark_queue - | exception Not_found -> - Symbol.Tbl.add symbols s Not_constant - end - | Symbol_field s -> begin - match Symbol_field.Tbl.find symbol_fields s with - | Not_constant -> () - | Implication deps -> - Symbol_field.Tbl.replace symbol_fields s Not_constant; - Queue.push deps mark_queue - | exception Not_found -> - Symbol_field.Tbl.add symbol_fields s Not_constant - end - - and mark_deps deps = - List.iter mark_dep deps - - and complete_marking () = - while not (Queue.is_empty mark_queue) do - let deps = - try - Queue.take mark_queue - with Not_found -> [] - in - mark_deps deps; - done - - (* adds 'curr in NC' *) - let mark_curr curr = - mark_deps curr; - complete_marking () - - (* adds in the tables 'dep in NC => curr in NC' *) - let register_implication ~in_nc:dep ~implies_in_nc:curr = - match dep with - | Var id -> begin - match Variable.Tbl.find variables id with - | Not_constant -> - mark_deps curr; - complete_marking (); - | Implication deps -> - let deps = List.rev_append curr deps in - Variable.Tbl.replace variables id (Implication deps) - | exception Not_found -> - Variable.Tbl.add variables id (Implication curr); - end - | Closure cl -> begin - match Set_of_closures_id.Tbl.find closures cl with - | Not_constant -> - mark_deps curr; - complete_marking (); - | Implication deps -> - let deps = List.rev_append curr deps in - Set_of_closures_id.Tbl.replace closures cl (Implication deps) - | exception Not_found -> - Set_of_closures_id.Tbl.add closures cl (Implication curr); - end - | Symbol symbol -> begin - match Symbol.Tbl.find symbols symbol with - | Not_constant -> - mark_deps curr; - complete_marking (); - | Implication deps -> - let deps = List.rev_append curr deps in - Symbol.Tbl.replace symbols symbol (Implication deps) - | exception Not_found -> - Symbol.Tbl.add symbols symbol (Implication curr); - end - | Symbol_field ((symbol, _) as field) -> begin - match Symbol_field.Tbl.find symbol_fields field with - | Not_constant -> - mark_deps curr; - complete_marking (); - | Implication deps -> - let deps = List.rev_append curr deps in - Symbol_field.Tbl.replace symbol_fields field (Implication deps) - | exception Not_found -> - (* There is no information available about the contents of imported - symbols, so we must consider all their fields as inconstant. *) - (* CR-someday pchambart: recover that from the cmx information *) - if Symbol.Set.mem symbol imported_symbols then begin - Symbol_field.Tbl.add symbol_fields field Not_constant; - mark_deps curr; - complete_marking (); - end else begin - Symbol_field.Tbl.add symbol_fields field (Implication curr) - end - end - - (* First loop: iterates on the tree to mark dependencies. - - curr is the variables or closures to which we add constraints like - '... in NC => curr in NC' or 'curr in NC' - - It can be empty when no constraint can be added like in the toplevel - expression or in the body of a function. - *) - let rec mark_loop ~toplevel (curr : dep list) (flam : Flambda.t) = - match flam with - | Let { var; defining_expr = lam; body; _ } -> - mark_named ~toplevel [Var var] lam; - (* adds 'var in NC => curr in NC' - This is not really necessary, but compiling this correctly is - trickier than eliminating that earlier. *) - mark_var var curr; - mark_loop ~toplevel curr body - | Let_mutable { initial_value = var; body } -> - mark_var var curr; - mark_loop ~toplevel curr body - | Let_rec(defs, body) -> - List.iter (fun (var, def) -> - mark_named ~toplevel [Var var] def; - (* adds 'var in NC => curr in NC' same remark as let case *) - mark_var var curr) - defs; - mark_loop ~toplevel curr body - | Var var -> mark_var var curr - (* Not constant cases: we mark directly 'curr in NC' and mark - bound variables as in NC also *) - | Assign _ -> - mark_curr curr - | Try_with (f1,id,f2, _kind) -> - mark_curr [Var id]; - mark_curr curr; - mark_loop ~toplevel [] f1; - mark_loop ~toplevel [] f2 - | Static_catch (_,ids,f1,f2, _) -> - List.iter (fun (id, _layout) -> mark_curr [Var id]) ids; - mark_curr curr; - mark_loop ~toplevel [] f1; - mark_loop ~toplevel [] f2 - (* CR-someday pchambart: If recursive staticcatch is introduced: - this becomes ~toplevel:false *) - | For { bound_var; from_value; to_value; direction = _; body; } -> - mark_curr [Var bound_var]; - mark_var from_value curr; - mark_var to_value curr; - mark_curr curr; - mark_loop ~toplevel:false [] body - | While (f1,body) -> - mark_curr curr; - mark_loop ~toplevel [] f1; - mark_loop ~toplevel:false [] body - | If_then_else (f1,f2,f3, _kind) -> - mark_curr curr; - mark_curr [Var f1]; - mark_loop ~toplevel [] f2; - mark_loop ~toplevel [] f3 - | Static_raise (_,l) -> - mark_curr curr; - List.iter (fun v -> mark_var v curr) l - | Apply ({func; args; _ }) -> - mark_curr curr; - mark_var func curr; - mark_vars args curr; - | Switch (arg,sw) -> - mark_curr curr; - mark_var arg curr; - List.iter (fun (_,l) -> mark_loop ~toplevel [] l) sw.consts; - List.iter (fun (_,l) -> mark_loop ~toplevel [] l) sw.blocks; - Option.iter (fun l -> mark_loop ~toplevel [] l) sw.failaction - | String_switch (arg,sw,def, _kind) -> - mark_curr curr; - mark_var arg curr; - List.iter (fun (_,l) -> mark_loop ~toplevel [] l) sw; - Option.iter (fun l -> mark_loop ~toplevel [] l) def - | Send { kind = _; meth; obj; args; dbg = _; } -> - mark_curr curr; - mark_var meth curr; - mark_var obj curr; - List.iter (fun arg -> mark_var arg curr) args - | Region body -> - mark_curr curr; - mark_loop ~toplevel [] body - | Exclave body -> - mark_curr curr; - mark_loop ~toplevel [] body - | Proved_unreachable -> - mark_curr curr - - and mark_named ~toplevel curr (named : Flambda.named) = - match named with - | Set_of_closures (set_of_closures) -> - mark_loop_set_of_closures ~toplevel curr set_of_closures - | Const _ | Allocated_const _ -> () - | Read_mutable _ -> mark_curr curr - | Symbol symbol -> begin - let current_unit = Compilation_unit.get_current_exn () in - if Compilation_unit.equal current_unit (Symbol.compilation_unit symbol) - then - () - else - match (Backend.import_symbol symbol).descr with - | Value_unresolved _ -> - (* Constant when 'for_clambda' means: can be a symbol (which is - obviously the case here) with a known approximation. If this - condition is not satisfied we mark as inconstant to reflect - the fact that the symbol's contents are unknown and thus - prevent attempts to examine it. (This is a bit of a hack.) *) - mark_curr curr - | _ -> - () - end - | Read_symbol_field (symbol, index) -> - register_implication ~in_nc:(Symbol_field (symbol, index)) - ~implies_in_nc:curr - (* Constant constructors: those expressions are constant if all their - parameters are: - - makeblock is compiled to a constant block - - offset is compiled to a pointer inside a constant closure. - See Cmmgen for the details - - makeblock(Mutable) can be a 'constant' if it is allocated at - toplevel: if this expression is evaluated only once. - *) - | Prim (Pmakeblock (_tag, (Immutable | Immutable_unique), - _value_kind, _mode), args, _dbg) -> - mark_vars args curr -(* (* CR-someday pchambart: If global mutables are allowed: *) - | Prim(Lambda.Pmakeblock(_tag, Asttypes.Mutable), args, _dbg, _) - when toplevel -> - List.iter (mark_loop ~toplevel curr) args -*) - | Prim (Pmakearray (Pfloatarray, (Immutable | Immutable_unique), _mode), - args, _) -> - mark_vars args curr - | Prim (Pmakearray (Pfloatarray, Mutable, _mode), args, _) -> - (* CR-someday pchambart: Toplevel float arrays could always be - statically allocated using an equivalent of the - Initialize_symbol construction. - Toplevel non-float arrays could also be turned into an - Initialize_symbol, but only when declared as immutable since - preallocated symbols does not allow mutation after - initialisation - *) - if toplevel then mark_vars args curr - else mark_curr curr - | Prim (Pduparray (Pfloatarray, (Immutable | Immutable_unique)), - [arg], _) -> - mark_var arg curr - | Prim (Pduparray (Pfloatarray, Mutable), [arg], _) -> - if toplevel then mark_var arg curr - else mark_curr curr - | Prim (Pduparray _, _, _) -> - (* See Lift_constants *) - mark_curr curr - | Project_closure ({ set_of_closures; closure_id; }) -> - if Closure_id.in_compilation_unit closure_id compilation_unit then - mark_var set_of_closures curr - else - mark_curr curr - | Move_within_set_of_closures ({ closure; start_from; move_to; }) -> - (* CR-someday mshinwell: We should be able to deem these projections - (same for the cases below) as constant when from another - compilation unit, but there isn't code to handle this yet. (Note - that for Project_var we cannot yet generate a projection from a - closure in another compilation unit, since we only lift closed - closures.) *) - if Closure_id.in_compilation_unit start_from compilation_unit then begin - assert (Closure_id.in_compilation_unit move_to compilation_unit); - mark_var closure curr - end else begin - mark_curr curr - end - | Project_var ({ closure; closure_id; var = _ }) -> - if Closure_id.in_compilation_unit closure_id compilation_unit then - mark_var closure curr - else - mark_curr curr - | Prim (Pfield _, [f1], _) -> - mark_curr curr; - mark_var f1 curr - | Prim (_, args, _) -> - mark_curr curr; - mark_vars args curr - | Expr flam -> - mark_loop ~toplevel curr flam - - and mark_var var curr = - (* adds 'id in NC => curr in NC' *) - register_implication ~in_nc:(Var var) ~implies_in_nc:curr - - and mark_vars vars curr = - (* adds 'id in NC => curr in NC' *) - List.iter (fun var -> mark_var var curr) vars - - (* [toplevel] is intended for allowing static allocations of mutable - blocks. This feature should be available in a future release once the - necessary GC changes have been merged. (See GPR#178.) *) - and mark_loop_set_of_closures ~toplevel:_ curr - { Flambda. function_decls; free_vars; specialised_args } = - (* If a function in the set of closures is specialised, do not consider - it constant, unless all specialised args are also constant. *) - Variable.Map.iter (fun _ (spec_arg : Flambda.specialised_to) -> - register_implication - ~in_nc:(Var spec_arg.var) - ~implies_in_nc:[Closure function_decls.set_of_closures_id]) - specialised_args; - (* adds 'function_decls in NC => curr in NC' *) - register_implication ~in_nc:(Closure function_decls.set_of_closures_id) - ~implies_in_nc:curr; - (* a closure is constant if its free variables are constants. *) - Variable.Map.iter (fun inner_id (var : Flambda.specialised_to) -> - register_implication ~in_nc:(Var var.var) - ~implies_in_nc:[ - Var inner_id; - Closure function_decls.set_of_closures_id - ]) - free_vars; - Variable.Map.iter (fun fun_id (ffunc : Flambda.function_declaration) -> - (* for each function f in a closure c 'c in NC => f' *) - register_implication ~in_nc:(Closure function_decls.set_of_closures_id) - ~implies_in_nc:[Var fun_id]; - (* function parameters are in NC unless specialised *) - List.iter (fun param -> - match Variable.Map.find param specialised_args with - | exception Not_found -> mark_curr [Var param] - | outer_var -> - register_implication ~in_nc:(Var outer_var.var) - ~implies_in_nc:[Var param]) - (Parameter.List.vars ffunc.params); - mark_loop ~toplevel:false [] ffunc.body) - function_decls.funs - - let mark_constant_defining_value (const:Flambda.constant_defining_value) = - match const with - | Allocated_const _ - | Block _ - | Project_closure _ -> () - | Set_of_closures set_of_closure -> - mark_loop_set_of_closures ~toplevel:true [] set_of_closure - - let mark_program (program : Flambda.program) = - let rec loop (program : Flambda.program_body) = - match program with - | End _ -> () - | Initialize_symbol (symbol,_tag,fields,program) -> - List.iteri (fun i field -> - mark_loop ~toplevel:true - [Symbol symbol; Symbol_field (symbol,i)] field) - fields; - loop program - | Effect (expr, program) -> - mark_loop ~toplevel:true [] expr; - loop program - | Let_symbol (_, def, program) -> - mark_constant_defining_value def; - loop program - | Let_rec_symbol (defs, program) -> - List.iter (fun (_, def) -> mark_constant_defining_value def) defs; - loop program - in - loop program.program_body - - let res = - mark_program program; - { id = variables; - closure = closures; - } -end - -let inconstants_on_program ~compilation_unit ~backend - (program : Flambda.program) = - let module P = struct - let program = program - let compilation_unit = compilation_unit - end in - let module Backend = (val backend : Backend_intf.S) in - let module I = Inconstants (P) (Backend) in - I.res - -let variable var { id; _ } = - match Variable.Tbl.find id var with - | Not_constant -> true - | Implication _ -> false - | exception Not_found -> false - -let closure cl { closure; _ } = - match Set_of_closures_id.Tbl.find closure cl with - | Not_constant -> true - | Implication _ -> false - | exception Not_found -> false diff --git a/middle_end/flambda/inconstant_idents.mli b/middle_end/flambda/inconstant_idents.mli deleted file mode 100644 index 2c5309e0224..00000000000 --- a/middle_end/flambda/inconstant_idents.mli +++ /dev/null @@ -1,36 +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"] - -type result - -(** [inconstants_on_program] finds those variables and set-of-closures - identifiers that cannot be compiled to constants by [Flambda_to_clambda]. -*) -val inconstants_on_program - : compilation_unit:Compilation_unit.t - -> backend:(module Backend_intf.S) - -> Flambda.program - -> result - -(** [variable var res] returns [true] if [var] is marked as inconstant - in [res]. *) -val variable : Variable.t -> result -> bool - -(** [closure cl res] returns [true] if [cl] is marked as inconstant - in [res]. *) -val closure : Set_of_closures_id.t -> result -> bool diff --git a/middle_end/flambda/initialize_symbol_to_let_symbol.ml b/middle_end/flambda/initialize_symbol_to_let_symbol.ml deleted file mode 100644 index 31246b0d46b..00000000000 --- a/middle_end/flambda/initialize_symbol_to_let_symbol.ml +++ /dev/null @@ -1,57 +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-66"] -open! Int_replace_polymorphic_compare - -let constant_field (expr:Flambda.t) - : Flambda.constant_defining_value_block_field option = - match expr with - | Let { var; defining_expr = Const c; body = Var var' ; _ } -> - assert(Variable.equal var var'); - (* This must be true since var is the only variable in scope *) - Some (Flambda.Const c) - | Let { var; defining_expr = Symbol s; body = Var var' ; _ } -> - assert(Variable.equal var var'); - Some (Flambda.Symbol s) - | _ -> - None - -let rec loop (program : Flambda.program_body) : Flambda.program_body = - match program with - | Initialize_symbol (symbol, tag, fields, program) -> - let constant_fields = List.map constant_field fields in - begin - match Misc.Stdlib.List.some_if_all_elements_are_some constant_fields - with - | None -> - Initialize_symbol (symbol, tag, fields, loop program) - | Some fields -> - Let_symbol (symbol, Block (tag, fields), loop program) - end - | Let_symbol (symbol, const, program) -> - Let_symbol (symbol, const, loop program) - | Let_rec_symbol (defs, program) -> - Let_rec_symbol (defs, loop program) - | Effect (expr, program) -> - Effect (expr, loop program) - | End symbol -> - End symbol - -let run (program : Flambda.program) = - { program with - program_body = loop program.program_body; - } diff --git a/middle_end/flambda/initialize_symbol_to_let_symbol.mli b/middle_end/flambda/initialize_symbol_to_let_symbol.mli deleted file mode 100644 index fc54f760754..00000000000 --- a/middle_end/flambda/initialize_symbol_to_let_symbol.mli +++ /dev/null @@ -1,25 +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"] - -val constant_field - : Flambda.t - -> Flambda.constant_defining_value_block_field option - -(** Transform Initialize_symbol with only constant fields to - let_symbol construction. *) -val run : Flambda.program -> Flambda.program diff --git a/middle_end/flambda/inline_and_simplify.ml b/middle_end/flambda/inline_and_simplify.ml deleted file mode 100644 index cbf7f4d013d..00000000000 --- a/middle_end/flambda/inline_and_simplify.ml +++ /dev/null @@ -1,1833 +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-66"] -open! Int_replace_polymorphic_compare - -module A = Simple_value_approx -module B = Inlining_cost.Benefit -module E = Inline_and_simplify_aux.Env -module R = Inline_and_simplify_aux.Result - -(** Values of two types hold the information propagated during simplification: - - [E.t] "environments", top-down, almost always called "env"; - - [R.t] "results", bottom-up approximately following the evaluation order, - almost always called "r". These results come along with rewritten - Flambda terms. - The environments map variables to approximations, which enable various - simplifications to be performed; for example, some variable may be known - to always hold a particular constant. -*) - -let ret = R.set_approx - -type simplify_variable_result = - | No_binding of Variable.t - | Binding of Variable.t * (Flambda.named Flambda.With_free_variables.t) - -let simplify_free_variable_internal env original_var = - let var = Freshening.apply_variable (E.freshening env) original_var in - let original_var = var in - (* In the case where an approximation is useful, we introduce a [let] - to bind (e.g.) the constant or symbol replacing [var], unless this - would introduce a useless [let] as a consequence of [var] already being - in the current scope. - - Even when the approximation is not useful, this simplification helps. - In particular, it squashes aliases of the form: - let var1 = var2 in ... var2 ... - by replacing [var2] in the body with [var1]. Simplification can then - eliminate the [let]. - *) - let var = - let approx = E.find_exn env var in - match approx.var with - | Some var when E.mem env var -> var - | Some _ | None -> var - in - (* CR-soon mshinwell: Should we update [r] when we *add* code? - Aside from that, it looks like maybe we don't need [r] in this function, - because the approximation within it wouldn't be used by any of the - call sites. *) - match E.find_with_scope_exn env var with - | Current, approx -> No_binding var, approx (* avoid useless [let] *) - | Outer, approx -> - match A.simplify_var approx with - | None -> No_binding var, approx - | Some (named, approx) -> - let module W = Flambda.With_free_variables in - Binding (original_var, W.of_named named), approx - -let simplify_free_variable env var ~f : Flambda.t * R.t = - match simplify_free_variable_internal env var with - | No_binding var, approx -> f env var approx - | Binding (var, named), approx -> - let module W = Flambda.With_free_variables in - let var = Variable.rename var in - let env = E.add env var approx in - let body, r = f env var approx in - (W.create_let_reusing_defining_expr var named body), r - -let simplify_free_variables env vars ~f : Flambda.t * R.t = - let rec collect_bindings vars env bound_vars approxs : Flambda.t * R.t = - match vars with - | [] -> f env (List.rev bound_vars) (List.rev approxs) - | var::vars -> - match simplify_free_variable_internal env var with - | No_binding var, approx -> - collect_bindings vars env (var::bound_vars) (approx::approxs) - | Binding (var, named), approx -> - let module W = Flambda.With_free_variables in - let var = Variable.rename var in - let env = E.add env var approx in - let body, r = - collect_bindings vars env (var::bound_vars) (approx::approxs) - in - (W.create_let_reusing_defining_expr var named body), r - in - collect_bindings vars env [] [] - -let simplify_free_variables_named env vars ~f : Flambda.named * R.t = - let rec collect_bindings vars env bound_vars approxs - : Flambda.maybe_named * R.t = - match vars with - | [] -> - let named, r = f env (List.rev bound_vars) (List.rev approxs) in - Is_named named, r - | var::vars -> - match simplify_free_variable_internal env var with - | No_binding var, approx -> - collect_bindings vars env (var::bound_vars) (approx::approxs) - | Binding (var, named), approx -> - let module W = Flambda.With_free_variables in - let var = Variable.rename var in - let env = E.add env var approx in - let body, r = - collect_bindings vars env (var::bound_vars) (approx::approxs) - in - let body = - match body with - | Is_named body -> - let name = Internal_variable_names.simplify_fv in - Flambda_utils.name_expr body ~name - | Is_expr body -> body - in - Is_expr (W.create_let_reusing_defining_expr var named body), r - in - let named_or_expr, r = collect_bindings vars env [] [] in - match named_or_expr with - | Is_named named -> named, r - | Is_expr expr -> Expr expr, r - -(* CR-soon mshinwell: tidy this up *) -let simplify_free_variable_named env var ~f : Flambda.named * R.t = - simplify_free_variables_named env [var] ~f:(fun env vars vars_approxs -> - match vars, vars_approxs with - | [var], [approx] -> f env var approx - | _ -> assert false) - -let simplify_named_using_approx r lam approx = - let lam, _summary, approx = A.simplify_named approx lam in - lam, R.set_approx r approx - -let simplify_using_approx_and_env env r original_lam approx = - let lam, summary, approx = - A.simplify_using_env approx ~is_present_in_env:(E.mem env) original_lam - in - let r = - let r = ret r approx in - match summary with - (* CR-soon mshinwell: Why is [r] not updated with the cost of adding the - new code? - mshinwell: similar to CR above *) - | Replaced_term -> R.map_benefit r (B.remove_code original_lam) - | Nothing_done -> r - in - lam, r - -let simplify_named_using_approx_and_env env r original_named approx = - let named, summary, approx = - A.simplify_named_using_env approx ~is_present_in_env:(E.mem env) - original_named - in - let r = - let r = ret r approx in - match summary with - | Replaced_term -> R.map_benefit r (B.remove_code_named original_named) - | Nothing_done -> r - in - named, r - -let simplify_const (const : Flambda.const) = - match const with - | Int i -> A.value_int i - | Char c -> A.value_char c - -let approx_for_allocated_const (const : Allocated_const.t) = - match const with - | String s -> A.value_string (String.length s) None - | Immutable_string s -> A.value_string (String.length s) (Some s) - | Int32 i -> A.value_boxed_int Int32 i - | Int64 i -> A.value_boxed_int Int64 i - | Nativeint i -> A.value_boxed_int Nativeint i - | Float f -> A.value_float f - | Float_array a -> A.value_mutable_float_array ~size:(List.length a) - | Immutable_float_array a -> - A.value_immutable_float_array - (Array.map A.value_float (Array.of_list a)) - -type filtered_switch_branches = - | Must_be_taken of Flambda.t - | Can_be_taken of (int * Flambda.t) list - -(* Determine whether a given closure ID corresponds directly to a variable - (bound to a closure) in the given environment. This happens when the body - of a [let rec]-bound function refers to another in the same set of closures. - If we succeed in this process, we can change [Project_closure] - expressions into [Var] expressions, thus sharing closure projections. *) -let reference_recursive_function_directly env closure_id = - let closure_id = Closure_id.unwrap closure_id in - match E.find_opt env closure_id with - | None -> None - | Some approx -> Some (Flambda.Expr (Var closure_id), approx) - -(* Simplify an expression that takes a set of closures and projects an - individual closure from it. *) -let simplify_project_closure env r ~(project_closure : Flambda.project_closure) - : Flambda.named * R.t = - simplify_free_variable_named env project_closure.set_of_closures - ~f:(fun _env set_of_closures set_of_closures_approx -> - match A.check_approx_for_set_of_closures set_of_closures_approx with - | Wrong -> - Misc.fatal_errorf "Wrong approximation when projecting closure: %a" - Flambda.print_project_closure project_closure - | Unresolved value -> - (* A set of closures coming from another compilation unit, whose .cmx is - missing; as such, we cannot have rewritten the function and don't - need to do any freshening. *) - Project_closure { - set_of_closures; - closure_id = project_closure.closure_id; - }, ret r (A.value_unresolved value) - | Unknown -> - (* CR-soon mshinwell: see CR comment in e.g. simple_value_approx.ml - [check_approx_for_closure_allowing_unresolved] *) - Project_closure { - set_of_closures; - closure_id = project_closure.closure_id; - }, ret r (A.value_unknown Other) - | Unknown_because_of_unresolved_value value -> - Project_closure { - set_of_closures; - closure_id = project_closure.closure_id; - }, ret r (A.value_unknown (Unresolved_value value)) - | Ok (set_of_closures_var, value_set_of_closures) -> - let closure_id = - A.freshen_and_check_closure_id value_set_of_closures - project_closure.closure_id - in - let projecting_from = - match set_of_closures_var with - | None -> None - | Some set_of_closures_var -> - let projection : Projection.t = - Project_closure { - set_of_closures = set_of_closures_var; - closure_id; - } - in - match E.find_projection env ~projection with - | None -> None - | Some var -> Some (var, projection) - in - match projecting_from with - | Some (var, projection) -> - simplify_free_variable_named env var ~f:(fun _env var var_approx -> - let r = R.map_benefit r (B.remove_projection projection) in - Expr (Var var), ret r var_approx) - | None -> - match reference_recursive_function_directly env closure_id with - | Some (flam, approx) -> flam, ret r approx - | None -> - let set_of_closures_var = - match set_of_closures_var with - | Some set_of_closures_var' when E.mem env set_of_closures_var' -> - set_of_closures_var - | Some _ | None -> None - in - let approx = - A.value_closure ?set_of_closures_var value_set_of_closures - closure_id - in - Project_closure { set_of_closures; closure_id; }, ret r approx) - -(* Simplify an expression that, given one closure within some set of - closures, returns another closure (possibly the same one) within the - same set. *) -let simplify_move_within_set_of_closures env r - ~(move_within_set_of_closures : Flambda.move_within_set_of_closures) - : Flambda.named * R.t = - simplify_free_variable_named env move_within_set_of_closures.closure - ~f:(fun _env closure closure_approx -> - match A.check_approx_for_closure_allowing_unresolved closure_approx with - | Wrong -> - Misc.fatal_errorf "Wrong approximation when moving within set of \ - closures. Approximation: %a Term: %a" - A.print closure_approx - Flambda.print_move_within_set_of_closures move_within_set_of_closures - | Unresolved sym -> - Move_within_set_of_closures { - closure; - start_from = move_within_set_of_closures.start_from; - move_to = move_within_set_of_closures.move_to; - }, - ret r (A.value_unresolved sym) - | Unknown -> - Move_within_set_of_closures { - closure; - start_from = move_within_set_of_closures.start_from; - move_to = move_within_set_of_closures.move_to; - }, - ret r (A.value_unknown Other) - | Unknown_because_of_unresolved_value value -> - (* For example: a move upon a (move upon a closure whose .cmx file - is missing). *) - Move_within_set_of_closures { - closure; - start_from = move_within_set_of_closures.start_from; - move_to = move_within_set_of_closures.move_to; - }, - ret r (A.value_unknown (Unresolved_value value)) - | Ok (_value_closure, set_of_closures_var, set_of_closures_symbol, - value_set_of_closures) -> - let freshen = - (* CR-soon mshinwell: potentially misleading name---not freshening with - new names, but with previously fresh names *) - A.freshen_and_check_closure_id value_set_of_closures - in - let move_to = freshen move_within_set_of_closures.move_to in - let start_from = freshen move_within_set_of_closures.start_from in - let projection : Projection.t = - Move_within_set_of_closures { - closure; - start_from; - move_to; - } - in - match E.find_projection env ~projection with - | Some var -> - simplify_free_variable_named env var ~f:(fun _env var var_approx -> - let r = R.map_benefit r (B.remove_projection projection) in - Expr (Var var), ret r var_approx) - | None -> - match reference_recursive_function_directly env move_to with - | Some (flam, approx) -> flam, ret r approx - | None -> - if Closure_id.equal start_from move_to then - (* Moving from one closure to itself is a no-op. We can return an - [Var] since we already have a variable bound to the closure. *) - Expr (Var closure), ret r closure_approx - else - match set_of_closures_var with - | Some set_of_closures_var when E.mem env set_of_closures_var -> - (* A variable bound to the set of closures is in scope, - meaning we can rewrite the [Move_within_set_of_closures] to a - [Project_closure]. *) - let project_closure : Flambda.project_closure = - { set_of_closures = set_of_closures_var; - closure_id = move_to; - } - in - let approx = - A.value_closure ~set_of_closures_var value_set_of_closures - move_to - in - Project_closure project_closure, ret r approx - | Some _ | None -> - match set_of_closures_symbol with - | Some set_of_closures_symbol -> - let set_of_closures_var = - Variable.create Internal_variable_names.symbol - in - let project_closure : Flambda.project_closure = - { set_of_closures = set_of_closures_var; - closure_id = move_to; - } - in - let project_closure_var = - Variable.create Internal_variable_names.project_closure - in - let let1 = - Flambda.create_let project_closure_var - (Project_closure project_closure) - (Var project_closure_var) - in - let expr = - Flambda.create_let set_of_closures_var - (Symbol set_of_closures_symbol) - let1 - in - let approx = - A.value_closure ~set_of_closures_var ~set_of_closures_symbol - value_set_of_closures move_to - in - Expr expr, ret r approx - | None -> - (* The set of closures is not available in scope, and we - have no other information by which to simplify the move. *) - let move_within : Flambda.move_within_set_of_closures = - { closure; start_from; move_to; } - in - let approx = A.value_closure value_set_of_closures move_to in - Move_within_set_of_closures move_within, ret r approx) - -let remove_exclaves (lam : Flambda.t) = - let rec remove lam ~depth : Flambda.t = - match (lam : Flambda.t) with - | Region body -> - let new_body = remove ~depth:(depth + 1) body in - if new_body == body then lam else Region new_body - | Exclave body -> - if depth = 0 then body - else - let new_body = remove ~depth:(depth - 1) body in - if new_body == body then lam else Exclave new_body - | Apply ({ reg_close = Rc_close_at_apply; _ } as apply) when depth = 0 -> - (* Can still be compiled as a tail call, so use [Rc_normal] rather than - [Rc_nontail] *) - Apply { apply with reg_close = Rc_normal } - | Send ({ reg_close = Rc_close_at_apply; _ } as send) when depth = 0 -> - (* Similar to [Apply] *) - Send { send with reg_close = Rc_normal } - | _ -> - Flambda_iterators.map_tail_subexpressions (remove ~depth) lam - in - remove lam ~depth:0 - -(* Transform an expression denoting an access to a variable bound in - a closure. Variables in the closure ([project_var.closure]) may - have been freshened since [expr] was constructed; as such, we - must ensure the same happens to [expr]. The renaming information is - contained within the approximation deduced from [closure] (as - such, that approximation *must* identify which closure it is). - - For instance in some imaginary syntax for flambda: - - [let f x = - let g y ~closure:{a} = a + y in - let closure = { a = x } in - g 12 ~closure] - - when [f] is traversed, [g] can be inlined, resulting in the - expression - - [let f z = - let g y ~closure:{a} = a + y in - let closure = { a = x } in - closure.a + 12] - - [closure.a] being a notation for: - - [Project_var{closure = closure; closure_id = g; var = a}] - - If [f] is inlined later, the resulting code will be - - [let x = ... in - let g' y' ~closure':{a'} = a' + y' in - let closure' = { a' = x } in - closure'.a' + 12] - - in particular the field [a] of the closure has been alpha renamed to [a']. - This information must be carried from the declaration to the use. - - If the function is declared outside of the alpha renamed part, there is - no need for renaming in the [Ffunction] and [Project_var]. - This is not usually the case, except when the closure declaration is a - symbol. - - What ensures that this information is available at [Project_var] - point is that those constructions can only be introduced by inlining, - which requires that same information. For this to still be valid, - other transformation must avoid transforming the information flow in - a way that the inline function can't propagate it. -*) -let rec simplify_project_var env r ~(project_var : Flambda.project_var) - : Flambda.named * R.t = - simplify_free_variable_named env project_var.closure - ~f:(fun _env closure approx -> - match A.check_approx_for_closure_allowing_unresolved approx with - | Ok (value_closure, _set_of_closures_var, _set_of_closures_symbol, - value_set_of_closures) -> - let module F = Freshening.Project_var in - let freshening = value_set_of_closures.freshening in - let var = F.apply_var_within_closure freshening project_var.var in - let closure_id = F.apply_closure_id freshening project_var.closure_id in - let closure_id_in_approx = value_closure.closure_id in - if not (Closure_id.equal closure_id closure_id_in_approx) then begin - Misc.fatal_errorf "When simplifying [Project_var], the closure ID %a \ - in the approximation of the set of closures did not match the \ - closure ID %a in the [Project_var] term. Approximation: %a@. \ - Var-within-closure being projected: %a@." - Closure_id.print closure_id_in_approx - Closure_id.print closure_id - Simple_value_approx.print approx - Var_within_closure.print var - end; - let projection : Projection.t = - Project_var { - closure; - closure_id; - var; - kind = project_var.kind; - } - in - begin match E.find_projection env ~projection with - | Some var -> - simplify_free_variable_named env var ~f:(fun _env var var_approx -> - let r = R.map_benefit r (B.remove_projection projection) in - Expr (Var var), ret r var_approx) - | None -> - let approx = A.approx_for_bound_var value_set_of_closures var in - let expr : Flambda.named = - Project_var { closure; closure_id; var; kind = project_var.kind; } - in - let unwrapped = Var_within_closure.unwrap var in - let expr = - if E.mem env unwrapped then - Flambda.Expr (Var unwrapped) - else - expr - in - simplify_named_using_approx_and_env env r expr approx - end - | Unresolved symbol -> - (* This value comes from a symbol for which we couldn't find any - approximation, telling us that names within the closure couldn't - have been renamed. So we don't need to change the variable or - closure ID in the [Project_var] expression. *) - Project_var { project_var with closure }, - ret r (A.value_unresolved symbol) - | Unknown -> - Project_var { project_var with closure }, - ret r (A.value_unknown Other) - | Unknown_because_of_unresolved_value value -> - Project_var { project_var with closure }, - ret r (A.value_unknown (Unresolved_value value)) - | Wrong -> - (* We must have the correct approximation of the value to ensure - we take account of all freshenings. *) - Misc.fatal_errorf "[Project_var] from a value with wrong \ - approximation: %a@.closure=%a@.approx of closure=%a@." - Flambda.print_project_var project_var - Variable.print closure - Simple_value_approx.print approx) - -(* Transforms closure definitions by applying [loop] on the code of every - one of the set and on the expressions of the free variables. - If the substitution is activated, alpha renaming also occur on everything - defined by the set of closures: - * Variables bound by a closure of the set - * closure identifiers - * parameters - - The rewriting occurs in a clean environment without any of the variables - defined outside reachable. This helps increase robustness against - accidental, potentially unsound simplification of variable accesses by - [simplify_using_approx_and_env]. - - The rewriting occurs in an environment filled with: - * The approximation of the free variables - * An explicitly unknown approximation for function parameters, - except for those where it is known to be safe: those present in the - [specialised_args] set. - * An approximation for the closures in the set. It contains the code of - the functions before rewriting. - - The approximation of the currently defined closures is available to - allow marking recursives calls as direct and in some cases, allow - inlining of one closure from the set inside another one. For this to - be correct an alpha renaming is first applied on the expressions by - [apply_function_decls_and_free_vars]. - - For instance when rewriting the declaration - - [let rec f_1 x_1 = - let y_1 = x_1 + 1 in - g_1 y_1 - and g_1 z_1 = f_1 (f_1 z_1)] - - When rewriting this function, the first substitution will contain - some mapping: - { f_1 -> f_2; - g_1 -> g_2; - x_1 -> x_2; - z_1 -> z_2 } - - And the approximation for the closure will contain - - { f_2: - fun x_2 -> - let y_1 = x_2 + 1 in - g_2 y_1 - g_2: - fun z_2 -> f_2 (f_2 z_2) } - - Note that no substitution is applied to the let-bound variable [y_1]. - If [f_2] where to be inlined inside [g_2], we known that a new substitution - will be introduced in the current scope for [y_1] each time. - - - If the function where a recursive one coming from another compilation - unit, the code already went through [Flambdasym] that could have - replaced the function variable by the symbol identifying the function - (this occur if the function contains only constants in its closure). - To handle that case, we first replace those symbols by the original - variable. -*) -and simplify_set_of_closures original_env r - (set_of_closures : Flambda.set_of_closures) - : Flambda.set_of_closures * R.t * Freshening.Project_var.t = - let function_decls = - (* CR-soon mshinwell: Does this affect - [reference_recursive_function_directly]? - mshinwell: This should be thought about as part of the wider issue of - references to functions via symbols or variables. *) - Freshening.rewrite_recursive_calls_with_symbols (E.freshening original_env) - set_of_closures.function_decls - in - let env = E.increase_closure_depth original_env in - let free_vars, specialised_args, function_decls, parameter_approximations, - internal_value_set_of_closures, set_of_closures_env = - Inline_and_simplify_aux.prepare_to_simplify_set_of_closures ~env - ~set_of_closures ~function_decls ~only_for_function_decl:None - ~freshen:true - in - let simplify_function fun_var (function_decl : Flambda.function_declaration) - (funs, used_params, r) - : Flambda.function_declaration Variable.Map.t * Variable.Set.t * R.t = - let closure_env = - Inline_and_simplify_aux.prepare_to_simplify_closure ~function_decl - ~free_vars ~specialised_args ~parameter_approximations - ~set_of_closures_env - in - let body, r = - E.enter_closure closure_env ~closure_id:(Closure_id.wrap fun_var) - ~inline_inside: - (Inlining_decision.should_inline_inside_declaration function_decl) - ~dbg:function_decl.dbg - ~f:(fun body_env -> - assert (E.inside_set_of_closures_declaration - function_decls.set_of_closures_origin body_env); - simplify body_env r function_decl.body) - in - let function_decl = - Flambda.create_function_declaration - ~params:function_decl.params - ~return_layout:function_decl.return_layout - ~alloc_mode:function_decl.alloc_mode ~region:function_decl.region - ~body ~stub:function_decl.stub - ~inline:function_decl.inline ~specialise:function_decl.specialise - ~check:function_decl.check - ~is_a_functor:function_decl.is_a_functor - ~closure_origin:function_decl.closure_origin - ~poll:function_decl.poll - in - let used_params' = Flambda.used_params function_decl in - Variable.Map.add fun_var function_decl funs, - Variable.Set.union used_params used_params', r - in - let funs, _used_params, r = - Variable.Map.fold simplify_function function_decls.funs - (Variable.Map.empty, Variable.Set.empty, r) - in - let function_decls = - Flambda.update_function_declarations function_decls ~funs - in - let invariant_params = - lazy (Invariant_params.invariant_params_in_recursion function_decls) - in - let recursive = - lazy (Find_recursive_functions.in_function_declarations function_decls) - in - let keep_body = - Inline_and_simplify_aux.keep_body_check - ~is_classic_mode:function_decls.is_classic_mode ~recursive - in - let function_decls_approx = - A.function_declarations_approx ~keep_body function_decls - in - let value_set_of_closures = - A.create_value_set_of_closures - ~function_decls:function_decls_approx - ~bound_vars:internal_value_set_of_closures.bound_vars - ~invariant_params - ~recursive - ~specialised_args:internal_value_set_of_closures.specialised_args - ~free_vars:internal_value_set_of_closures.free_vars - ~freshening:internal_value_set_of_closures.freshening - ~direct_call_surrogates: - internal_value_set_of_closures.direct_call_surrogates - in - let direct_call_surrogates = - Closure_id.Map.fold (fun existing surrogate surrogates -> - Variable.Map.add (Closure_id.unwrap existing) - (Closure_id.unwrap surrogate) surrogates) - internal_value_set_of_closures.direct_call_surrogates - Variable.Map.empty - in - let set_of_closures = - Flambda.create_set_of_closures ~function_decls - ~free_vars:(Variable.Map.map fst free_vars) - ~specialised_args - ~direct_call_surrogates - in - let r = ret r (A.value_set_of_closures value_set_of_closures) in - set_of_closures, r, value_set_of_closures.freshening - -and mark_region_used_for_apply ~(reg_close : Lambda.region_close) ~(mode : Lambda.alloc_mode) r = - let r = - (* A close-at-apply tail call is effectively a small exclave *) - match reg_close with - | Rc_close_at_apply -> R.set_region_has_exclave r - | Rc_normal | Rc_nontail -> r - in - let r = - match mode with - | Alloc_local -> R.set_region_used r - | Alloc_heap -> r - in - r - -and simplify_apply env r ~(apply : Flambda.apply) : Flambda.t * R.t = - let { - Flambda. func = lhs_of_application; args; kind = _; dbg; reg_close; mode; - inlined = inlined_requested; specialise = specialise_requested; - probe = probe_requested; result_layout - } = apply in - let r = mark_region_used_for_apply ~reg_close ~mode r in - let dbg = E.add_inlined_debuginfo env ~dbg in - simplify_free_variable env lhs_of_application - ~f:(fun env lhs_of_application lhs_of_application_approx -> - simplify_free_variables env args ~f:(fun env args args_approxs -> - (* By using the approximation of the left-hand side of the - application, attempt to determine which function is being applied - (even if the application is currently [Indirect]). If - successful---in which case we then have a direct - application---consider inlining. *) - match A.check_approx_for_closure lhs_of_application_approx with - | Ok (value_closure, set_of_closures_var, - set_of_closures_symbol, value_set_of_closures) -> - let lhs_of_application, closure_id_being_applied, - value_set_of_closures, env, wrap = - let closure_id_being_applied = value_closure.closure_id in - (* If the call site is a direct call to a function that has a - "direct call surrogate" (see inline_and_simplify_aux.mli), - repoint the call to the surrogate. *) - let surrogates = value_set_of_closures.direct_call_surrogates in - match Closure_id.Map.find closure_id_being_applied surrogates with - | exception Not_found -> - lhs_of_application, closure_id_being_applied, - value_set_of_closures, env, (fun expr -> expr) - | surrogate -> - let rec find_transitively surrogate = - match Closure_id.Map.find surrogate surrogates with - | exception Not_found -> surrogate - | surrogate -> find_transitively surrogate - in - let surrogate = find_transitively surrogate in - let surrogate_var = Variable.rename lhs_of_application in - let move_to_surrogate : Projection.move_within_set_of_closures = - { closure = lhs_of_application; - start_from = closure_id_being_applied; - move_to = surrogate; - } - in - let approx_for_surrogate = - A.value_closure ~closure_var:surrogate_var - ?set_of_closures_var ?set_of_closures_symbol - value_set_of_closures surrogate - in - let env = E.add env surrogate_var approx_for_surrogate in - let wrap expr = - Flambda.create_let surrogate_var - (Move_within_set_of_closures move_to_surrogate) - expr - in - surrogate_var, surrogate, value_set_of_closures, env, wrap - in - let function_decls = value_set_of_closures.function_decls in - let function_decl = - try - Variable.Map.find - (Closure_id.unwrap closure_id_being_applied) - function_decls.funs - with - | Not_found -> - Misc.fatal_errorf "When handling application expression, \ - approximation references non-existent closure %a@." - Closure_id.print closure_id_being_applied - in - let r = - match apply.kind with - | Indirect -> - R.map_benefit r Inlining_cost.Benefit.direct_call_of_indirect - | Direct _ -> r - in - let nargs = List.length args in - let arity = A.function_arity function_decl in - begin match probe_requested with - | None -> () - | Some {name} -> - if not (nargs = arity) then - Misc.fatal_errorf - "Probe %s handler with arity %d applied to %d args: %a" - name arity nargs Flambda.print (Flambda.Apply apply); - () - end; - let result, r = - if nargs = arity then - simplify_full_application env r ~function_decls ~result_layout - ~lhs_of_application ~closure_id_being_applied ~function_decl - ~value_set_of_closures ~args ~args_approxs ~dbg ~reg_close ~mode - ~inlined_requested ~specialise_requested ~probe_requested - else if nargs > arity then - simplify_over_application env r ~args ~args_approxs - ~function_decls ~lhs_of_application ~closure_id_being_applied - ~function_decl ~value_set_of_closures ~dbg ~reg_close ~mode - ~inlined_requested ~specialise_requested ~result_layout - else if nargs > 0 && nargs < arity then begin - assert(Lambda.compatible_layout Lambda.layout_function - result_layout); - simplify_partial_application env r ~lhs_of_application - ~closure_id_being_applied ~function_decl ~args ~mode ~dbg - ~inlined_requested ~specialise_requested - end - else - Misc.fatal_errorf "Function with arity %d when simplifying \ - application expression: %a" - arity Flambda.print (Flambda.Apply apply) - in - wrap result, r - | Wrong -> (* Insufficient approximation information to simplify. *) - Apply ({ func = lhs_of_application; args; kind = Indirect; dbg; - reg_close; mode; - inlined = inlined_requested; - specialise = specialise_requested; - probe = probe_requested; - result_layout; - }), - ret r (A.value_unknown Other))) - -and simplify_full_application env r ~function_decls ~lhs_of_application - ~closure_id_being_applied ~function_decl ~value_set_of_closures ~args - ~args_approxs ~dbg ~reg_close ~mode ~result_layout - ~inlined_requested ~specialise_requested ~probe_requested - = - Inlining_decision.for_call_site ~env ~r ~function_decls - ~lhs_of_application ~closure_id_being_applied ~function_decl - ~value_set_of_closures ~args ~args_approxs ~dbg ~reg_close ~mode ~simplify - ~inlined_requested ~specialise_requested ~probe_requested ~result_layout - -and simplify_partial_application env r ~lhs_of_application - ~closure_id_being_applied ~function_decl ~args ~mode ~dbg - ~inlined_requested ~specialise_requested - = - let arity = A.function_arity function_decl in - assert (arity > List.length args); - (* For simplicity, we disallow [@inline] attributes on partial - applications. The user may always write an explicit wrapper instead - with such an attribute. *) - (* CR-someday mshinwell: Pierre noted that we might like a function to be - inlined when applied to its first set of arguments, e.g. for some kind - of type class like thing. *) - begin match (inlined_requested : Lambda.inlined_attribute) with - | Always_inlined | Never_inlined -> - Location.prerr_warning (Debuginfo.to_location dbg) - (Warnings.Inlining_impossible "[@inlined] attributes may not be used \ - on partial applications") - | Unroll _ -> - Location.prerr_warning (Debuginfo.to_location dbg) - (Warnings.Inlining_impossible "[@unrolled] attributes may not be used \ - on partial applications") - | Hint_inlined | Default_inlined -> () - end; - begin match (specialise_requested : Lambda.specialise_attribute) with - | Always_specialise | Never_specialise -> - Location.prerr_warning (Debuginfo.to_location dbg) - (Warnings.Inlining_impossible "[@specialised] attributes may not be used \ - on partial applications") - | Default_specialise -> () - end; - let freshened_params = - List.map (fun p -> Parameter.rename p) function_decl.A.params - in - let applied_args, remaining_args = - Misc.Stdlib.List.map2_prefix (fun arg id' -> id', arg) - args freshened_params - in - let partial_mode = - List.fold_left (fun _mode (p,_) -> Parameter.alloc_mode p) - function_decl.A.alloc_mode applied_args - in - if not (Lambda.sub_mode partial_mode mode) then - Misc.fatal_errorf "Partial application of %a with wrong mode at %s" - Closure_id.print closure_id_being_applied - (Debuginfo.to_string dbg); - let result_mode = - if function_decl.A.region then Lambda.alloc_heap else Lambda.alloc_local - in - let wrapper_accepting_remaining_args = - let body : Flambda.t = - Apply { - func = lhs_of_application; - args = Parameter.List.vars freshened_params; - kind = Direct closure_id_being_applied; - dbg; - reg_close = Rc_normal; - mode = result_mode; - inlined = Default_inlined; - specialise = Default_specialise; - probe = None; - result_layout = function_decl.A.return_layout; - } - in - let closure_variable = - Variable.rename ~debug_info:(Closure_id.debug_info closure_id_being_applied) - (Closure_id.unwrap closure_id_being_applied) - in - let free_variables = - Variable.Map.of_list - (List.map (fun p -> Parameter.var p, Parameter.kind p) freshened_params) - in - let free_variables = - Variable.Map.add lhs_of_application Lambda.layout_function free_variables - in - Flambda_utils.make_closure_declaration ~id:closure_variable - ~is_classic_mode:false - ~body - ~alloc_mode:partial_mode - ~region:function_decl.A.region - ~params:remaining_args - ~return_layout:function_decl.A.return_layout - ~free_variables - in - let with_known_args = - Flambda_utils.bind - ~bindings:(List.map (fun (param, arg) -> - Parameter.var param, Flambda.Expr (Var arg)) applied_args) - ~body:wrapper_accepting_remaining_args - in - simplify env r with_known_args - -and simplify_over_application env r ~args ~args_approxs ~function_decls - ~lhs_of_application ~closure_id_being_applied ~function_decl - ~value_set_of_closures ~dbg ~reg_close ~mode ~result_layout - ~inlined_requested ~specialise_requested = - let arity = A.function_arity function_decl in - assert (arity < List.length args); - assert (List.length args = List.length args_approxs); - let full_app_args, remaining_args = - Misc.Stdlib.List.split_at arity args - in - let full_app_approxs, _ = - Misc.Stdlib.List.split_at arity args_approxs - in - let mode' = - if function_decl.A.region then Lambda.alloc_heap else Lambda.alloc_local - in - let expr, r = - simplify_full_application env r ~function_decls ~lhs_of_application - ~closure_id_being_applied ~function_decl ~value_set_of_closures - ~args:full_app_args ~args_approxs:full_app_approxs ~dbg - ~reg_close:Lambda.Rc_normal ~mode:mode' - ~result_layout:Lambda.layout_function - ~inlined_requested ~specialise_requested ~probe_requested:None - in - let func_var = Variable.create Internal_variable_names.full_apply in - let expr : Flambda.t = - Flambda.create_let func_var (Expr expr) - (Apply { func = func_var; args = remaining_args; kind = Indirect; dbg; - reg_close = Rc_normal; mode; result_layout; - inlined = inlined_requested; specialise = specialise_requested; - probe = None}) - in - let expr = Lift_code.lift_lets_expr expr ~toplevel:true in - let expr = - match mode, function_decl.A.region with - | Lambda.Alloc_heap, false -> Flambda.Region expr - | _ -> expr - in - let expr = - match reg_close with - | Lambda.Rc_close_at_apply -> Flambda.Exclave expr - | Lambda.Rc_normal | Lambda.Rc_nontail-> expr - in - simplify (E.set_never_inline env) r expr - -and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t = - match tree with - | Symbol sym -> - (* New Symbol construction could have been introduced during - transformation (by simplify_named_using_approx_and_env). - When this comes from another compilation unit, we must load it. *) - let approx = E.find_or_load_symbol env sym in - simplify_named_using_approx r tree approx - | Const cst -> tree, ret r (simplify_const cst) - | Allocated_const cst -> tree, ret r (approx_for_allocated_const cst) - | Read_mutable mut_var -> - (* See comment on the [Assign] case. *) - let mut_var = - Freshening.apply_mutable_variable (E.freshening env) mut_var - in - Read_mutable mut_var, ret r (A.value_unknown Other) - | Read_symbol_field (symbol, field_index) -> - let approx = E.find_or_load_symbol env symbol in - begin match A.get_field approx ~field_index with - (* CR-someday mshinwell: Think about [Unreachable] vs. [Value_bottom]. *) - | Unreachable -> (Flambda.Expr Proved_unreachable), r - | Ok approx -> - let approx = A.augment_with_symbol_field approx symbol field_index in - simplify_named_using_approx_and_env env r tree approx - end - | Set_of_closures set_of_closures -> begin - let r = - match set_of_closures.alloc_mode with - | Alloc_local -> R.set_region_used r - | Alloc_heap -> r - in - let set_of_closures, r, first_freshening = - simplify_set_of_closures env r set_of_closures - in - let simplify env r expr ~pass_name : Flambda.named * R.t = - (* If simplifying a set of closures more than once during any given round - of simplification, the [Freshening.Project_var] substitutions arising - from each call to [simplify_set_of_closures] must be composed. - Note that this function only composes with [first_freshening] owing - to the structure of the code below (this new [simplify] is always - in tail position). *) - (* CR-someday mshinwell: It was mooted that maybe we could try - structurally-typed closures (i.e. where we would never rename the - closure elements), or something else, to try to remove - the "closure freshening" thing in the approximation which is hard - to deal with. *) - let expr, r = simplify (E.set_never_inline env) r expr in - let approx = R.approx r in - let value_set_of_closures = - match A.strict_check_approx_for_set_of_closures approx with - | Wrong -> - Misc.fatal_errorf "Unexpected approximation returned from \ - simplification of [%s] result: %a" - pass_name A.print approx - | Ok (_var, value_set_of_closures) -> - let freshening = - Freshening.Project_var.compose ~earlier:first_freshening - ~later:value_set_of_closures.freshening - in - A.update_freshening_of_value_set_of_closures value_set_of_closures - ~freshening - in - Expr expr, (ret r (A.value_set_of_closures value_set_of_closures)) - in - (* This does the actual substitutions of specialised args introduced - by [Unbox_closures] for free variables. (Apart from simplifying - the [Unbox_closures] output, this also prevents applying - [Unbox_closures] over and over.) *) - let set_of_closures = - let ppf_dump = Inline_and_simplify_aux.Env.ppf_dump env in - match Remove_free_vars_equal_to_args.run ~ppf_dump set_of_closures with - | None -> set_of_closures - | Some set_of_closures -> set_of_closures - in - (* Do [Unbox_closures] next to try to decide which things are - free variables and which things are specialised arguments before - unboxing them. *) - match - Unbox_closures.rewrite_set_of_closures ~env - ~duplicate_function ~set_of_closures - with - | Some (expr, benefit) -> - let r = R.add_benefit r benefit in - simplify env r expr ~pass_name:"Unbox_closures" - | None -> - match Unbox_free_vars_of_closures.run ~env ~set_of_closures with - | Some (expr, benefit) -> - let r = R.add_benefit r benefit in - simplify env r expr ~pass_name:"Unbox_free_vars_of_closures" - | None -> - (* CR-soon mshinwell: should maybe add one allocation for the stub *) - match - Unbox_specialised_args.rewrite_set_of_closures ~env - ~duplicate_function ~set_of_closures - with - | Some (expr, benefit) -> - let r = R.add_benefit r benefit in - simplify env r expr ~pass_name:"Unbox_specialised_args" - | None -> - match - Remove_unused_arguments. - separate_unused_arguments_in_set_of_closures - set_of_closures - with - | Some set_of_closures -> - let expr = - Flambda_utils.name_expr (Set_of_closures set_of_closures) - ~name:Internal_variable_names.remove_unused_arguments - in - simplify env r expr ~pass_name:"Remove_unused_arguments" - | None -> - Set_of_closures set_of_closures, r - end - | Project_closure project_closure -> - simplify_project_closure env r ~project_closure - | Project_var project_var -> simplify_project_var env r ~project_var - | Move_within_set_of_closures move_within_set_of_closures -> - simplify_move_within_set_of_closures env r ~move_within_set_of_closures - | Prim (prim, args, dbg) -> - let dbg = E.add_inlined_debuginfo env ~dbg in - simplify_free_variables_named env args ~f:(fun env args args_approxs -> - let tree = Flambda.Prim (prim, args, dbg) in - let r = - if Semantics_of_primitives.may_locally_allocate prim then - R.set_region_used r - else r - in - begin match prim, args, args_approxs with - (* CR-someday mshinwell: Optimise [Pfield_computed]. *) - | Pfield (field_index, _, _, _), [arg], [arg_approx] -> - let projection : Projection.t = Field (field_index, arg) in - begin match E.find_projection env ~projection with - | Some var -> - simplify_free_variable_named env var ~f:(fun _env var var_approx -> - let r = R.map_benefit r (B.remove_projection projection) in - Expr (Var var), ret r var_approx) - | None -> - begin match A.get_field arg_approx ~field_index with - | Unreachable -> (Flambda.Expr Proved_unreachable, r) - | Ok approx -> - let tree, approx = - match arg_approx.symbol with - (* If the [Pfield] is projecting directly from a symbol, rewrite - the expression to [Read_symbol_field]. *) - | Some (symbol, None) -> - let approx = - A.augment_with_symbol_field approx symbol field_index - in - Flambda.Read_symbol_field (symbol, field_index), approx - | None | Some (_, Some _ ) -> - (* This [Pfield] is either not projecting from a symbol at all, - or it is the projection of a projection from a symbol. *) - let approx' = E.really_import_approx env approx in - tree, approx' - in - simplify_named_using_approx_and_env env r tree approx - end - end - | Pfield _, _, _ -> Misc.fatal_error "Pfield arity error" - | (Parraysetu skind | Parraysets skind), - [_block; _field; _value], - [block_approx; _field_approx; value_approx] -> - if A.warn_on_mutation block_approx then begin - Location.prerr_warning (Debuginfo.to_location dbg) - Warnings.Flambda_assignment_to_non_mutable_value - end; - let skind = - let check () = - match skind with - | Pfloatarray_set | Pgenarray_set _ -> () - | Paddrarray_set _ | Pintarray_set -> - (* CR pchambart: Do a proper warning here *) - Misc.fatal_errorf "Assignment of a float to a specialised \ - non-float array: %a" - Flambda.print_named tree - in - match A.descr block_approx, A.descr value_approx with - | (Value_float_array _, _) -> check (); Lambda.Pfloatarray_set - | (_, Value_float _) when Config.flat_float_array -> - check (); Lambda.Pfloatarray_set - (* CR pchambart: This should be accounted by the benefit *) - | _ -> - skind - in - let prim : Clambda_primitives.primitive = match prim with - | Parraysetu _ -> Parraysetu skind - | Parraysets _ -> Parraysets skind - | _ -> assert false - in - Prim (prim, args, dbg), ret r (A.value_unknown Other) - | Psetfield _, _block::_, block_approx::_ -> - if A.warn_on_mutation block_approx then begin - Location.prerr_warning (Debuginfo.to_location dbg) - Warnings.Flambda_assignment_to_non_mutable_value - end; - tree, ret r (A.value_unknown Other) - | (Psetfield _ | Parraysetu _ | Parraysets _), _, _ -> - Misc.fatal_error "Psetfield / Parraysetu / Parraysets arity error" - | (Psequand | Psequor), _, _ -> - Misc.fatal_error "Psequand and Psequor must be expanded (see handling \ - in closure_conversion.ml)" - | p, args, args_approxs -> - let expr, approx, benefit = - let module Backend = (val (E.backend env) : Backend_intf.S) in - Simplify_primitives.primitive p (args, args_approxs) tree dbg - ~size_int:Backend.size_int - in - let r = R.map_benefit r (B.(+) benefit) in - let approx = - match p with - | Popaque -> A.value_unknown Other - | _ -> approx - in - expr, ret r approx - end) - | Expr expr -> - let expr, r = simplify env r expr in - Expr expr, r - -and simplify env r (tree : Flambda.t) : Flambda.t * R.t = - match tree with - | Var var -> - let var = Freshening.apply_variable (E.freshening env) var in - (* If from the approximations we can simplify [var], then we will be - forced to insert [let]-expressions (done using [name_expr], in - [Simple_value_approx]) to bind a [named]. This has an important - consequence: it brings bindings of constants closer to their use - points. *) - simplify_using_approx_and_env env r (Var var) (E.find_exn env var) - | Apply apply -> - simplify_apply env r ~apply - | Let _ -> - let for_defining_expr (env, r) var defining_expr = - let defining_expr, r = simplify_named env r defining_expr in - let var, sb = Freshening.add_variable (E.freshening env) var in - let env = E.set_freshening env sb in - let env = E.add env var (R.approx r) in - (env, r), var, defining_expr - in - let for_last_body (env, r) body = - simplify env r body - in - let filter_defining_expr r var defining_expr free_vars_of_body = - if Variable.Set.mem var free_vars_of_body then - r, var, Some defining_expr - else if Effect_analysis.no_effects_named defining_expr then - let r = R.map_benefit r (B.remove_code_named defining_expr) in - r, var, None - else - r, var, Some defining_expr - in - Flambda.fold_lets_option tree - ~init:(env, r) - ~for_defining_expr - ~for_last_body - ~filter_defining_expr - | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> - (* CR-someday mshinwell: add the dead let elimination, as above. *) - simplify_free_variable env var ~f:(fun env var _var_approx -> - let mut_var, sb = - Freshening.add_mutable_variable (E.freshening env) mut_var - in - let env = E.set_freshening env sb in - let body, r = - simplify (E.add_mutable env mut_var (A.value_unknown Other)) r body - in - Flambda.Let_mutable - { var = mut_var; - initial_value = var; - body; - contents_kind }, - r) - | Let_rec (defs, body) -> - let defs, sb = Freshening.add_variables (E.freshening env) defs in - let env = E.set_freshening env sb in - let def_env = - List.fold_left (fun env_acc (id, _lam) -> - E.add env_acc id (A.value_unknown Other)) - env defs - in - let defs, body_env, r = - List.fold_right (fun (id, lam) (defs, env_acc, r) -> - let lam, r = simplify_named def_env r lam in - let defs = (id, lam) :: defs in - let env_acc = E.add env_acc id (R.approx r) in - defs, env_acc, r) - defs ([], env, r) - in - let body, r = simplify body_env r body in - Let_rec (defs, body), r - | Static_raise (i, args) -> - let i = Freshening.apply_static_exception (E.freshening env) i in - simplify_free_variables env args ~f:(fun _env args _args_approxs -> - let r = R.use_static_exception r i in - Static_raise (i, args), ret r A.value_bottom) - | Static_catch (i, vars, body, handler, kind) -> - begin - match body with - | Let { var; defining_expr = def; body; _ } - when not (Flambda_utils.might_raise_static_exn def i) -> - simplify env r - (Flambda.create_let var def (Static_catch (i, vars, body, handler, kind))) - | _ -> - let i, sb = Freshening.add_static_exception (E.freshening env) i in - let env = E.set_freshening env sb in - let body, r = simplify env r body in - (* CR-soon mshinwell: for robustness, R.used_static_exceptions should - maybe be removed. *) - if not (Static_exception.Set.mem i (R.used_static_exceptions r)) then - (* If the static exception is not used, we can drop the declaration *) - body, r - else begin - match (body : Flambda.t) with - | Static_raise (j, args) -> - assert (Static_exception.equal i j); - let handler = - List.fold_left2 (fun body (var, _layout) arg -> - Flambda.create_let var (Expr (Var arg)) body) - handler vars args - in - let r = R.exit_scope_catch r i in - simplify env r handler - | _ -> - let vars, sb = Freshening.add_variables (E.freshening env) vars in - let approx = R.approx r in - let env = - List.fold_left (fun env (id, _layout) -> - E.add env id (A.value_unknown Other)) - (E.set_freshening env sb) vars - in - let env = E.inside_branch env in - let handler, r = simplify env r handler in - let r = R.exit_scope_catch r i in - Static_catch (i, vars, body, handler, kind), - R.meet_approx r env approx - end - end - | Try_with (body, id, handler, kind) -> - let body, r = simplify env r body in - let id, sb = Freshening.add_variable (E.freshening env) id in - let env = E.add (E.set_freshening env sb) id (A.value_unknown Other) in - let env = E.inside_branch env in - let handler, r = simplify env r handler in - Try_with (body, id, handler, kind), ret r (A.value_unknown Other) - | If_then_else (arg, ifso, ifnot, kind) -> - (* When arg is the constant false or true (or something considered - as true), we can drop the if and replace it by a sequence. - if arg is not effectful we can also drop it. *) - simplify_free_variable env arg ~f:(fun env arg arg_approx -> - begin match arg_approx.descr with - | Value_int 0 -> (* Constant [false]: keep [ifnot] *) - let ifnot, r = simplify env r ifnot in - ifnot, R.map_benefit r B.remove_branch - | Value_int _ - | Value_block _ -> (* Constant [true]: keep [ifso] *) - let ifso, r = simplify env r ifso in - ifso, R.map_benefit r B.remove_branch - | _ -> - let env = E.inside_branch env in - let ifso, r = simplify env r ifso in - let ifso_approx = R.approx r in - let ifnot, r = simplify env r ifnot in - If_then_else (arg, ifso, ifnot, kind), - R.meet_approx r env ifso_approx - end) - | While (cond, body) -> - let cond, r = simplify env r cond in - let body, r = simplify env r body in - While (cond, body), ret r (A.value_unknown Other) - | Send { kind; meth; obj; args; dbg; reg_close; mode; result_layout } -> - let r = mark_region_used_for_apply ~reg_close ~mode r in - let dbg = E.add_inlined_debuginfo env ~dbg in - simplify_free_variable env meth ~f:(fun env meth _meth_approx -> - simplify_free_variable env obj ~f:(fun env obj _obj_approx -> - simplify_free_variables env args ~f:(fun _env args _args_approx -> - Send { kind; meth; obj; args; dbg; reg_close; mode; result_layout }, - ret r (A.value_unknown Other)))) - | For { bound_var; from_value; to_value; direction; body; } -> - simplify_free_variable env from_value ~f:(fun env from_value _approx -> - simplify_free_variable env to_value ~f:(fun env to_value _approx -> - let bound_var, sb = - Freshening.add_variable (E.freshening env) bound_var - in - let env = - E.add (E.set_freshening env sb) bound_var - (A.value_unknown Other) - in - let body, r = simplify env r body in - For { bound_var; from_value; to_value; direction; body; }, - ret r (A.value_unknown Other))) - | Assign { being_assigned; new_value; } -> - (* No need to use something like [simplify_free_variable]: the - approximation of [being_assigned] is always unknown. *) - let being_assigned = - Freshening.apply_mutable_variable (E.freshening env) being_assigned - in - simplify_free_variable env new_value ~f:(fun _env new_value _approx -> - Assign { being_assigned; new_value; }, ret r (A.value_unknown Other)) - | Switch (arg, sw) -> - (* When [arg] is known to be a variable whose approximation is that of a - block with a fixed tag or a fixed integer, we can eliminate the - [Switch]. (This should also make the [Let] that binds [arg] redundant, - meaning that it too can be eliminated.) *) - simplify_free_variable env arg ~f:(fun env arg arg_approx -> - let rec filter_branches filter branches compatible_branches = - match branches with - | [] -> Can_be_taken compatible_branches - | (c, lam) as branch :: branches -> - match filter arg_approx c with - | A.Cannot_be_taken -> - filter_branches filter branches compatible_branches - | A.Can_be_taken -> - filter_branches filter branches (branch :: compatible_branches) - | A.Must_be_taken -> - Must_be_taken lam - in - let filtered_consts = - filter_branches A.potentially_taken_const_switch_branch sw.consts [] - in - let filtered_blocks = - filter_branches A.potentially_taken_block_switch_branch sw.blocks [] - in - begin match filtered_consts, filtered_blocks with - | Must_be_taken _, Must_be_taken _ -> - assert false - | Must_be_taken branch, _ - | _, Must_be_taken branch -> - let lam, r = simplify env r branch in - lam, R.map_benefit r B.remove_branch - | Can_be_taken consts, Can_be_taken blocks -> - match consts, blocks, sw.failaction with - | [], [], None -> - (* If the switch is applied to a statically-known value that does not - match any case: - * if there is a default action take that case; - * otherwise this is something that is guaranteed not to - be reachable by the type checker. For example: - [type 'a t = Int : int -> int t | Float : float -> float t - match Int 1 with - | Int _ -> ... - | Float f as v -> - match v with <-- This match is unreachable - | Float f -> ...] - *) - Proved_unreachable, ret r A.value_bottom - | [_, branch], [], None - | [], [_, branch], None - | [], [], Some branch -> - let lam, r = simplify env r branch in - lam, R.map_benefit r B.remove_branch - | _ -> - let env = E.inside_branch env in - let f (i, v) (acc, r) = - let approx = R.approx r in - let lam, r = simplify env r v in - (i, lam)::acc, - R.meet_approx r env approx - in - let r = R.set_approx r A.value_bottom in - let consts, r = List.fold_right f consts ([], r) in - let blocks, r = List.fold_right f blocks ([], r) in - let failaction, r = - match sw.failaction with - | None -> None, r - | Some l -> - let approx = R.approx r in - let l, r = simplify env r l in - Some l, - R.meet_approx r env approx - in - let sw = { sw with failaction; consts; blocks; } in - Switch (arg, sw), r - end) - | String_switch (arg, sw, def, kind) -> - simplify_free_variable env arg ~f:(fun env arg arg_approx -> - match A.check_approx_for_string arg_approx with - | None -> - let env = E.inside_branch env in - let sw, r = - List.fold_right (fun (str, lam) (sw, r) -> - let approx = R.approx r in - let lam, r = simplify env r lam in - (str, lam)::sw, - R.meet_approx r env approx) - sw - ([], r) - in - let def, r = - match def with - | None -> def, r - | Some def -> - let approx = R.approx r in - let def, r = simplify env r def in - Some def, - R.meet_approx r env approx - in - String_switch (arg, sw, def, kind), ret r (A.value_unknown Other) - | Some arg_string -> - let branch = - match List.find (fun (str, _) -> String.equal str arg_string) sw with - | (_, branch) -> branch - | exception Not_found -> - match def with - | None -> - Flambda.Proved_unreachable - | Some def -> - def - in - let branch, r = simplify env r branch in - branch, R.map_benefit r B.remove_branch) - | Region (Exclave body) -> - simplify env r body - | Region body -> - let r = R.enter_region r in - let body, r = simplify env r body in - let use_inner_region = R.may_use_region r in - let has_exclave = R.region_has_exclave r in - let r = R.leave_region r in - if use_inner_region then Region body, r - else if has_exclave then remove_exclaves body, r else body, r - | Exclave body -> - let exclave, r = R.enter_exclave r in - let body, r = simplify env r body in - let r = R.leave_exclave r exclave in - Exclave body, r - | Proved_unreachable -> tree, ret r A.value_bottom - -and simplify_list env r l = - match l with - | [] -> [], [], r - | h::t -> - let t', approxs, r = simplify_list env r t in - let h', r = simplify env r h in - let approxs = (R.approx r) :: approxs in - if t' == t && h' == h - then l, approxs, r - else h' :: t', approxs, r - -and duplicate_function ~env ~(set_of_closures : Flambda.set_of_closures) - ~fun_var ~new_fun_var = - let function_decl = - match Variable.Map.find fun_var set_of_closures.function_decls.funs with - | exception Not_found -> - Misc.fatal_errorf "duplicate_function: cannot find function %a" - Variable.print fun_var - | function_decl -> function_decl - in - let env = E.activate_freshening (E.set_never_inline env) in - let free_vars, specialised_args, function_decls, parameter_approximations, - _internal_value_set_of_closures, set_of_closures_env = - Inline_and_simplify_aux.prepare_to_simplify_set_of_closures ~env - ~set_of_closures ~function_decls:set_of_closures.function_decls - ~freshen:false ~only_for_function_decl:(Some function_decl) - in - let function_decl = - match Variable.Map.find fun_var function_decls.funs with - | exception Not_found -> - Misc.fatal_errorf "duplicate_function: cannot find function %a (2)" - Variable.print fun_var - | function_decl -> function_decl - in - let closure_env = - Inline_and_simplify_aux.prepare_to_simplify_closure ~function_decl - ~free_vars ~specialised_args ~parameter_approximations - ~set_of_closures_env - in - let body, _r = - E.enter_closure closure_env - ~closure_id:(Closure_id.wrap fun_var) - ~inline_inside:false - ~dbg:function_decl.dbg - ~f:(fun body_env -> - assert (E.inside_set_of_closures_declaration - function_decls.set_of_closures_origin body_env); - simplify body_env (R.create ()) function_decl.body) - in - let function_decl = - Flambda.create_function_declaration - ~params:function_decl.params - ~return_layout:function_decl.return_layout - ~alloc_mode:function_decl.alloc_mode ~region:function_decl.region - ~body ~stub:function_decl.stub - ~inline:function_decl.inline ~specialise:function_decl.specialise - ~check:function_decl.check - ~is_a_functor:function_decl.is_a_functor - ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var)) - ~poll:function_decl.poll - in - function_decl, specialised_args - -let constant_defining_value_approx - env - (constant_defining_value:Flambda.constant_defining_value) = - match constant_defining_value with - | Allocated_const const -> - approx_for_allocated_const const - | Block (tag, fields) -> - let fields = - List.map - (function - | Flambda.Symbol sym -> begin - match E.find_symbol_opt env sym with - | Some approx -> approx - | None -> A.value_unresolved (Symbol sym) - end - | Flambda.Const cst -> simplify_const cst) - fields - in - A.value_block tag (Array.of_list fields) - | Set_of_closures { function_decls; free_vars; specialised_args } -> - (* At toplevel, there is no freshening currently happening (this - cannot be the body of a currently inlined function), so we can - keep the original set_of_closures in the approximation. *) - assert(Freshening.is_empty (E.freshening env)); - assert(Variable.Map.is_empty free_vars); - assert(Variable.Map.is_empty specialised_args); - let invariant_params = - lazy (Invariant_params.invariant_params_in_recursion function_decls) - in - let recursive = - lazy (Find_recursive_functions.in_function_declarations function_decls) - in - let value_set_of_closures = - let keep_body = - Inline_and_simplify_aux.keep_body_check - ~is_classic_mode:function_decls.is_classic_mode ~recursive - in - let function_decls = - A.function_declarations_approx ~keep_body function_decls - in - A.create_value_set_of_closures ~function_decls - ~bound_vars:Var_within_closure.Map.empty - ~invariant_params - ~recursive - ~specialised_args:Variable.Map.empty - ~free_vars:Variable.Map.empty - ~freshening:Freshening.Project_var.empty - ~direct_call_surrogates:Closure_id.Map.empty - in - A.value_set_of_closures value_set_of_closures - | Project_closure (set_of_closures_symbol, closure_id) -> begin - match E.find_symbol_opt env set_of_closures_symbol with - | None -> - A.value_unresolved (Symbol set_of_closures_symbol) - | Some set_of_closures_approx -> - let checked_approx = - A.check_approx_for_set_of_closures set_of_closures_approx - in - match checked_approx with - | Ok (_, value_set_of_closures) -> - let closure_id = - A.freshen_and_check_closure_id value_set_of_closures closure_id - in - A.value_closure value_set_of_closures closure_id - | Unresolved sym -> A.value_unresolved sym - | Unknown -> A.value_unknown Other - | Unknown_because_of_unresolved_value value -> - A.value_unknown (Unresolved_value value) - | Wrong -> - Misc.fatal_errorf "Wrong approximation for [Project_closure] \ - when being used as a [constant_defining_value]: %a" - Flambda.print_constant_defining_value constant_defining_value - end - -(* See documentation on [Let_rec_symbol] in flambda.mli. *) -let define_let_rec_symbol_approx orig_env defs = - (* First declare an empty version of the symbols *) - let init_env = - List.fold_left (fun building_env (symbol, _) -> - E.add_symbol building_env symbol (A.value_unresolved (Symbol symbol))) - orig_env defs - in - let rec loop times lookup_env = - if times <= 0 then - lookup_env - else - let env = - List.fold_left (fun building_env (symbol, constant_defining_value) -> - let approx = - constant_defining_value_approx lookup_env constant_defining_value - in - let approx = A.augment_with_symbol approx symbol in - E.add_symbol building_env symbol approx) - orig_env defs - in - loop (times-1) env - in - loop 2 init_env - -let simplify_constant_defining_value - env r symbol - (constant_defining_value:Flambda.constant_defining_value) = - let r, constant_defining_value, approx = - match constant_defining_value with - (* No simplifications are possible for [Allocated_const] or [Block]. *) - | Allocated_const const -> - r, constant_defining_value, approx_for_allocated_const const - | Block (tag, fields) -> - let fields = List.map - (function - | Flambda.Symbol sym -> E.find_symbol_exn env sym - | Flambda.Const cst -> simplify_const cst) - fields - in - r, constant_defining_value, A.value_block tag (Array.of_list fields) - | Set_of_closures set_of_closures -> - if Variable.Map.cardinal set_of_closures.free_vars <> 0 then begin - Misc.fatal_errorf "Set of closures bound by [Let_symbol] is not \ - closed: %a" - Flambda.print_set_of_closures set_of_closures - end; - let set_of_closures, r, _freshening = - simplify_set_of_closures env r set_of_closures - in - r, ((Set_of_closures set_of_closures) : Flambda.constant_defining_value), - R.approx r - | Project_closure (set_of_closures_symbol, closure_id) -> - (* No simplifications are necessary here. *) - let set_of_closures_approx = - E.find_symbol_exn env set_of_closures_symbol - in - let closure_approx = - match A.check_approx_for_set_of_closures set_of_closures_approx with - | Ok (_, value_set_of_closures) -> - let closure_id = - A.freshen_and_check_closure_id value_set_of_closures closure_id - in - A.value_closure value_set_of_closures closure_id - | Unresolved sym -> A.value_unresolved sym - | Unknown -> A.value_unknown Other - | Unknown_because_of_unresolved_value value -> - A.value_unknown (Unresolved_value value) - | Wrong -> - Misc.fatal_errorf "Wrong approximation for [Project_closure] \ - when being used as a [constant_defining_value]: %a" - Flambda.print_constant_defining_value constant_defining_value - in - r, constant_defining_value, closure_approx - in - let approx = A.augment_with_symbol approx symbol in - let r = ret r approx in - r, constant_defining_value, approx - -let rec simplify_program_body env r (program : Flambda.program_body) - : Flambda.program_body * R.t = - match program with - | Let_rec_symbol (defs, program) -> - let set_of_closures_defs, other_defs = - List.partition - (function - | (_, Flambda.Set_of_closures _) -> true - | _ -> false) - defs in - let process_defs ~lookup_env ~env r defs = - List.fold_left (fun (building_env, r, defs) (symbol, def) -> - let r, def, approx = - simplify_constant_defining_value lookup_env r symbol def - in - let approx = A.augment_with_symbol approx symbol in - let building_env = E.add_symbol building_env symbol approx in - (building_env, r, (symbol, def) :: defs)) - (env, r, []) defs - in - let env, r, set_of_closures_defs = - let lookup_env = define_let_rec_symbol_approx env defs in - process_defs ~lookup_env ~env r set_of_closures_defs - in - let env, r, other_defs = - let lookup_env = define_let_rec_symbol_approx env other_defs in - process_defs ~lookup_env ~env r other_defs - in - let program, r = simplify_program_body env r program in - Let_rec_symbol (set_of_closures_defs @ other_defs, program), r - | Let_symbol (symbol, constant_defining_value, program) -> - let r, constant_defining_value, approx = - simplify_constant_defining_value env r symbol constant_defining_value - in - let approx = A.augment_with_symbol approx symbol in - let env = E.add_symbol env symbol approx in - let program, r = simplify_program_body env r program in - Let_symbol (symbol, constant_defining_value, program), r - | Initialize_symbol (symbol, tag, fields, program) -> - let fields, approxs, r = simplify_list env r fields in - let approx = - A.augment_with_symbol (A.value_block tag (Array.of_list approxs)) symbol - in - let env = E.add_symbol env symbol approx in - let program, r = simplify_program_body env r program in - Initialize_symbol (symbol, tag, fields, program), r - | Effect (expr, program) -> - let expr, r = simplify env r expr in - let program, r = simplify_program_body env r program in - Effect (expr, program), r - | End root -> End root, r - -let simplify_program env r (program : Flambda.program) = - let env, r = - Symbol.Set.fold (fun symbol (env, r) -> - let env, approx = - match E.find_symbol_exn env symbol with - | exception Not_found -> - let module Backend = (val (E.backend env) : Backend_intf.S) in - (* CR-someday mshinwell for mshinwell: Is there a reason we cannot - use [simplify_named_using_approx_and_env] here? *) - let approx = Backend.import_symbol symbol in - E.add_symbol env symbol approx, approx - | approx -> env, approx - in - env, ret r approx) - program.imported_symbols - (env, r) - in - let program_body, r = simplify_program_body env r program.program_body in - let program = { program with program_body; } in - program, r - -let add_predef_exns_to_environment ~env = - List.fold_left (fun env predef_exn -> - assert (Ident.is_predef predef_exn); - let symbol = Symbol.for_predef_ident predef_exn in - let name = Ident.name predef_exn in - let approx = - A.value_block Tag.object_tag - [| A.value_string (String.length name) (Some name); - A.value_unknown Other; - |] - in - E.add_symbol env symbol (A.augment_with_symbol approx symbol)) - env - Predef.all_predef_exns - -let run ~never_inline ~backend ~prefixname ~round ~ppf_dump program = - let r = R.create () in - let report = !Clflags.inlining_report in - if never_inline then Clflags.inlining_report := false; - let initial_env = - add_predef_exns_to_environment - ~env:(E.create ~never_inline ~backend ~round ~ppf_dump) - in - let result, r = simplify_program initial_env r program in - let result = Flambda_utils.introduce_needed_import_symbols result in - if not (Static_exception.Set.is_empty (R.used_static_exceptions r)) - then begin - Misc.fatal_error (Format.asprintf "Remaining static exceptions: %a@.%a@." - Static_exception.Set.print (R.used_static_exceptions r) - Flambda.print_program result) - end; - assert (Static_exception.Set.is_empty (R.used_static_exceptions r)); - if !Clflags.inlining_report then begin - let output_prefix = Printf.sprintf "%s.%d" prefixname round in - Inlining_stats.save_then_forget_decisions ~output_prefix - end; - Clflags.inlining_report := report; - result diff --git a/middle_end/flambda/inline_and_simplify.mli b/middle_end/flambda/inline_and_simplify.mli deleted file mode 100644 index 9a8e6e8b46c..00000000000 --- a/middle_end/flambda/inline_and_simplify.mli +++ /dev/null @@ -1,40 +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"] - -(** Simplification of Flambda programs combined with function inlining: - for the most part a beta-reduction pass. - - Readers interested in the inlining strategy should read the - [Inlining_decision] module first. -*) -val run - : never_inline:bool - -> backend:(module Backend_intf.S) - -> prefixname:string - -> round:int - -> ppf_dump:Format.formatter - -> Flambda.program - -> Flambda.program - -val duplicate_function - : env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> fun_var:Variable.t - -> new_fun_var:Variable.t - -> Flambda.function_declaration - * Flambda.specialised_to Variable.Map.t (* new specialised arguments *) diff --git a/middle_end/flambda/inline_and_simplify_aux.ml b/middle_end/flambda/inline_and_simplify_aux.ml deleted file mode 100644 index c3834732668..00000000000 --- a/middle_end/flambda/inline_and_simplify_aux.ml +++ /dev/null @@ -1,794 +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-66"] -open! Int_replace_polymorphic_compare -module Int = Misc.Stdlib.Int - -module Env = struct - type scope = Current | Outer - - type t = { - backend : (module Backend_intf.S); - round : int; - ppf_dump : Format.formatter; - approx : (scope * Simple_value_approx.t) Variable.Map.t; - approx_mutable : Simple_value_approx.t Mutable_variable.Map.t; - approx_sym : Simple_value_approx.t Symbol.Map.t; - projections : Variable.t Projection.Map.t; - current_functions : Set_of_closures_origin.Set.t; - (* The functions currently being declared: used to avoid inlining - recursively *) - inlining_level : int; - (* Number of times "inline" has been called recursively *) - inside_branch : int; - freshening : Freshening.t; - never_inline : bool ; - never_inline_inside_closures : bool; - never_inline_outside_closures : bool; - unroll_counts : int Set_of_closures_origin.Map.t; - inlining_counts : int Closure_origin.Map.t; - actively_unrolling : int Set_of_closures_origin.Map.t; - closure_depth : int; - inlining_stats_closure_stack : Inlining_stats.Closure_stack.t; - inlined_debuginfo : Debuginfo.t; - } - - let create ~never_inline ~backend ~round ~ppf_dump = - { backend; - round; - ppf_dump; - approx = Variable.Map.empty; - approx_mutable = Mutable_variable.Map.empty; - approx_sym = Symbol.Map.empty; - projections = Projection.Map.empty; - current_functions = Set_of_closures_origin.Set.empty; - inlining_level = 0; - inside_branch = 0; - freshening = Freshening.empty; - never_inline; - never_inline_inside_closures = false; - never_inline_outside_closures = false; - unroll_counts = Set_of_closures_origin.Map.empty; - inlining_counts = Closure_origin.Map.empty; - actively_unrolling = Set_of_closures_origin.Map.empty; - closure_depth = 0; - inlining_stats_closure_stack = - Inlining_stats.Closure_stack.create (); - inlined_debuginfo = Debuginfo.none; - } - - let backend t = t.backend - let round t = t.round - let ppf_dump t = t.ppf_dump - - let local env = - { env with - approx = Variable.Map.empty; - projections = Projection.Map.empty; - freshening = Freshening.empty_preserving_activation_state env.freshening; - inlined_debuginfo = Debuginfo.none; - } - - let inlining_level_up env = - let max_level = - Clflags.Int_arg_helper.get ~key:(env.round) !Clflags.inline_max_depth - in - if (env.inlining_level + 1) > max_level then - Misc.fatal_error "Inlining level increased above maximum"; - { env with inlining_level = env.inlining_level + 1 } - - let print ppf t = - Format.fprintf ppf - "Environment maps: %a@.Projections: %a@.Freshening: %a@." - Variable.Set.print (Variable.Map.keys t.approx) - (Projection.Map.print Variable.print) t.projections - Freshening.print t.freshening - - let mem t var = Variable.Map.mem var t.approx - - let add_internal t var (approx : Simple_value_approx.t) ~scope = - let approx = - (* The semantics of this [match] are what preserve the property - described at the top of simple_value_approx.mli, namely that when a - [var] is mem on an approximation (amongst many possible [var]s), - it is the one with the outermost scope. *) - match approx.var with - | Some var when mem t var -> approx - | _ -> Simple_value_approx.augment_with_variable approx var - in - { t with approx = Variable.Map.add var (scope, approx) t.approx } - - let add t var approx = add_internal t var approx ~scope:Current - let add_outer_scope t var approx = add_internal t var approx ~scope:Outer - - let add_mutable t mut_var approx = - { t with approx_mutable = - Mutable_variable.Map.add mut_var approx t.approx_mutable; - } - - let really_import_approx t = - let module Backend = (val (t.backend) : Backend_intf.S) in - Backend.really_import_approx - - let really_import_approx_with_scope t (scope, approx) = - scope, really_import_approx t approx - - let find_symbol_exn t symbol = - really_import_approx t - (Symbol.Map.find symbol t.approx_sym) - - let find_symbol_opt t symbol = - try Some (really_import_approx t - (Symbol.Map.find symbol t.approx_sym)) - with Not_found -> None - - let find_symbol_fatal t symbol = - match find_symbol_exn t symbol with - | exception Not_found -> - Misc.fatal_errorf "Symbol %a is unbound. Maybe there is a missing \ - [Let_symbol], [Import_symbol] or similar?" - Symbol.print symbol - | approx -> approx - - let find_or_load_symbol t symbol = - match find_symbol_exn t symbol with - | exception Not_found -> - if Compilation_unit.equal - (Compilation_unit.get_current_exn ()) - (Symbol.compilation_unit symbol) - then - Misc.fatal_errorf "Symbol %a from the current compilation unit is \ - unbound. Maybe there is a missing [Let_symbol] or similar?" - Symbol.print symbol; - let module Backend = (val (t.backend) : Backend_intf.S) in - Backend.import_symbol symbol - | approx -> approx - - let add_projection t ~projection ~bound_to = - { t with - projections = - Projection.Map.add projection bound_to t.projections; - } - - let find_projection t ~projection = - match Projection.Map.find projection t.projections with - | exception Not_found -> None - | var -> Some var - - let does_not_bind t vars = - not (List.exists (mem t) vars) - - let does_not_freshen t vars = - Freshening.does_not_freshen t.freshening vars - - let add_symbol t symbol approx = - match find_symbol_exn t symbol with - | exception Not_found -> - { t with - approx_sym = Symbol.Map.add symbol approx t.approx_sym; - } - | _ -> - Misc.fatal_errorf "Attempt to redefine symbol %a (to %a) in environment \ - for [Inline_and_simplify]" - Symbol.print symbol - Simple_value_approx.print approx - - let redefine_symbol t symbol approx = - match find_symbol_exn t symbol with - | exception Not_found -> - assert false - | _ -> - { t with - approx_sym = Symbol.Map.add symbol approx t.approx_sym; - } - - let find_with_scope_exn t id = - try - really_import_approx_with_scope t - (Variable.Map.find id t.approx) - with Not_found -> - Misc.fatal_errorf "Env.find_with_scope_exn: Unbound variable \ - %a@.%s@. Environment: %a@." - Variable.print id - (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int)) - print t - - let find_exn t id = - snd (find_with_scope_exn t id) - - let find_mutable_exn t mut_var = - try Mutable_variable.Map.find mut_var t.approx_mutable - with Not_found -> - Misc.fatal_errorf "Env.find_mutable_exn: Unbound variable \ - %a@.%s@. Environment: %a@." - Mutable_variable.print mut_var - (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int)) - print t - - let find_list_exn t vars = - List.map (fun var -> find_exn t var) vars - - let find_opt t id = - try Some (really_import_approx t - (snd (Variable.Map.find id t.approx))) - with Not_found -> None - - let activate_freshening t = - { t with freshening = Freshening.activate t.freshening } - - let enter_set_of_closures_declaration t origin = - { t with - current_functions = - Set_of_closures_origin.Set.add origin t.current_functions; } - - let inside_set_of_closures_declaration origin t = - Set_of_closures_origin.Set.mem origin t.current_functions - - let at_toplevel t = - t.closure_depth = 0 - - let is_inside_branch env = env.inside_branch > 0 - - let branch_depth env = env.inside_branch - - let inside_branch t = - { t with inside_branch = t.inside_branch + 1 } - - let set_freshening t freshening = - { t with freshening; } - - let increase_closure_depth t = - let approx = - Variable.Map.map (fun (_scope, approx) -> Outer, approx) t.approx - in - { t with - approx; - closure_depth = t.closure_depth + 1; - } - - let set_never_inline t = - if t.never_inline then t - else { t with never_inline = true } - - let set_never_inline_inside_closures t = - if t.never_inline_inside_closures then t - else { t with never_inline_inside_closures = true } - - let unset_never_inline_inside_closures t = - if t.never_inline_inside_closures then - { t with never_inline_inside_closures = false } - else t - - let set_never_inline_outside_closures t = - if t.never_inline_outside_closures then t - else { t with never_inline_outside_closures = true } - - let unset_never_inline_outside_closures t = - if t.never_inline_outside_closures then - { t with never_inline_outside_closures = false } - else t - - let actively_unrolling t origin = - match Set_of_closures_origin.Map.find origin t.actively_unrolling with - | count -> Some count - | exception Not_found -> None - - let start_actively_unrolling t origin i = - let actively_unrolling = - Set_of_closures_origin.Map.add origin i t.actively_unrolling - in - { t with actively_unrolling } - - let continue_actively_unrolling t origin = - let unrolling = - try - Set_of_closures_origin.Map.find origin t.actively_unrolling - with Not_found -> - Misc.fatal_error "Unexpected actively unrolled function" - in - let actively_unrolling = - Set_of_closures_origin.Map.add origin (unrolling - 1) t.actively_unrolling - in - { t with actively_unrolling } - - let unrolling_allowed t origin = - let unroll_count = - try - Set_of_closures_origin.Map.find origin t.unroll_counts - with Not_found -> - Clflags.Int_arg_helper.get - ~key:t.round !Clflags.inline_max_unroll - in - unroll_count > 0 - - let inside_unrolled_function t origin = - let unroll_count = - try - Set_of_closures_origin.Map.find origin t.unroll_counts - with Not_found -> - Clflags.Int_arg_helper.get - ~key:t.round !Clflags.inline_max_unroll - in - let unroll_counts = - Set_of_closures_origin.Map.add - origin (unroll_count - 1) t.unroll_counts - in - { t with unroll_counts } - - let inlining_allowed t id = - let inlining_count = - try - Closure_origin.Map.find id t.inlining_counts - with Not_found -> - Int.max 1 (Clflags.Int_arg_helper.get - ~key:t.round !Clflags.inline_max_unroll) - in - inlining_count > 0 - - let inside_inlined_function t id = - let inlining_count = - try - Closure_origin.Map.find id t.inlining_counts - with Not_found -> - Int.max 1 (Clflags.Int_arg_helper.get - ~key:t.round !Clflags.inline_max_unroll) - in - let inlining_counts = - Closure_origin.Map.add id (inlining_count - 1) t.inlining_counts - in - { t with inlining_counts } - - let inlining_level t = t.inlining_level - let freshening t = t.freshening - let never_inline t = t.never_inline || t.never_inline_outside_closures - - let note_entering_closure t ~closure_id ~dbg = - if t.never_inline then t - else - { t with - inlining_stats_closure_stack = - Inlining_stats.Closure_stack.note_entering_closure - t.inlining_stats_closure_stack ~closure_id ~dbg; - } - - let note_entering_call t ~closure_id ~dbg = - if t.never_inline then t - else - { t with - inlining_stats_closure_stack = - Inlining_stats.Closure_stack.note_entering_call - t.inlining_stats_closure_stack ~closure_id ~dbg; - } - - let note_entering_inlined t = - if t.never_inline then t - else - { t with - inlining_stats_closure_stack = - Inlining_stats.Closure_stack.note_entering_inlined - t.inlining_stats_closure_stack; - } - - let note_entering_specialised t ~closure_ids = - if t.never_inline then t - else - { t with - inlining_stats_closure_stack = - Inlining_stats.Closure_stack.note_entering_specialised - t.inlining_stats_closure_stack ~closure_ids; - } - - let enter_closure t ~closure_id ~inline_inside ~dbg ~f = - let t = - if inline_inside && not t.never_inline_inside_closures then t - else set_never_inline t - in - let t = unset_never_inline_outside_closures t in - f (note_entering_closure t ~closure_id ~dbg) - - let record_decision t decision = - Inlining_stats.record_decision decision - ~closure_stack:t.inlining_stats_closure_stack - - let set_inline_debuginfo t ~dbg = - { t with inlined_debuginfo = dbg } - - let add_inlined_debuginfo t ~dbg = - Debuginfo.inline t.inlined_debuginfo dbg -end - -let initial_inlining_threshold ~round : Inlining_cost.Threshold.t = - let unscaled = - Clflags.Float_arg_helper.get ~key:round !Clflags.inline_threshold - in - (* CR-soon pchambart: Add a warning if this is too big - mshinwell: later *) - Can_inline_if_no_larger_than - (int_of_float - (unscaled *. float_of_int Inlining_cost.scale_inline_threshold_by)) - -let initial_inlining_toplevel_threshold ~round : Inlining_cost.Threshold.t = - let ordinary_threshold = - Clflags.Float_arg_helper.get ~key:round !Clflags.inline_threshold - in - let toplevel_threshold = - Clflags.Int_arg_helper.get ~key:round !Clflags.inline_toplevel_threshold - in - let unscaled = - (int_of_float ordinary_threshold) + toplevel_threshold - in - (* CR-soon pchambart: Add a warning if this is too big - mshinwell: later *) - Can_inline_if_no_larger_than - (unscaled * Inlining_cost.scale_inline_threshold_by) - -module Result = struct - type region = { may_be_used : bool; has_exclave : bool } - - type t = - { approx : Simple_value_approx.t; - used_static_exceptions : Static_exception.Set.t; - inlining_threshold : Inlining_cost.Threshold.t option; - benefit : Inlining_cost.Benefit.t; - num_direct_applications : int; - regions : region list; - } - - let create_region () = { may_be_used = false; has_exclave = false } - - let create () = - { approx = Simple_value_approx.value_unknown Other; - used_static_exceptions = Static_exception.Set.empty; - inlining_threshold = None; - benefit = Inlining_cost.Benefit.zero; - num_direct_applications = 0; - regions = [ ]; - } - - let approx t = t.approx - let set_approx t approx = { t with approx } - - let meet_approx t env approx = - let really_import_approx = Env.really_import_approx env in - let meet = - Simple_value_approx.meet ~really_import_approx t.approx approx - in - set_approx t meet - - let use_static_exception t i = - { t with - used_static_exceptions = - Static_exception.Set.add i t.used_static_exceptions; - } - - let used_static_exceptions t = t.used_static_exceptions - - let no_current_region () = - Misc.fatal_error "No current region" - - let enter_region t = - { t with regions = create_region () :: t.regions } - - let leave_region t = - match t.regions with - | _region :: regions -> { t with regions } - | [] -> no_current_region () - - let set_region_used t = - match t.regions with - | region :: regions -> - { t with regions = { region with may_be_used = true } :: regions } - | [] -> - (* By rights this should be a fatal error, but currently - [Semantics_of_primitives.may_locally_allocate] has too many false - positives (including ccalls). *) - t - - let set_region_has_exclave t = - match t.regions with - | region :: regions -> - { t with regions = { region with has_exclave = true } :: regions } - | [] -> no_current_region () - - type exclave = { from_region : region } - - let enter_exclave t = - match t.regions with - | region :: regions -> - let region = { region with has_exclave = true } in - let exclave = { from_region = region } in - exclave, { t with regions = regions } - | [] -> no_current_region () - - let leave_exclave t { from_region } = - { t with regions = from_region :: t.regions } - - let current_region t = - match t.regions with - | region :: _ -> region - | [] -> no_current_region () - - let may_use_region t = - (current_region t).may_be_used - - let region_has_exclave t = - (current_region t).has_exclave - - let exit_scope_catch t i = - { t with - used_static_exceptions = - Static_exception.Set.remove i t.used_static_exceptions; - } - - let map_benefit t f = - { t with benefit = f t.benefit } - - let add_benefit t b = - { t with benefit = Inlining_cost.Benefit.(+) t.benefit b } - - let benefit t = t.benefit - - let reset_benefit t = - { t with benefit = Inlining_cost.Benefit.zero; } - - let set_inlining_threshold t inlining_threshold = - { t with inlining_threshold } - - let add_inlining_threshold t j = - match t.inlining_threshold with - | None -> t - | Some i -> - let inlining_threshold = Some (Inlining_cost.Threshold.add i j) in - { t with inlining_threshold } - - let sub_inlining_threshold t j = - match t.inlining_threshold with - | None -> t - | Some i -> - let inlining_threshold = Some (Inlining_cost.Threshold.sub i j) in - { t with inlining_threshold } - - let inlining_threshold t = t.inlining_threshold - - let seen_direct_application t = - { t with num_direct_applications = t.num_direct_applications + 1; } - - let num_direct_applications t = - t.num_direct_applications -end - -module A = Simple_value_approx -module E = Env - -let keep_body_check ~is_classic_mode ~recursive = - if not is_classic_mode then begin - fun _ _ -> true - end else begin - let can_inline_non_rec_function (fun_decl : Flambda.function_declaration) = - (* In classic-inlining mode, the inlining decision is taken at - definition site (here). If the function is small enough - (below the -inline threshold) it will always be inlined. - - Closure gives a bonus of [8] to optional arguments. In classic - mode, however, we would inline functions with the "*opt*" argument - in all cases, as it is a stub. (This is ensured by - [middle_end/closure_conversion.ml]). - *) - let inlining_threshold = initial_inlining_threshold ~round:0 in - let bonus = Flambda_utils.function_arity fun_decl in - Inlining_cost.can_inline fun_decl.body inlining_threshold ~bonus - in - fun (var : Variable.t) (fun_decl : Flambda.function_declaration) -> - if fun_decl.stub then begin - true - end else if Variable.Set.mem var (Lazy.force recursive) then begin - false - end else begin - match fun_decl.inline with - | Default_inline -> can_inline_non_rec_function fun_decl - | Unroll factor -> factor > 0 - | Always_inline | Available_inline -> true - | Never_inline -> false - end - end - -let prepare_to_simplify_set_of_closures ~env - ~(set_of_closures : Flambda.set_of_closures) - ~function_decls ~freshen - ~(only_for_function_decl : Flambda.function_declaration option) = - let free_vars = - Variable.Map.map (fun (external_var : Flambda.specialised_to) -> - let var = - let var = - Freshening.apply_variable (E.freshening env) external_var.var - in - match - A.simplify_var_to_var_using_env (E.find_exn env var) - ~is_present_in_env:(fun var -> E.mem env var) - with - | None -> var - | Some var -> var - in - let approx = E.find_exn env var in - (* The projections are freshened below in one step, once we know - the closure freshening substitution. *) - ({ external_var with var } : Flambda.specialised_to), approx) - set_of_closures.free_vars - in - let specialised_args = - set_of_closures.specialised_args |> Variable.Map.filter_map - (fun param (spec_to : Flambda.specialised_to) -> - let keep = - match only_for_function_decl with - | None -> true - | Some function_decl -> - Variable.Set.mem param (Parameter.Set.vars function_decl.params) - in - if not keep then None - else - let external_var = spec_to.var in - let var = - Freshening.apply_variable (E.freshening env) external_var - in - let var = - match - A.simplify_var_to_var_using_env (E.find_exn env var) - ~is_present_in_env:(fun var -> E.mem env var) - with - | None -> var - | Some var -> var - in - Some ({ spec_to with var } : Flambda.specialised_to)) - in - let environment_before_cleaning = env in - (* [E.local] helps us to catch bugs whereby variables escape their scope. *) - let env = E.local env in - let free_vars, function_decls, sb, freshening = - Freshening.apply_function_decls_and_free_vars (E.freshening env) free_vars - function_decls ~only_freshen_parameters:(not freshen) - in - let env = E.set_freshening env sb in - let free_vars = - Freshening.freshen_projection_relation' free_vars - ~freshening:(E.freshening env) - ~closure_freshening:freshening - in - let specialised_args = - let specialised_args = - Variable.Map.map_keys (Freshening.apply_variable (E.freshening env)) - specialised_args - in - Freshening.freshen_projection_relation specialised_args - ~freshening:(E.freshening env) - ~closure_freshening:freshening - in - let parameter_approximations = - (* Approximations of parameters that are known to always hold the same - argument throughout the body of the function. *) - Variable.Map.map_keys (Freshening.apply_variable (E.freshening env)) - (Variable.Map.mapi (fun _id' (spec_to : Flambda.specialised_to) -> - E.find_exn environment_before_cleaning spec_to.var) - specialised_args) - in - let direct_call_surrogates = - Variable.Map.fold (fun existing surrogate surrogates -> - let existing = - Freshening.Project_var.apply_closure_id freshening - (Closure_id.wrap existing) - in - let surrogate = - Freshening.Project_var.apply_closure_id freshening - (Closure_id.wrap surrogate) - in - assert (not (Closure_id.Map.mem existing surrogates)); - Closure_id.Map.add existing surrogate surrogates) - set_of_closures.direct_call_surrogates - Closure_id.Map.empty - in - let env = - E.enter_set_of_closures_declaration env - function_decls.set_of_closures_origin - in - (* we use the previous closure for evaluating the functions *) - let internal_value_set_of_closures = - let bound_vars = - Variable.Map.fold (fun id (_, desc) map -> - Var_within_closure.Map.add (Var_within_closure.wrap id) desc map) - free_vars Var_within_closure.Map.empty - in - let free_vars = Variable.Map.map fst free_vars in - let invariant_params = lazy Variable.Map.empty in - let recursive = lazy (Variable.Map.keys function_decls.funs) in - let is_classic_mode = function_decls.is_classic_mode in - let keep_body = keep_body_check ~is_classic_mode ~recursive in - let function_decls = - A.function_declarations_approx ~keep_body function_decls - in - A.create_value_set_of_closures ~function_decls ~bound_vars - ~free_vars ~invariant_params ~recursive ~specialised_args - ~freshening ~direct_call_surrogates - in - (* Populate the environment with the approximation of each closure. - This part of the environment is shared between all of the closures in - the set of closures. *) - let set_of_closures_env = - Variable.Map.fold (fun closure _ env -> - let approx = - A.value_closure ~closure_var:closure internal_value_set_of_closures - (Closure_id.wrap closure) - in - E.add env closure approx - ) - function_decls.funs env - in - free_vars, specialised_args, function_decls, parameter_approximations, - internal_value_set_of_closures, set_of_closures_env - -(* This adds only the minimal set of approximations to the closures. - It is not strictly necessary to have this restriction, but it helps - to catch potential substitution bugs. *) -let populate_closure_approximations - ~(function_decl : Flambda.function_declaration) - ~(free_vars : (_ * A.t) Variable.Map.t) - ~(parameter_approximations : A.t Variable.Map.t) - ~set_of_closures_env = - (* Add approximations of free variables *) - let env = - Variable.Map.fold (fun id (_, desc) env -> - E.add_outer_scope env id desc) - free_vars set_of_closures_env - in - (* Add known approximations of function parameters *) - let env = - List.fold_left (fun env id -> - let approx = - try Variable.Map.find id parameter_approximations - with Not_found -> (A.value_unknown Other) - in - E.add env id approx) - env (Parameter.List.vars function_decl.params) - in - env - -let prepare_to_simplify_closure ~(function_decl : Flambda.function_declaration) - ~free_vars ~specialised_args ~parameter_approximations - ~set_of_closures_env = - let closure_env = - populate_closure_approximations ~function_decl ~free_vars - ~parameter_approximations ~set_of_closures_env - in - (* Add definitions of known projections to the environment. *) - let add_projections ~closure_env ~which_variables ~map = - Variable.Map.fold (fun inner_var spec_arg env -> - let (spec_arg : Flambda.specialised_to) = map spec_arg in - match spec_arg.projection with - | None -> env - | Some projection -> - let from = Projection.projecting_from projection in - if Variable.Set.mem from function_decl.free_variables then - E.add_projection env ~projection ~bound_to:inner_var - else - env) - which_variables - closure_env - in - let closure_env = - add_projections ~closure_env ~which_variables:specialised_args - ~map:(fun spec_to -> spec_to) - in - add_projections ~closure_env ~which_variables:free_vars - ~map:(fun (spec_to, _approx) -> spec_to) diff --git a/middle_end/flambda/inline_and_simplify_aux.mli b/middle_end/flambda/inline_and_simplify_aux.mli deleted file mode 100644 index 5631e097ced..00000000000 --- a/middle_end/flambda/inline_and_simplify_aux.mli +++ /dev/null @@ -1,400 +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"] - -(** Environments and result structures used during inlining and - simplification. (See inline_and_simplify.ml.) *) - -module Env : sig - (** Environments follow the lexical scopes of the program. *) - type t - - (** Create a new environment. If [never_inline] is true then the returned - environment will prevent [Inline_and_simplify] from inlining. The - [backend] parameter is used for passing information about the compiler - backend being used. - Newly-created environments have inactive [Freshening]s (see below) and do - not initially hold any approximation information. *) - val create - : never_inline:bool - -> backend:(module Backend_intf.S) - -> round:int - -> ppf_dump:Format.formatter - -> t - - (** Obtain the first-class module that gives information about the - compiler backend being used for compilation. *) - val backend : t -> (module Backend_intf.S) - - (** Obtain the really_import_approx function from the backend module. *) - val really_import_approx - : t - -> (Simple_value_approx.t -> Simple_value_approx.t) - - (** Which simplification round we are currently in. *) - val round : t -> int - - (** Where to print intermediate asts and similar debug information *) - val ppf_dump : t -> Format.formatter - - (** Add the approximation of a variable---that is to say, some knowledge - about the value(s) the variable may take on at runtime---to the - environment. *) - val add : t -> Variable.t -> Simple_value_approx.t -> t - - val add_outer_scope : t -> Variable.t -> Simple_value_approx.t -> t - - (** Like [add], but for mutable variables. *) - val add_mutable : t -> Mutable_variable.t -> Simple_value_approx.t -> t - - (** Find the approximation of a given variable, raising a fatal error if - the environment does not know about the variable. Use [find_opt] - instead if you need to catch the failure case. *) - val find_exn : t -> Variable.t -> Simple_value_approx.t - - (** Like [find_exn], but for mutable variables. *) - val find_mutable_exn : t -> Mutable_variable.t -> Simple_value_approx.t - - type scope = Current | Outer - - val find_with_scope_exn : t -> Variable.t -> scope * Simple_value_approx.t - - (** Like [find_exn], but intended for use where the "not present in - environment" case is to be handled by the caller. *) - val find_opt : t -> Variable.t -> Simple_value_approx.t option - - (** Like [find_exn], but for a list of variables. *) - val find_list_exn : t -> Variable.t list -> Simple_value_approx.t list - - val does_not_bind : t -> Variable.t list -> bool - - val does_not_freshen : t -> Variable.t list -> bool - - val add_symbol : t -> Symbol.t -> Simple_value_approx.t -> t - val redefine_symbol : t -> Symbol.t -> Simple_value_approx.t -> t - val find_symbol_exn : t -> Symbol.t -> Simple_value_approx.t - val find_symbol_opt : t -> Symbol.t -> Simple_value_approx.t option - val find_symbol_fatal : t -> Symbol.t -> Simple_value_approx.t - - (* Like [find_symbol_exn], but load the symbol approximation using - the backend if not available in the environment. *) - val find_or_load_symbol : t -> Symbol.t -> Simple_value_approx.t - - (** Note that the given [bound_to] holds the given [projection]. *) - val add_projection - : t - -> projection:Projection.t - -> bound_to:Variable.t - -> t - - (** Determine if the environment knows about a variable that is bound - to the given [projection]. *) - val find_projection - : t - -> projection:Projection.t - -> Variable.t option - - (** Whether the environment has an approximation for the given variable. *) - val mem : t -> Variable.t -> bool - - (** Return the freshening that should be applied to variables when - rewriting code (in [Inline_and_simplify], etc.) using the given - environment. *) - val freshening : t -> Freshening.t - - (** Set the freshening that should be used as per [freshening], above. *) - val set_freshening : t -> Freshening.t -> t - - (** Causes every bound variable in code rewritten during inlining and - simplification, using the given environment, to be freshened. This is - used when descending into subexpressions substituted into existing - expressions. *) - val activate_freshening : t -> t - - (** Erase all variable approximation information and freshening information - from the given environment. However, the freshening activation state - is preserved. This function is used when rewriting inside a function - declaration, to avoid (due to a compiler bug) accidental use of - variables from outer scopes that are not accessible. *) - val local : t -> t - - (** Determine whether the inliner is currently inside a function body from - the given set of closures. This is used to detect whether a given - function call refers to a function which exists somewhere on the current - inlining stack. *) - val inside_set_of_closures_declaration : Set_of_closures_origin.t -> t -> bool - - (** Not inside a closure declaration. - Toplevel code is the one evaluated when the compilation unit is - loaded *) - val at_toplevel : t -> bool - - val is_inside_branch : t -> bool - val branch_depth : t -> int - val inside_branch : t -> t - - val increase_closure_depth : t -> t - - (** Mark that call sites contained within code rewritten using the given - environment should never be replaced by inlined (or unrolled) versions - of the callee(s). *) - val set_never_inline : t -> t - - (** Equivalent to [set_never_inline] but only applies to code inside - a set of closures. *) - val set_never_inline_inside_closures : t -> t - - (** Unset the restriction from [set_never_inline_inside_closures] *) - val unset_never_inline_inside_closures : t -> t - - (** Equivalent to [set_never_inline] but does not apply to code inside - a set of closures. *) - val set_never_inline_outside_closures : t -> t - - (** Unset the restriction from [set_never_inline_outside_closures] *) - val unset_never_inline_outside_closures : t -> t - - (** Return whether [set_never_inline] is currently in effect on the given - environment. *) - val never_inline : t -> bool - - val inlining_level : t -> int - - (** Mark that this environment is used to rewrite code for inlining. This is - used by the inlining heuristics to decide whether to continue. - Unconditionally inlined does not take this into account. *) - val inlining_level_up : t -> t - - (** Whether we are actively unrolling a given function. *) - val actively_unrolling : t -> Set_of_closures_origin.t -> int option - - (** Start actively unrolling a given function [n] times. *) - val start_actively_unrolling : t -> Set_of_closures_origin.t -> int -> t - - (** Unroll a function currently actively being unrolled. *) - val continue_actively_unrolling : t -> Set_of_closures_origin.t -> t - - (** Whether it is permissible to unroll a call to a recursive function - in the given environment. *) - val unrolling_allowed : t -> Set_of_closures_origin.t -> bool - - (** Whether the given environment is currently being used to rewrite the - body of an unrolled recursive function. *) - val inside_unrolled_function : t -> Set_of_closures_origin.t -> t - - (** Whether it is permissible to inline a call to a function in the given - environment. *) - val inlining_allowed : t -> Closure_origin.t -> bool - - (** Whether the given environment is currently being used to rewrite the - body of an inlined function. *) - val inside_inlined_function : t -> Closure_origin.t -> t - - (** If collecting inlining statistics, record that the inliner is about to - descend into [closure_id]. This information enables us to produce a - stack of closures that form a kind of context around an inlining - decision point. *) - val note_entering_closure - : t - -> closure_id:Closure_id.t - -> dbg:Debuginfo.t - -> t - - (** If collecting inlining statistics, record that the inliner is about to - descend into a call to [closure_id]. This information enables us to - produce a stack of closures that form a kind of context around an - inlining decision point. *) - val note_entering_call - : t - -> closure_id:Closure_id.t - -> dbg:Debuginfo.t - -> t - - (** If collecting inlining statistics, record that the inliner is about to - descend into an inlined function call. This requires that the inliner - has already entered the call with [note_entering_call]. *) - val note_entering_inlined : t -> t - - (** If collecting inlining statistics, record that the inliner is about to - descend into a specialised function definition. This requires that the - inliner has already entered the call with [note_entering_call]. *) - val note_entering_specialised : t -> closure_ids:Closure_id.Set.t -> t - - (** Update a given environment to record that the inliner is about to - descend into [closure_id] and pass the resulting environment to [f]. - If [inline_inside] is [false] then the environment passed to [f] will be - marked as [never_inline] (see above). *) - val enter_closure - : t - -> closure_id:Closure_id.t - -> inline_inside:bool - -> dbg:Debuginfo.t - -> f:(t -> 'a) - -> 'a - - (** If collecting inlining statistics, record an inlining decision for the - call at the top of the closure stack stored inside the given - environment. *) - val record_decision - : t - -> Inlining_stats_types.Decision.t - -> unit - - (** Print a human-readable version of the given environment. *) - val print : Format.formatter -> t -> unit - - (** The environment stores the call-site being inlined to produce - precise location information. This function sets the current - call-site being inlined. *) - val set_inline_debuginfo : t -> dbg:Debuginfo.t -> t - - (** Appends the locations of inlined call-sites to the [~dbg] argument *) - val add_inlined_debuginfo : t -> dbg:Debuginfo.t -> Debuginfo.t -end - -module Result : sig - (** Result structures approximately follow the evaluation order of the - program. They are returned by the simplification algorithm acting on - an Flambda subexpression. *) - type t - - val create : unit -> t - - (** The approximation of the subexpression that has just been - simplified. *) - val approx : t -> Simple_value_approx.t - - (** Set the approximation of the subexpression that has just been - simplified. Typically used just before returning from a case of the - simplification algorithm. *) - val set_approx : t -> Simple_value_approx.t -> t - - (** Set the approximation of the subexpression to the meet of the - current return approximation and the provided one. Typically - used just before returning from a branch case of the - simplification algorithm. *) - val meet_approx : t -> Env.t -> Simple_value_approx.t -> t - - (** All static exceptions for which [use_staticfail] has been called on - the given result structure. *) - val used_static_exceptions : t -> Static_exception.Set.t - - (** Mark that the given static exception has been used. *) - val use_static_exception : t -> Static_exception.t -> t - - (** Enter the scope of a region. A subsequent call to [set_region_used] will - affect this region. *) - val enter_region : t -> t - - (** Leave the scope of a region, restoring the previous one as the new - innermost region. *) - val leave_region : t -> t - - type exclave - - (** Enter an exclave. A subsequent call to [set_region_used] will now affect - the outer region. Returns a value that must be passed to the - corresponding [leave_exclave]. *) - val enter_exclave : t -> exclave * t - - (** Leave an exclave, effectively re-entering the outer region. *) - val leave_exclave : t -> exclave -> t - - (** Mark that local allocations may be made in - the nearest enclosing region *) - val set_region_used : t -> t - - (** Whether [set_region_used _] has been called *) - val may_use_region : t -> bool - - (** Mark that the nearest enclosing region has an exclave (either an actual - [exclave] expression or a close-on-apply tail call). *) - val set_region_has_exclave : t -> t - - (** Whether [enter_exclave _] or [set_region_has_exclave] has been called. *) - val region_has_exclave : t -> bool - - (** Mark that we are moving up out of the scope of a static-catch block - that catches the given static exception identifier. This has the effect - of removing the identifier from the [used_staticfail] set. *) - val exit_scope_catch : t -> Static_exception.t -> t - - (** The benefit to be gained by inlining the subexpression whose - simplification yielded the given result structure. *) - val benefit : t -> Inlining_cost.Benefit.t - - (** Apply a transformation to the inlining benefit stored within the - given result structure. *) - val map_benefit - : t - -> (Inlining_cost.Benefit.t -> Inlining_cost.Benefit.t) - -> t - - (** Add some benefit to the inlining benefit stored within the - given result structure. *) - val add_benefit : t -> Inlining_cost.Benefit.t -> t - - (** Set the benefit of inlining the subexpression corresponding to the - given result structure to zero. *) - val reset_benefit : t -> t - - val set_inlining_threshold : - t -> Inlining_cost.Threshold.t option -> t - val add_inlining_threshold : - t -> Inlining_cost.Threshold.t -> t - val sub_inlining_threshold : - t -> Inlining_cost.Threshold.t -> t - val inlining_threshold : t -> Inlining_cost.Threshold.t option - - val seen_direct_application : t -> t - val num_direct_applications : t -> int -end - -(** Command line argument -inline *) -val initial_inlining_threshold : round:int -> Inlining_cost.Threshold.t - -(** Command line argument -inline-toplevel *) -val initial_inlining_toplevel_threshold - : round:int -> Inlining_cost.Threshold.t - -val prepare_to_simplify_set_of_closures - : env:Env.t - -> set_of_closures:Flambda.set_of_closures - -> function_decls:Flambda.function_declarations - -> freshen:bool - -> only_for_function_decl:Flambda.function_declaration option - -> (Flambda.specialised_to * Simple_value_approx.t) Variable.Map.t (* fvs *) - * Flambda.specialised_to Variable.Map.t (* specialised arguments *) - * Flambda.function_declarations - * Simple_value_approx.t Variable.Map.t (* parameter approximations *) - * Simple_value_approx.value_set_of_closures - * Env.t - -val prepare_to_simplify_closure - : function_decl:Flambda.function_declaration - -> free_vars:(Flambda.specialised_to * Simple_value_approx.t) Variable.Map.t - -> specialised_args:Flambda.specialised_to Variable.Map.t - -> parameter_approximations:Simple_value_approx.t Variable.Map.t - -> set_of_closures_env:Env.t - -> Env.t - -val keep_body_check - : is_classic_mode:bool - -> recursive:Variable.Set.t Lazy.t - -> Variable.t - -> Flambda.function_declaration - -> bool diff --git a/middle_end/flambda/inlining_cost.ml b/middle_end/flambda/inlining_cost.ml deleted file mode 100644 index 7957aa41a0c..00000000000 --- a/middle_end/flambda/inlining_cost.ml +++ /dev/null @@ -1,713 +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-66"] -open! Int_replace_polymorphic_compare -module Int = Misc.Stdlib.Int - -(* Simple approximation of the space cost of a primitive. *) - -let prim_size (prim : Clambda_primitives.primitive) args = - match prim with - | Pmakeblock _ -> 5 + List.length args - | Pfield _ -> 1 - | Psetfield (_, isptr, init) -> - begin match init with - | Root_initialization -> 1 (* never causes a write barrier hit *) - | Assignment _ | Heap_initialization -> - match isptr with - | Pointer -> 4 - | Immediate -> 1 - end - | Pfloatfield _ -> 1 - | Psetfloatfield _ -> 1 - | Pduprecord _ -> 10 + List.length args - | Pccall p -> (if p.Primitive.prim_alloc then 10 else 4) + List.length args - | Praise _ -> 4 - | Pstringlength -> 5 - | Pbyteslength -> 5 - | Pstringrefs -> 6 - | Pbytesrefs | Pbytessets -> 6 - | Pmakearray _ -> 5 + List.length args - | Parraylength Pgenarray -> 6 - | Parraylength _ -> 2 - | Parrayrefu (Pgenarray_ref _) -> 12 - | Parrayrefu _ -> 2 - | Parraysetu (Pgenarray_set _) -> 16 - | Parraysetu _ -> 4 - | Parrayrefs (Pgenarray_ref _) -> 18 - | Parrayrefs _ -> 8 - | Parraysets (Pgenarray_set _) -> 22 - | Parraysets _ -> 10 - | Pbigarrayref (_, ndims, _, _) -> 4 + ndims * 6 - | Pbigarrayset (_, ndims, _, _) -> 4 + ndims * 6 - | Psequand | Psequor -> - Misc.fatal_error "Psequand and Psequor are not allowed in Prim \ - expressions; translate out instead (cf. closure_conversion.ml)" - | Pprobe_is_enabled _ -> 4 (* Similar to Pgetglobal and comparison *) - (* CR-soon mshinwell: This match must be made exhaustive. - mshinwell: Let's do this when we have the new size computation. *) - | _ -> 2 (* arithmetic and comparisons *) - -(* Simple approximation of the space cost of an Flambda expression. *) - -(* CR-soon mshinwell: Investigate revised size numbers. *) - -let direct_call_size = 4 -let project_size = 1 - -let lambda_smaller' lam ~than:threshold = - let size = ref 0 in - let rec lambda_size (lam : Flambda.t) = - if !size > threshold then raise Exit; - match lam with - | Var _ -> () - | Apply ({ func = _; args = _; probe = None; kind = direct }) -> - let call_cost = - match direct with Indirect -> 6 | Direct _ -> direct_call_size - in - size := !size + call_cost - | Apply {probe=Some _} -> () - (* Do not affect inlining decision. - Actual cost is either 1, 5 or 6 bytes, depending on their kind. *) - | Assign _ -> incr size - | Send _ -> size := !size + 8 - | Proved_unreachable -> () - | Let { defining_expr; body; _ } -> - lambda_named_size defining_expr; - lambda_size body - | Let_mutable { body } -> lambda_size body - | Let_rec (bindings, body) -> - List.iter (fun (_, lam) -> lambda_named_size lam) bindings; - lambda_size body - | Switch (_, sw) -> - let cost cases = - let size = List.length cases in - if size <= 1 then 0 - else 3 + size - in - size := !size + cost sw.consts + cost sw.blocks; - List.iter (fun (_, lam) -> lambda_size lam) sw.consts; - List.iter (fun (_, lam) -> lambda_size lam) sw.blocks; - Option.iter lambda_size sw.failaction - | String_switch (_, sw, def, _) -> - List.iter (fun (_, lam) -> - size := !size + 2; - lambda_size lam) - sw; - Option.iter lambda_size def - | Static_raise _ -> () - | Static_catch (_, _, body, handler, _) -> - incr size; lambda_size body; lambda_size handler - | Try_with (body, _, handler, _) -> - size := !size + 8; lambda_size body; lambda_size handler - | If_then_else (_, ifso, ifnot, _) -> - size := !size + 2; - lambda_size ifso; lambda_size ifnot - | While (cond, body) -> - size := !size + 2; lambda_size cond; lambda_size body - | For { body; _ } -> - size := !size + 4; lambda_size body - | Region body -> - size := !size + 2; lambda_size body - | Exclave body -> - lambda_size body - and lambda_named_size (named : Flambda.named) = - if !size > threshold then raise Exit; - match named with - | Symbol _ | Read_mutable _ -> () - | Const _ | Allocated_const _ -> incr size - | Read_symbol_field _ -> incr size - | Set_of_closures ({ function_decls = ffuns }) -> - Variable.Map.iter (fun _ (ffun : Flambda.function_declaration) -> - lambda_size ffun.body) - ffuns.funs - | Project_closure _ | Project_var _ -> - size := !size + project_size - | Move_within_set_of_closures _ -> - incr size - | Prim (prim, args, _) -> - size := !size + prim_size prim args - | Expr expr -> lambda_size expr - in - try - lambda_size lam; - if !size <= threshold then Some !size - else None - with Exit -> - None - -let lambda_size lam = - match lambda_smaller' lam ~than:max_int with - | Some size -> - size - | None -> - (* There is no way that an expression of size max_int could fit in - memory. *) - assert false - -module Threshold = struct - - type t = - | Never_inline - | Can_inline_if_no_larger_than of int - - let add t1 t2 = - match t1, t2 with - | Never_inline, t -> t - | t, Never_inline -> t - | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> - Can_inline_if_no_larger_than (i1 + i2) - - let sub t1 t2 = - match t1, t2 with - | Never_inline, _ -> Never_inline - | t, Never_inline -> t - | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> - if i1 > i2 then Can_inline_if_no_larger_than (i1 - i2) - else Never_inline - - let min t1 t2 = - match t1, t2 with - | Never_inline, _ -> Never_inline - | _, Never_inline -> Never_inline - | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> - Can_inline_if_no_larger_than (Int.min i1 i2) - - let equal t1 t2 = - match t1, t2 with - | Never_inline, Never_inline -> true - | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> - i1 = i2 - | (Never_inline | Can_inline_if_no_larger_than _), _ -> - false - -end - -let can_try_inlining lam inlining_threshold ~number_of_arguments - ~size_from_approximation = - match inlining_threshold with - | Threshold.Never_inline -> Threshold.Never_inline - | Threshold.Can_inline_if_no_larger_than inlining_threshold -> - let bonus = - (* removing a call will reduce the size by at least the number - of arguments *) - number_of_arguments - in - let size = - let than = inlining_threshold + bonus in - match size_from_approximation with - | Some size -> if size <= than then Some size else None - | None -> lambda_smaller' lam ~than - in - match size with - | None -> Threshold.Never_inline - | Some size -> - Threshold.Can_inline_if_no_larger_than - (inlining_threshold - size + bonus) - -let lambda_smaller lam ~than = - match lambda_smaller' lam ~than with - | Some _ -> true - | None -> false - -let can_inline lam inlining_threshold ~bonus = - match inlining_threshold with - | Threshold.Never_inline -> false - | Threshold.Can_inline_if_no_larger_than inlining_threshold -> - lambda_smaller - lam - ~than:(inlining_threshold + bonus) - -let cost (flag : Clflags.Int_arg_helper.parsed) ~round = - Clflags.Int_arg_helper.get ~key:round flag - -let benefit_factor = 1 - -module Benefit = struct - type t = { - remove_call : int; - remove_alloc : int; - remove_prim : int; - remove_branch : int; - (* CR-someday pchambart: branch_benefit : t list; *) - direct_call_of_indirect : int; - requested_inline : int; - (* Benefit to compensate the size of functions marked for inlining *) - } - - let zero = { - remove_call = 0; - remove_alloc = 0; - remove_prim = 0; - remove_branch = 0; - direct_call_of_indirect = 0; - requested_inline = 0; - } - - let remove_call t = { t with remove_call = t.remove_call + 1; } - let remove_alloc t = { t with remove_alloc = t.remove_alloc + 1; } - let remove_prim t = { t with remove_prim = t.remove_prim + 1; } - let remove_prims t n = { t with remove_prim = t.remove_prim + n; } - let remove_branch t = { t with remove_branch = t.remove_branch + 1; } - let direct_call_of_indirect t = - { t with direct_call_of_indirect = t.direct_call_of_indirect + 1; } - let requested_inline t ~size_of = - let size = lambda_size size_of in - { t with requested_inline = t.requested_inline + size; } - - let remove_code_helper b (flam : Flambda.t) = - match flam with - | Assign _ -> b := remove_prim !b - | Switch _ | String_switch _ | Static_raise _ | Try_with _ - | If_then_else _ | While _ | For _ -> b := remove_branch !b - | Apply _ | Send _ -> b := remove_call !b - | Let _ | Let_mutable _ | Let_rec _ | Proved_unreachable | Var _ - | Region _ | Exclave _ | Static_catch _ -> () - - let remove_code_helper_named b (named : Flambda.named) = - match named with - | Set_of_closures _ - | Prim ((Pmakearray _ | Pmakeblock _ | Pduprecord _), _, _) -> - b := remove_alloc !b - (* CR-soon pchambart: should we consider that boxed integer and float - operations are allocations ? *) - | Prim _ | Project_closure _ | Project_var _ - | Move_within_set_of_closures _ - | Read_symbol_field _ -> b := remove_prim !b - | Symbol _ | Read_mutable _ | Allocated_const _ | Const _ | Expr _ -> () - - let remove_code lam b = - let b = ref b in - Flambda_iterators.iter_toplevel (remove_code_helper b) - (remove_code_helper_named b) lam; - !b - - let remove_code_named lam b = - let b = ref b in - Flambda_iterators.iter_named_toplevel (remove_code_helper b) - (remove_code_helper_named b) lam; - !b - - let remove_projection (_proj : Projection.t) b = - (* They are all primitives for the moment. The [Projection.t] argument - is here for future expansion. *) - remove_prim b - - let print ppf b = - Format.fprintf ppf "@[remove_call: %i@ remove_alloc: %i@ \ - remove_prim: %i@ remove_branch: %i@ \ - direct: %i@ requested: %i@]" - b.remove_call - b.remove_alloc - b.remove_prim - b.remove_branch - b.direct_call_of_indirect - b.requested_inline - - let evaluate t ~round : int = - benefit_factor * - (t.remove_call * (cost !Clflags.inline_call_cost ~round) - + t.remove_alloc * (cost !Clflags.inline_alloc_cost ~round) - + t.remove_prim * (cost !Clflags.inline_prim_cost ~round) - + t.remove_branch * (cost !Clflags.inline_branch_cost ~round) - + (t.direct_call_of_indirect - * (cost !Clflags.inline_indirect_cost ~round))) - + t.requested_inline - - let (+) t1 t2 = { - remove_call = t1.remove_call + t2.remove_call; - remove_alloc = t1.remove_alloc + t2.remove_alloc; - remove_prim = t1.remove_prim + t2.remove_prim; - remove_branch = t1.remove_branch + t2.remove_branch; - direct_call_of_indirect = - t1.direct_call_of_indirect + t2.direct_call_of_indirect; - requested_inline = t1.requested_inline + t2.requested_inline; - } - - let (-) t1 t2 = { - remove_call = t1.remove_call - t2.remove_call; - remove_alloc = t1.remove_alloc - t2.remove_alloc; - remove_prim = t1.remove_prim - t2.remove_prim; - remove_branch = t1.remove_branch - t2.remove_branch; - direct_call_of_indirect = - t1.direct_call_of_indirect - t2.direct_call_of_indirect; - requested_inline = t1.requested_inline - t2.requested_inline; - } - - let max ~round t1 t2 = - let c1 = evaluate ~round t1 in - let c2 = evaluate ~round t2 in - if c1 > c2 then t1 else t2 - - let add_code lam b = - b - (remove_code lam zero) - - let add_code_named lam b = - b - (remove_code_named lam zero) - - let add_projection proj b = - b - (remove_projection proj zero) - - (* Print out a benefit as a table *) - - let benefit_table = - [ "Calls", (fun b -> b.remove_call); - "Allocs", (fun b -> b.remove_alloc); - "Prims", (fun b -> b.remove_prim); - "Branches", (fun b -> b.remove_branch); - "Indirect calls", (fun b -> b.direct_call_of_indirect); - ] - - let benefits_table = - lazy begin - List.map - (fun (header, accessor) -> (header, accessor, String.length header)) - benefit_table - end - - let table_line = - lazy begin - let benefits_table = Lazy.force benefits_table in - let dashes = - List.map (fun (_, _, n) -> String.make n '-') benefits_table - in - "|-" ^ String.concat "-+-" dashes ^ "-|" - end - - let table_headers = - lazy begin - let benefits_table = Lazy.force benefits_table in - let headers = List.map (fun (head, _, _) -> head) benefits_table in - "| " ^ String.concat " | " headers ^ " |" - end - - let print_table_values ppf b = - let rec loop ppf = function - | [] -> Format.fprintf ppf "|" - | (_, accessor, width) :: rest -> - Format.fprintf ppf "| %*d %a" width (accessor b) loop rest - in - loop ppf (Lazy.force benefits_table) - - let print_table ppf b = - let table_line = Lazy.force table_line in - let table_headers = Lazy.force table_headers in - Format.fprintf ppf - "@[@[%s@]@;@[%s@]@;@[%s@]@;@[%a@]@;@[%s@]@]" - table_line table_headers table_line - print_table_values b - table_line -end - -module Whether_sufficient_benefit = struct - type t = { - round : int; - benefit : Benefit.t; - toplevel : bool; - branch_depth : int; - lifting : bool; - original_size : int; - new_size : int; - evaluated_benefit : int; - estimate : bool; - } - - let create ~original ~toplevel ~branch_depth lam ~benefit ~lifting ~round = - let evaluated_benefit = Benefit.evaluate benefit ~round in - { round; benefit; toplevel; branch_depth; lifting; - original_size = lambda_size original; - new_size = lambda_size lam; - evaluated_benefit; - estimate = false; - } - - let create_estimate ~original_size ~toplevel ~branch_depth ~new_size - ~benefit ~lifting ~round = - let evaluated_benefit = Benefit.evaluate benefit ~round in - { round; benefit; toplevel; branch_depth; lifting; original_size; - new_size; evaluated_benefit; estimate = true; - } - - let is_nan f = - match Float.classify_float f with - | FP_nan -> true - | FP_normal | FP_subnormal | FP_zero | FP_infinite -> false - - let correct_branch_factor f = - (not (is_nan f)) - && (Float.compare f 0. >= 0) - - let estimated_benefit t = - if t.toplevel && t.lifting && t.branch_depth = 0 then begin - let lifting_benefit = - Clflags.Int_arg_helper.get ~key:t.round !Clflags.inline_lifting_benefit - in - float (t.evaluated_benefit + lifting_benefit) - end else begin - (* The estimated benefit is the evaluated benefit times an - estimation of the probability that the branch does actually matter - for performance (i.e. is hot). The probability is very roughly - estimated by considering that under every branch the - sub-expressions have the same [1 / (1 + factor)] probability - [p] of being hot. Hence the probability for the current - call to be hot is [p ^ number of nested branches]. - The probability is expressed as [1 / (1 + factor)] rather - than letting the user directly provide [p], since for every - positive value of [factor] [p] is in [0, 1]. *) - let branch_taken_estimated_probability = - let inline_branch_factor = - let factor = - Clflags.Float_arg_helper.get ~key:t.round - !Clflags.inline_branch_factor - in - if is_nan factor then - Clflags.default_inline_branch_factor - else if Float.compare factor 0. < 0 then - 0. - else - factor - in - assert (correct_branch_factor inline_branch_factor); - 1. /. (1. +. inline_branch_factor) - in - let call_estimated_probability = - branch_taken_estimated_probability ** float t.branch_depth - in - float t.evaluated_benefit *. call_estimated_probability - end - - let evaluate t = - Float.compare - (float t.new_size -. estimated_benefit t) - (float t.original_size) <= 0 - - let to_string t = - let lifting = t.toplevel && t.lifting && t.branch_depth = 0 in - let evaluated_benefit = - if lifting then - let lifting_benefit = - Clflags.Int_arg_helper.get ~key:t.round - !Clflags.inline_lifting_benefit - in - t.evaluated_benefit + lifting_benefit - else t.evaluated_benefit - in - let estimate = if t.estimate then "<" else "=" in - Printf.sprintf "{benefit%s{call=%d,alloc=%d,prim=%i,branch=%i,\ - indirect=%i,req=%i,\ - lifting=%B}, orig_size=%d,new_size=%d,eval_size=%d,\ - eval_benefit%s%d,\ - branch_depth=%d}=%s" - estimate - t.benefit.remove_call - t.benefit.remove_alloc - t.benefit.remove_prim - t.benefit.remove_branch - t.benefit.direct_call_of_indirect - t.benefit.requested_inline - lifting - t.original_size - t.new_size - (t.original_size - t.new_size) - estimate - evaluated_benefit - t.branch_depth - (if evaluate t then "yes" else "no") - - let print_description ~subfunctions ppf t = - let pr_intro ppf = - let estimate = if t.estimate then " at most" else "" in - Format.pp_print_text ppf - "Specialisation of the function body"; - if subfunctions then - Format.pp_print_text ppf - ", including speculative inlining of other functions,"; - Format.pp_print_text ppf " removed"; - Format.pp_print_text ppf estimate; - Format.pp_print_text ppf " the following operations:" - in - let lifting = t.toplevel && t.lifting && t.branch_depth = 0 in - let requested = t.benefit.requested_inline in - let pr_requested ppf = - if requested > 0 then begin - Format.pp_open_box ppf 0; - Format.pp_print_text ppf - "and inlined user-annotated functions worth "; - Format.fprintf ppf "%d." requested; - Format.pp_close_box ppf (); - Format.pp_print_cut ppf (); - Format.pp_print_cut ppf () - end - in - let pr_lifting ppf = - if lifting then begin - Format.pp_open_box ppf 0; - Format.pp_print_text ppf - "Inlining the function would also \ - lift some definitions to toplevel."; - Format.pp_close_box ppf (); - Format.pp_print_cut ppf (); - Format.pp_print_cut ppf () - end - in - let total_benefit = - if lifting then - let lifting_benefit = - Clflags.Int_arg_helper.get ~key:t.round - !Clflags.inline_lifting_benefit - in - t.evaluated_benefit + lifting_benefit - else t.evaluated_benefit - in - let expected_benefit = estimated_benefit t in - let size_change = t.new_size - t.original_size in - let result = if evaluate t then "less" else "greater" in - let pr_conclusion ppf = - Format.pp_print_text ppf "This gives a total benefit of "; - Format.pp_print_int ppf total_benefit; - Format.pp_print_text ppf ". At a branch depth of "; - Format.pp_print_int ppf t.branch_depth; - Format.pp_print_text ppf " this produces an expected benefit of "; - Format.fprintf ppf "%.1f" expected_benefit; - Format.pp_print_text ppf ". The new code has size "; - Format.pp_print_int ppf t.new_size; - Format.pp_print_text ppf ", giving a change in code size of "; - Format.pp_print_int ppf size_change; - Format.pp_print_text ppf ". The change in code size is "; - Format.pp_print_text ppf result; - Format.pp_print_text ppf " than the expected benefit." - in - Format.fprintf ppf "%t@,@[@[@;%a@]@;@;%t%t@]%t" - pr_intro Benefit.print_table t.benefit pr_requested pr_lifting - pr_conclusion -end - -let scale_inline_threshold_by = 8 - -let default_toplevel_multiplier = 8 - - (* CR-soon mshinwell for mshinwell: hastily-written comment, to review *) - (* We may in [Inlining_decision] need to measure the size of functions - that are below the inlining threshold. We also need to measure with - regard to benefit (see [Inlining_decision.inline_non_recursive). The - intuition for having a cached size in the second case is as follows. - If a function's body exceeds some maximum size and its argument - approximations are unknown (meaning that we cannot materially simplify - it further), we can infer without examining the function's body that - it cannot be inlined. The aim is to speed up [Inlining_decision]. - - The "original size" is [Inlining_cost.direct_call_size]. The "new size" is - the size of the function's body plus [Inlining_cost.project_size] for each - free variable and mutually recursive function accessed through the closure. - - To be inlined we need: - - body_size - + (closure_accesses * project_size) <= direct_call_size - - (evaluated_benefit * call_prob) - - i.e.: - - body_size <= direct_call_size - + (evaluated_benefit * call_prob) - - (closure_accesses * project_size) - - In this case we would be removing a single call and a projection for each - free variable that can be accessed directly (i.e. not via the closure - or the internal variable). - - evaluated_benefit = - benefit_factor - * (inline_call_cost - + ((free_variables - indirect_accesses) * inline_prim_cost)) - - (For [inline_call_cost] and [inline_prim_cost], we use the maximum these - might be across any round.) - - Substituting: - - body_size <= direct_call_size - + (benefit_factor - * (inline_call_cost - + ((free_variables - indirect_accesses) - * inline_prim_cost))) - * call_prob - - (closure_accesses * project_size) - - Rearranging: - - body_size <= direct_call_size - + (inline_call_cost * benefit_factor * call_prob) - + (free_variables * inline_prim_cost - * benefit_factor * call_prob) - - (indirect_accesses * inline_prim_cost - * benefit_factor * call_prob) - - (closure_accesses * project_size) - - The upper bound for the right-hand side is when call_prob = 1.0, - indirect_accesses = 0 and closure_accesses = 0, giving: - - direct_call_size - + (inline_call_cost * benefit_factor) - + (free_variables * inline_prim_cost * benefit_factor) - - So we should measure all functions at or below this size, but also record - the size discovered, so we can later re-check (without examining the body) - when we know [call_prob], [indirect_accesses] and [closure_accesses]. - - This number is split into parts dependent and independent of the - number of free variables: - - base = direct_call_size + (inline_call_cost * benefit_factor) - - multiplier = inline_prim_cost * benefit_factor - - body_size <= base + free_variables * multiplier - - *) -let maximum_interesting_size_of_function_body_base = - lazy begin - let max_cost = ref 0 in - for round = 0 to (Clflags.rounds ()) - 1 do - let max_size = - let inline_call_cost = cost !Clflags.inline_call_cost ~round in - direct_call_size + (inline_call_cost * benefit_factor) - in - max_cost := Int.max !max_cost max_size - done; - !max_cost - end - -let maximum_interesting_size_of_function_body_multiplier = - lazy begin - let max_cost = ref 0 in - for round = 0 to (Clflags.rounds ()) - 1 do - let max_size = - let inline_prim_cost = cost !Clflags.inline_prim_cost ~round in - inline_prim_cost * benefit_factor - in - max_cost := Int.max !max_cost max_size - done; - !max_cost - end - -let maximum_interesting_size_of_function_body num_free_variables = - let base = Lazy.force maximum_interesting_size_of_function_body_base in - let multiplier = - Lazy.force maximum_interesting_size_of_function_body_multiplier - in - base + (num_free_variables * multiplier) diff --git a/middle_end/flambda/inlining_cost.mli b/middle_end/flambda/inlining_cost.mli deleted file mode 100644 index 345f67abad3..00000000000 --- a/middle_end/flambda/inlining_cost.mli +++ /dev/null @@ -1,142 +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"] - -(** Measurement of the cost (including cost in space) of Flambda terms - in the context of inlining. *) - -module Threshold : sig - - (** The maximum size, in some abstract measure of space cost, that an - Flambda expression may be in order to be inlined. *) - type t = - | Never_inline - | Can_inline_if_no_larger_than of int - - val add : t -> t -> t - val sub : t -> t -> t - val min : t -> t -> t - val equal : t -> t -> bool - -end - -(* Determine whether the given Flambda expression has a sufficiently low space - cost so as to fit under the given [inlining_threshold]. The [bonus] is - added to the threshold before evaluation. *) -val can_inline - : Flambda.t - -> Threshold.t - -> bonus:int - -> bool - -(* CR-soon mshinwell for pchambart: I think the name of this function might be - misleading. It should probably reflect the functionality it provides, - not the use to which it is put in another module. *) -(* As for [can_inline], but returns the decision as an inlining threshold. - If [Never_inline] is returned, the expression was too large for the - input [inlining_threshold]. Otherwise, [Can_inline_if_no_larger_than] is - returned, with the constructor argument being the measured estimated size - of the expression. *) -val can_try_inlining - : Flambda.t - -> Threshold.t - -> number_of_arguments:int - -> size_from_approximation:int option - -> Threshold.t - -module Benefit : sig - (* A model of the benefit we gain by removing a particular combination - of operations. Such removals are typically performed by inlining (for - example, [remove_call]) and simplification (for example, [remove_alloc]) - passes. *) - - type t - - val zero : t - val (+) : t -> t -> t - val max : round:int -> t -> t -> t - - val remove_call : t -> t - (* CR-soon mshinwell: [remove_alloc] should take the size of the block - (to account for removal of initializing writes). *) - val remove_alloc : t -> t - val remove_prim : t -> t - val remove_prims : t -> int -> t - val remove_branch : t -> t - val direct_call_of_indirect : t -> t - val requested_inline : t -> size_of:Flambda.t -> t - - val remove_code : Flambda.t -> t -> t - val remove_code_named : Flambda.named -> t -> t - val remove_projection : Projection.t -> t -> t - - val add_code : Flambda.t -> t -> t - val add_code_named : Flambda.named -> t -> t - val add_projection : Projection.t -> t -> t - - val print : Format.formatter -> t -> unit -end - -module Whether_sufficient_benefit : sig - (* Evaluation of the benefit of removing certain operations against an - inlining threshold. *) - - type t - - val create - : original:Flambda.t - -> toplevel:bool - -> branch_depth:int - -> Flambda.t - -> benefit:Benefit.t - -> lifting:bool - -> round:int - -> t - - val create_estimate - : original_size:int - -> toplevel:bool - -> branch_depth: int - -> new_size:int - -> benefit:Benefit.t - -> lifting:bool - -> round:int - -> t - - val evaluate : t -> bool - - val to_string : t -> string - - val print_description : subfunctions:bool -> Format.formatter -> t -> unit -end - -val scale_inline_threshold_by : int - -val default_toplevel_multiplier : int - -val direct_call_size : int - -(** If a function body exceeds this size, we can make a fast decision not - to inline it (see [Inlining_decision]). *) -val maximum_interesting_size_of_function_body : int -> int - -(** Measure the given expression to determine whether its size is at or - below the given threshold. [None] is returned if it is too big; otherwise - [Some] is returned with the measured size. *) -val lambda_smaller' : Flambda.expr -> than:int -> int option - -val lambda_size : Flambda.expr -> int diff --git a/middle_end/flambda/inlining_decision.ml b/middle_end/flambda/inlining_decision.ml deleted file mode 100644 index 8fb5ea5f372..00000000000 --- a/middle_end/flambda/inlining_decision.ml +++ /dev/null @@ -1,764 +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-66"] -open! Int_replace_polymorphic_compare - -module A = Simple_value_approx -module E = Inline_and_simplify_aux.Env -module R = Inline_and_simplify_aux.Result -module W = Inlining_cost.Whether_sufficient_benefit -module T = Inlining_cost.Threshold -module S = Inlining_stats_types -module D = S.Decision - -let get_function_body (function_decl : A.function_declaration) = - match function_decl.function_body with - | None -> assert false - | Some function_body -> function_body - -type ('a, 'b) inlining_result = - | Changed of (Flambda.t * R.t) * 'a - | Original of 'b - -type 'b good_idea = - | Try_it - | Don't_try_it of 'b - -let inline env r ~lhs_of_application - ~closure_id_being_applied - ~(function_decl : A.function_declaration) - ~(function_body : A.function_body) - ~value_set_of_closures ~only_use_of_function ~original ~recursive - ~(args : Variable.t list) ~size_from_approximation ~dbg ~reg_close ~mode - ~simplify - ~(inlined_requested : Lambda.inlined_attribute) - ~(specialise_requested : Lambda.specialise_attribute) - ~(probe_requested : Lambda.probe) - ~fun_vars ~set_of_closures_origin - ~self_call ~fun_cost ~inlining_threshold = - let toplevel = E.at_toplevel env in - let branch_depth = E.branch_depth env in - let unrolling, always_inline, never_inline, env = - let unrolling = E.actively_unrolling env set_of_closures_origin in - match unrolling with - | Some count -> - if count > 0 then - let env = E.continue_actively_unrolling env set_of_closures_origin in - true, true, false, env - else false, false, true, env - | None -> begin - let inline_annotation : Lambda.inlined_attribute = - (* Merge call site annotation and function annotation. - The call site annotation takes precedence *) - match inlined_requested with - | Always_inlined | Hint_inlined | Never_inlined | Unroll _ -> - inlined_requested - | Default_inlined -> - match function_body.inline with - | Always_inline -> Always_inlined - | Available_inline | Default_inline -> Default_inlined - | Never_inline -> Never_inlined - | Unroll n -> Unroll n - in - match inline_annotation with - | Always_inlined | Hint_inlined -> false, true, false, env - | Never_inlined -> false, false, true, env - | Default_inlined -> false, false, false, env - | Unroll count -> - if count > 0 then - let env = - E.start_actively_unrolling - env set_of_closures_origin (count - 1) - in - true, true, false, env - else false, false, true, env - end - in - assert (Option.is_none probe_requested || never_inline); - let remaining_inlining_threshold : Inlining_cost.Threshold.t = - if always_inline then inlining_threshold - else Lazy.force fun_cost - in - let try_inlining = - if unrolling then - Try_it - else if self_call then - Don't_try_it S.Not_inlined.Self_call - else if not (E.inlining_allowed env function_decl.closure_origin) then - Don't_try_it S.Not_inlined.Unrolling_depth_exceeded - else if only_use_of_function || always_inline then - Try_it - else if never_inline then - Don't_try_it S.Not_inlined.Annotation - else if not (E.unrolling_allowed env set_of_closures_origin) - && (Lazy.force recursive) then - Don't_try_it S.Not_inlined.Unrolling_depth_exceeded - else if T.equal remaining_inlining_threshold T.Never_inline then - let threshold = - match inlining_threshold with - | T.Never_inline -> assert false - | T.Can_inline_if_no_larger_than threshold -> threshold - in - Don't_try_it (S.Not_inlined.Above_threshold threshold) - else if not (toplevel && branch_depth = 0) - && A.all_not_useful (E.find_list_exn env args) then - (* When all of the arguments to the function being inlined are unknown, - then we cannot materially simplify the function. As such, we know - what the benefit of inlining it would be: just removing the call. - In this case we may be able to prove the function cannot be inlined - without traversing its body. - Note that if the function is sufficiently small, we still have to call - [simplify], because the body needs freshening before substitution. - *) - (* CR-someday mshinwell: (from GPR#8): pchambart writes: - - We may need to think a bit about that. I can't see a lot of - meaningful examples right now, but there are some cases where some - optimization can happen even if we don't know anything about the - shape of the arguments. - - For instance - - let f x y = x - - let g x = - let y = (x,x) in - f x y - let f x y = - if x = y then ... else ... - - let g x = f x x - *) - match size_from_approximation with - | Some body_size -> - let wsb = - let benefit = Inlining_cost.Benefit.zero in - let benefit = Inlining_cost.Benefit.remove_call benefit in - let benefit = - Variable.Set.fold (fun v acc -> - try - let t = - Var_within_closure.Map.find (Var_within_closure.wrap v) - value_set_of_closures.A.bound_vars - in - match t.A.var with - | Some v -> - if (E.mem env v) then Inlining_cost.Benefit.remove_prim acc - else acc - | None -> acc - with Not_found -> acc) - function_body.free_variables benefit - in - W.create_estimate - ~original_size:Inlining_cost.direct_call_size - ~new_size:body_size - ~toplevel:(E.at_toplevel env) - ~branch_depth:(E.branch_depth env) - ~lifting:function_body.A.is_a_functor - ~round:(E.round env) - ~benefit - in - if (not (W.evaluate wsb)) then begin - Don't_try_it - (S.Not_inlined.Without_subfunctions wsb) - end else Try_it - | None -> - (* The function is definitely too large to inline given that we don't - have any approximations for its arguments. Further, the body - should already have been simplified (inside its declaration), so - we also expect no gain from the code below that permits inlining - inside the body. *) - Don't_try_it S.Not_inlined.No_useful_approximations - else begin - (* There are useful approximations, so we should simplify. *) - Try_it - end - in - match try_inlining with - | Don't_try_it decision -> Original decision - | Try_it -> - let r = - R.set_inlining_threshold r (Some remaining_inlining_threshold) - in - let body, r_inlined = - (* First we construct the code that would result from copying the body of - the function, without doing any further inlining upon it, to the call - site. *) - Inlining_transforms.inline_by_copying_function_body ~env - ~r:(R.reset_benefit r) ~lhs_of_application - ~closure_id_being_applied ~specialise_requested ~inlined_requested - ~probe_requested ~free_vars:value_set_of_closures.A.free_vars - ~function_decl ~function_body ~fun_vars ~args ~dbg ~reg_close ~mode ~simplify - in - let num_direct_applications_seen = - (R.num_direct_applications r_inlined) - (R.num_direct_applications r) - in - assert (num_direct_applications_seen >= 0); - let keep_inlined_version decision = - (* Inlining the body of the function was sufficiently beneficial that we - will keep it, replacing the call site. We continue by allowing - further inlining within the inlined copy of the body. *) - let r_inlined = - (* The meaning of requesting inlining is that the user ensure - that the function has a benefit of at least its size. It is not - added to the benefit exposed by the inlining because the user should - have taken that into account before annotating the function. *) - if always_inline then - R.map_benefit r_inlined - (Inlining_cost.Benefit.max ~round:(E.round env) - Inlining_cost.Benefit.(requested_inline ~size_of:body zero)) - else r_inlined - in - let r = - R.map_benefit r_inlined (Inlining_cost.Benefit.(+) (R.benefit r)) - in - let env = E.note_entering_inlined env in - let env = - (* We decrement the unrolling count even if the function is not - recursive to avoid having to check whether or not it is recursive *) - E.inside_unrolled_function env set_of_closures_origin - in - let env = E.inside_inlined_function env function_decl.closure_origin in - let env = - if E.inlining_level env = 0 - (* If the function was considered for inlining without considering - its sub-functions, and it is not below another inlining choice, - then we are certain that this code will be kept. *) - then env - else E.inlining_level_up env - in - Changed ((simplify env r body), decision) - in - if always_inline then - keep_inlined_version S.Inlined.Annotation - else if only_use_of_function then - keep_inlined_version S.Inlined.Decl_local_to_application - else begin - let wsb = - W.create ~original body - ~toplevel:(E.at_toplevel env) - ~branch_depth:(E.branch_depth env) - ~lifting:function_body.is_a_functor - ~round:(E.round env) - ~benefit:(R.benefit r_inlined) - in - if W.evaluate wsb then - keep_inlined_version (S.Inlined.Without_subfunctions wsb) - else if num_direct_applications_seen < 1 then begin - (* Inlining the body of the function did not appear sufficiently - beneficial; however, it may become so if we inline within the body - first. We try that next, unless it is known that there were - no direct applications in the simplified body computed above, meaning - no opportunities for inlining. *) - Original (S.Not_inlined.Without_subfunctions wsb) - end else begin - let env = E.inlining_level_up env in - let env = E.note_entering_inlined env in - let env = - (* We decrement the unrolling count even if the function is recursive - to avoid having to check whether or not it is recursive *) - E.inside_unrolled_function env set_of_closures_origin - in - let body, r_inlined = simplify env r_inlined body in - let wsb_with_subfunctions = - W.create ~original body - ~toplevel:(E.at_toplevel env) - ~branch_depth:(E.branch_depth env) - ~lifting:function_body.is_a_functor - ~round:(E.round env) - ~benefit:(R.benefit r_inlined) - in - if W.evaluate wsb_with_subfunctions then begin - let res = - (body, R.map_benefit r_inlined - (Inlining_cost.Benefit.(+) (R.benefit r))) - in - let decision = - S.Inlined.With_subfunctions (wsb, wsb_with_subfunctions) - in - Changed (res, decision) - end - else begin - (* r_inlined contains an approximation that may be invalid for the - untransformed expression: it may reference functions that only - exists if the body of the function is in fact inlined. - If the function approximation contained an approximation that - does not depend on the actual values of its arguments, it - could be returned instead of [A.value_unknown]. *) - let decision = - S.Not_inlined.With_subfunctions (wsb, wsb_with_subfunctions) - in - Original decision - end - end - end - -let specialise env r ~lhs_of_application - ~(function_decls : A.function_declarations) - ~(function_decl : A.function_declaration) - ~closure_id_being_applied - ~(value_set_of_closures : A.value_set_of_closures) - ~args ~args_approxs ~dbg ~reg_close ~mode ~simplify - ~original ~recursive ~self_call - ~inlining_threshold ~fun_cost - ~inlined_requested ~specialise_requested - ~probe_requested - = - let invariant_params = value_set_of_closures.invariant_params in - let free_vars = value_set_of_closures.free_vars in - let has_no_useful_approxes = - lazy - (List.for_all2 - (fun id approx -> - not ((A.useful approx) - && Variable.Map.mem id (Lazy.force invariant_params))) - (Parameter.List.vars function_decl.params) args_approxs) - in - let always_specialise, never_specialise = - (* Merge call site annotation and function annotation. - The call site annotation takes precedence *) - match (specialise_requested : Lambda.specialise_attribute) with - | Always_specialise -> true, false - | Never_specialise -> false, true - | Default_specialise -> begin - match function_decl.function_body with - | None -> false, true - | Some { specialise } -> - match (specialise : Lambda.specialise_attribute) with - | Always_specialise -> true, false - | Never_specialise -> false, true - | Default_specialise -> false, false - end - in - let remaining_inlining_threshold : Inlining_cost.Threshold.t = - if always_specialise then inlining_threshold - else Lazy.force fun_cost - in - let try_specialising = - (* Try specialising if the function: - - is recursive; and - - is closed (it and all other members of the set of closures on which - it depends); and - - has useful approximations for some invariant parameters. *) - if function_decls.is_classic_mode then - Don't_try_it S.Not_specialised.Classic_mode - else if self_call then - Don't_try_it S.Not_specialised.Self_call - else if always_specialise && not (Lazy.force has_no_useful_approxes) then - Try_it - else if never_specialise then - Don't_try_it S.Not_specialised.Annotation - else if T.equal remaining_inlining_threshold T.Never_inline then - let threshold = - match inlining_threshold with - | T.Never_inline -> assert false - | T.Can_inline_if_no_larger_than threshold -> threshold - in - Don't_try_it (S.Not_specialised.Above_threshold threshold) - else if not (Variable.Map.is_empty free_vars) then - Don't_try_it S.Not_specialised.Not_closed - else if not (Lazy.force recursive) then - Don't_try_it S.Not_specialised.Not_recursive - else if Variable.Map.is_empty (Lazy.force invariant_params) then - Don't_try_it S.Not_specialised.No_invariant_parameters - else if Lazy.force has_no_useful_approxes then - Don't_try_it S.Not_specialised.No_useful_approximations - else Try_it - in - match try_specialising with - | Don't_try_it decision -> Original decision - | Try_it -> begin - let r = - R.set_inlining_threshold r (Some remaining_inlining_threshold) - in - let copied_function_declaration = - Inlining_transforms.inline_by_copying_function_declaration ~env - ~r:(R.reset_benefit r) ~lhs_of_application - ~function_decls ~closure_id_being_applied ~function_decl - ~args ~args_approxs - ~invariant_params:invariant_params - ~specialised_args:value_set_of_closures.specialised_args - ~probe_requested - ~free_vars:value_set_of_closures.free_vars - ~direct_call_surrogates:value_set_of_closures.direct_call_surrogates - ~dbg ~reg_close ~mode ~simplify ~inlined_requested - in - match copied_function_declaration with - | Some (expr, r_inlined) -> - let wsb = - W.create ~original expr - ~toplevel:false - ~branch_depth:(E.branch_depth env) - ~lifting:false - ~round:(E.round env) - ~benefit:(R.benefit r_inlined) - in - let env = - (* CR-someday lwhite: could avoid calculating this if stats is turned - off *) - let closure_ids = - Closure_id.Set.of_list ( - List.map Closure_id.wrap - (Variable.Set.elements (Variable.Map.keys function_decls.funs))) - in - E.note_entering_specialised env ~closure_ids - in - if always_specialise || W.evaluate wsb then begin - let r_inlined = - if always_specialise then - R.map_benefit r_inlined - (Inlining_cost.Benefit.max ~round:(E.round env) - Inlining_cost.Benefit.(requested_inline ~size_of:expr zero)) - else r_inlined - in - let r = - R.map_benefit r_inlined (Inlining_cost.Benefit.(+) (R.benefit r)) - in - let closure_env = - let env = - if E.inlining_level env = 0 - (* If the function was considered for specialising without - considering its sub-functions, and it is not below another - inlining choice, then we are certain that this code will - be kept. *) - then env - else E.inlining_level_up env - in - E.set_never_inline_outside_closures env - in - let application_env = E.set_never_inline_inside_closures env in - let expr, r = simplify closure_env r expr in - let res = simplify application_env r expr in - let decision = - if always_specialise then S.Specialised.Annotation - else S.Specialised.Without_subfunctions wsb - in - Changed (res, decision) - end else begin - let closure_env = - let env = E.inlining_level_up env in - E.set_never_inline_outside_closures env - in - let expr, r_inlined = simplify closure_env r_inlined expr in - let wsb_with_subfunctions = - W.create ~original expr - ~toplevel:false - ~branch_depth:(E.branch_depth env) - ~lifting:false - ~round:(E.round env) - ~benefit:(R.benefit r_inlined) - in - if W.evaluate wsb_with_subfunctions then begin - let r = - R.map_benefit r_inlined - (Inlining_cost.Benefit.(+) (R.benefit r)) - in - let application_env = E.set_never_inline_inside_closures env in - let res = simplify application_env r expr in - let decision = - S.Specialised.With_subfunctions (wsb, wsb_with_subfunctions) - in - Changed (res, decision) - end else begin - let decision = - S.Not_specialised.Not_beneficial (wsb, wsb_with_subfunctions) - in - Original decision - end - end - | None -> - let decision = S.Not_specialised.No_useful_approximations in - Original decision - end - -let for_call_site ~env ~r ~(function_decls : A.function_declarations) - ~lhs_of_application ~closure_id_being_applied - ~(function_decl : A.function_declaration) - ~(value_set_of_closures : A.value_set_of_closures) - ~args ~args_approxs ~dbg ~reg_close ~mode ~simplify ~inlined_requested - ~specialise_requested ~probe_requested ~result_layout = - if List.length args <> List.length args_approxs then begin - Misc.fatal_error "Inlining_decision.for_call_site: inconsistent lengths \ - of [args] and [args_approxs]" - end; - (* Remove unroll attributes from functions we are already actively - unrolling, otherwise they'll be unrolled again next round. *) - let inlined_requested : Lambda.inlined_attribute = - match (inlined_requested : Lambda.inlined_attribute) with - | Unroll _ -> begin - let unrolling = - E.actively_unrolling env function_decls.set_of_closures_origin - in - match unrolling with - | Some _ -> Default_inlined - | None -> inlined_requested - end - | Always_inlined | Hint_inlined | Default_inlined | Never_inlined -> - inlined_requested - in - let original = - Flambda.Apply { - func = lhs_of_application; - args; - result_layout; - kind = Direct closure_id_being_applied; - dbg; - reg_close; - mode; - inlined = inlined_requested; - specialise = specialise_requested; - probe = probe_requested; - } - in - let original_r = - R.set_approx (R.seen_direct_application r) (A.value_unknown Other) - in - match function_decl.function_body with - | None -> original, original_r - | Some { stub; _ } -> - if stub then begin - let fun_vars = Variable.Map.keys function_decls.funs in - let function_body = get_function_body function_decl in - let body, r = - Inlining_transforms.inline_by_copying_function_body ~env - ~r ~fun_vars ~lhs_of_application - ~closure_id_being_applied ~specialise_requested ~inlined_requested - ~probe_requested ~free_vars:value_set_of_closures.free_vars - ~function_decl ~function_body ~args ~dbg ~reg_close ~mode ~simplify - in - simplify env r body - end else if E.never_inline env then - (* This case only occurs when examining the body of a stub function - but not in the context of inlining said function. As such, there - is nothing to do here (and no decision to report). *) - original, original_r - else if function_decls.is_classic_mode then begin - let env = - E.note_entering_call env - ~closure_id:closure_id_being_applied ~dbg:dbg - in - let simpl = - match function_decl.function_body with - | None -> Original S.Not_inlined.Classic_mode - | Some function_body -> - let self_call = - E.inside_set_of_closures_declaration - function_decls.set_of_closures_origin env - in - let try_inlining = - if self_call then - Don't_try_it S.Not_inlined.Self_call - else - if not (E.inlining_allowed env function_decl.closure_origin) then - Don't_try_it S.Not_inlined.Unrolling_depth_exceeded - else - Try_it - in - match try_inlining with - | Don't_try_it decision -> Original decision - | Try_it -> - let fun_vars = Variable.Map.keys function_decls.funs in - let body, r = - Inlining_transforms.inline_by_copying_function_body ~env - ~r ~function_body ~lhs_of_application - ~closure_id_being_applied ~specialise_requested - ~probe_requested ~free_vars:value_set_of_closures.free_vars - ~inlined_requested ~function_decl ~fun_vars ~args - ~dbg ~reg_close ~mode ~simplify - in - let env = E.note_entering_inlined env in - let env = - (* We decrement the unrolling count even if the function is not - recursive to avoid having to check whether or not it is - recursive *) - E.inside_unrolled_function env - function_decls.set_of_closures_origin - in - let env = - E.inside_inlined_function env function_decl.closure_origin - in - Changed ((simplify env r body), S.Inlined.Classic_mode) - in - let res, decision = - match simpl with - | Original decision -> - let decision = - S.Decision.Unchanged (S.Not_specialised.Classic_mode, decision) - in - (original, original_r), decision - | Changed ((expr, r), decision) -> - let max_inlining_threshold = - if E.at_toplevel env then - Inline_and_simplify_aux.initial_inlining_toplevel_threshold - ~round:(E.round env) - else - Inline_and_simplify_aux.initial_inlining_threshold - ~round:(E.round env) - in - let raw_inlining_threshold = R.inlining_threshold r in - let unthrottled_inlining_threshold = - match raw_inlining_threshold with - | None -> max_inlining_threshold - | Some inlining_threshold -> inlining_threshold - in - let inlining_threshold = - T.min unthrottled_inlining_threshold max_inlining_threshold - in - let inlining_threshold_diff = - T.sub unthrottled_inlining_threshold inlining_threshold - in - let res = - if E.inlining_level env = 0 - then expr, R.set_inlining_threshold r raw_inlining_threshold - else expr, R.add_inlining_threshold r inlining_threshold_diff - in - res, S.Decision.Inlined (S.Not_specialised.Classic_mode, decision) - in - E.record_decision env decision; - res - end else begin - let function_body = get_function_body function_decl in - let env = E.unset_never_inline_inside_closures env in - let env = - E.note_entering_call env - ~closure_id:closure_id_being_applied ~dbg:dbg - in - let max_level = - Clflags.Int_arg_helper.get ~key:(E.round env) !Clflags.inline_max_depth - in - let raw_inlining_threshold = R.inlining_threshold r in - let max_inlining_threshold = - if E.at_toplevel env then - Inline_and_simplify_aux.initial_inlining_toplevel_threshold - ~round:(E.round env) - else - Inline_and_simplify_aux.initial_inlining_threshold - ~round:(E.round env) - in - let unthrottled_inlining_threshold = - match raw_inlining_threshold with - | None -> max_inlining_threshold - | Some inlining_threshold -> inlining_threshold - in - let inlining_threshold = - T.min unthrottled_inlining_threshold max_inlining_threshold - in - let inlining_threshold_diff = - T.sub unthrottled_inlining_threshold inlining_threshold - in - let inlining_prevented = - match inlining_threshold with - | Never_inline -> true - | Can_inline_if_no_larger_than _ -> false - in - let simpl = - if inlining_prevented then - Original (D.Prevented Function_prevented_from_inlining) - else if E.inlining_level env >= max_level then - Original (D.Prevented Level_exceeded) - else begin - let self_call = - E.inside_set_of_closures_declaration - function_decls.set_of_closures_origin env - in - let fun_cost = - lazy - (Inlining_cost.can_try_inlining function_body.body - inlining_threshold - ~number_of_arguments:(List.length function_decl.params) - (* CR-someday mshinwell: for the moment, this is None, since - the Inlining_cost code isn't checking sizes up to the max - inlining threshold---this seems to take too long. *) - ~size_from_approximation:None) - in - let recursive = - lazy - (let fun_var = Closure_id.unwrap closure_id_being_applied in - Variable.Set.mem fun_var - (Lazy.force value_set_of_closures.recursive)) - in - let specialise_result = - specialise env r - ~function_decls ~function_decl - ~lhs_of_application ~recursive ~closure_id_being_applied - ~value_set_of_closures ~args ~args_approxs ~dbg ~reg_close ~mode - ~simplify - ~original ~inlined_requested ~specialise_requested ~fun_cost - ~self_call ~inlining_threshold ~probe_requested - in - match specialise_result with - | Changed (res, spec_reason) -> - Changed (res, D.Specialised spec_reason) - | Original spec_reason -> - let only_use_of_function = false in - (* If we didn't specialise then try inlining *) - let size_from_approximation = - let fun_var = Closure_id.unwrap closure_id_being_applied in - match - Variable.Map.find fun_var - (Lazy.force value_set_of_closures.size) - with - | size -> size - | exception Not_found -> - Misc.fatal_errorf "Approximation does not give a size for the \ - function having fun_var %a. \ - value_set_of_closures: %a" - Variable.print fun_var - A.print_value_set_of_closures value_set_of_closures - in - let fun_vars = Variable.Map.keys function_decls.funs in - let set_of_closures_origin = - function_decls.set_of_closures_origin - in - let inline_result = - inline env r ~lhs_of_application - ~closure_id_being_applied ~function_decl ~value_set_of_closures - ~only_use_of_function ~original ~recursive - ~inlined_requested ~specialise_requested ~probe_requested - ~fun_vars ~set_of_closures_origin ~args - ~size_from_approximation ~dbg ~reg_close ~mode - ~simplify ~fun_cost ~self_call - ~inlining_threshold ~function_body - in - match inline_result with - | Changed (res, inl_reason) -> - Changed (res, D.Inlined (spec_reason, inl_reason)) - | Original inl_reason -> - Original (D.Unchanged (spec_reason, inl_reason)) - end - in - let res, decision = - match simpl with - | Original decision -> (original, original_r), decision - | Changed ((expr, r), decision) -> - let res = - if E.inlining_level env = 0 - then expr, R.set_inlining_threshold r raw_inlining_threshold - else expr, R.add_inlining_threshold r inlining_threshold_diff - in - res, decision - in - E.record_decision env decision; - res - end - -(* We do not inline inside stubs, which are always inlined at their call site. - Inlining inside the declaration of a stub could result in more code than - expected being inlined (e.g. the body of a function that was transformed - by adding the stub). *) -let should_inline_inside_declaration (decl : Flambda.function_declaration) = - not decl.stub diff --git a/middle_end/flambda/inlining_decision.mli b/middle_end/flambda/inlining_decision.mli deleted file mode 100644 index ec4a9d84e31..00000000000 --- a/middle_end/flambda/inlining_decision.mli +++ /dev/null @@ -1,47 +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"] - -(** See the Flambda manual chapter for an explanation in prose of the - inlining decision procedure. *) - -(** Try to inline a full application of a known function, guided by various - heuristics. *) -val for_call_site - : env:Inline_and_simplify_aux.Env.t - -> r:Inline_and_simplify_aux.Result.t - -> function_decls:Simple_value_approx.function_declarations - -> lhs_of_application:Variable.t - -> closure_id_being_applied:Closure_id.t - -> function_decl:Simple_value_approx.function_declaration - -> value_set_of_closures:Simple_value_approx.value_set_of_closures - -> args:Variable.t list - -> args_approxs:Simple_value_approx.t list - -> dbg:Debuginfo.t - -> reg_close:Lambda.region_close - -> mode:Lambda.alloc_mode - -> simplify:Inlining_decision_intf.simplify - -> inlined_requested:Lambda.inlined_attribute - -> specialise_requested:Lambda.specialise_attribute - -> probe_requested:Lambda.probe - -> result_layout:Lambda.layout - -> Flambda.t * Inline_and_simplify_aux.Result.t - -(** When a function declaration is encountered by [for_call_site], the body - may be subject to inlining immediately, thus changing the declaration. - This function must return [true] for that to be able to happen. *) -val should_inline_inside_declaration : Flambda.function_declaration -> bool diff --git a/middle_end/flambda/inlining_decision_intf.mli b/middle_end/flambda/inlining_decision_intf.mli deleted file mode 100644 index 15a080316cf..00000000000 --- a/middle_end/flambda/inlining_decision_intf.mli +++ /dev/null @@ -1,49 +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-someday mshinwell: name of this source file could now be improved *) - -type 'a by_copying_function_body = - env:Inline_and_simplify_aux.Env.t - -> r:Inline_and_simplify_aux.Result.t - -> clos:Flambda.function_declarations - -> lfunc:Flambda.t - -> fun_id:Closure_id.t - -> func:Flambda.function_declaration - -> args:Flambda.t list - -> Flambda.t * Inline_and_simplify_aux.Result.t - -type 'a by_copying_function_declaration = - env:Inline_and_simplify_aux.Env.t - -> r:Inline_and_simplify_aux.Result.t - -> funct:Flambda.t - -> clos:Flambda.function_declarations - -> fun_id:Closure_id.t - -> func:Flambda.function_declaration - -> args_with_approxs: - (Flambda.t list) * (Simple_value_approx.t list) - -> invariant_params:Variable.Set.t - -> specialised_args:Variable.Set.t - -> dbg:Debuginfo.t - -> (Flambda.t * Inline_and_simplify_aux.Result.t) option - -type simplify = - Inline_and_simplify_aux.Env.t - -> Inline_and_simplify_aux.Result.t - -> Flambda.t - -> Flambda.t * Inline_and_simplify_aux.Result.t diff --git a/middle_end/flambda/inlining_stats.ml b/middle_end/flambda/inlining_stats.ml deleted file mode 100644 index 6809d4cbb4c..00000000000 --- a/middle_end/flambda/inlining_stats.ml +++ /dev/null @@ -1,252 +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-66"] -open! Int_replace_polymorphic_compare - -module Closure_stack = struct - type t = node list - - and node = - | Closure of Closure_id.t * Debuginfo.t - | Call of Closure_id.t * Debuginfo.t - | Inlined - | Specialised of Closure_id.Set.t - - let create () = [] - - let note_entering_closure t ~closure_id ~dbg = - if not !Clflags.inlining_report then t - else - match t with - | [] | (Closure _ | Inlined | Specialised _) :: _-> - (Closure (closure_id, dbg)) :: t - | (Call _) :: _ -> - Misc.fatal_errorf "note_entering_closure: unexpected Call node" - - (* CR-someday lwhite: since calls do not have a unique id it is possible - some calls will end up sharing nodes. *) - let note_entering_call t ~closure_id ~dbg = - if not !Clflags.inlining_report then t - else - match t with - | [] | (Closure _ | Inlined | Specialised _) :: _ -> - (Call (closure_id, dbg)) :: t - | (Call _) :: _ -> - Misc.fatal_errorf "note_entering_call: unexpected Call node" - - let note_entering_inlined t = - if not !Clflags.inlining_report then t - else - match t with - | [] | (Closure _ | Inlined | Specialised _) :: _-> - Misc.fatal_errorf "note_entering_inlined: missing Call node" - | (Call _) :: _ -> Inlined :: t - - let note_entering_specialised t ~closure_ids = - if not !Clflags.inlining_report then t - else - match t with - | [] | (Closure _ | Inlined | Specialised _) :: _ -> - Misc.fatal_errorf "note_entering_specialised: missing Call node" - | (Call _) :: _ -> Specialised closure_ids :: t - -end - -let log - : (Closure_stack.t * Inlining_stats_types.Decision.t) list ref - = ref [] - -let record_decision decision ~closure_stack = - if !Clflags.inlining_report then begin - match closure_stack with - | [] - | Closure_stack.Closure _ :: _ - | Closure_stack.Inlined :: _ - | Closure_stack.Specialised _ :: _ -> - Misc.fatal_errorf "record_decision: missing Call node" - | Closure_stack.Call _ :: _ -> - log := (closure_stack, decision) :: !log - end - -module Inlining_report = struct - - module Place = struct - type kind = - | Closure - | Call - - type t = Debuginfo.t * Closure_id.t * kind - - let compare ((d1, cl1, k1) : t) ((d2, cl2, k2) : t) = - let c = Debuginfo.compare d1 d2 in - if c <> 0 then c else - let c = Closure_id.compare cl1 cl2 in - if c <> 0 then c else - match k1, k2 with - | Closure, Closure -> 0 - | Call, Call -> 0 - | Closure, Call -> 1 - | Call, Closure -> -1 - end - - module Place_map = Map.Make(Place) - - type t = node Place_map.t - - and node = - | Closure of t - | Call of call - - and call = - { decision: Inlining_stats_types.Decision.t option; - inlined: t option; - specialised: t option; } - - let empty_call = - { decision = None; - inlined = None; - specialised = None; } - - (* Prevented or unchanged decisions may be overridden by a later look at the - same call. Other decisions may also be "overridden" because calls are not - uniquely identified. *) - let add_call_decision call (decision : Inlining_stats_types.Decision.t) = - match call.decision, decision with - | None, _ -> { call with decision = Some decision } - | Some _, Prevented _ -> call - | Some (Prevented _), _ -> { call with decision = Some decision } - | Some (Specialised _), _ -> call - | Some _, Specialised _ -> { call with decision = Some decision } - | Some (Inlined _), _ -> call - | Some _, Inlined _ -> { call with decision = Some decision } - | Some Unchanged _, Unchanged _ -> call - - let add_decision t (stack, decision) = - let rec loop t : Closure_stack.t -> _ = function - | Closure(cl, dbg) :: rest -> - let key : Place.t = (dbg, cl, Closure) in - let v = - try - match Place_map.find key t with - | Closure v -> v - | Call _ -> assert false - with Not_found -> Place_map.empty - in - let v = loop v rest in - Place_map.add key (Closure v) t - | Call(cl, dbg) :: rest -> - let key : Place.t = (dbg, cl, Call) in - let v = - try - match Place_map.find key t with - | Call v -> v - | Closure _ -> assert false - with Not_found -> empty_call - in - let v = - match rest with - | [] -> add_call_decision v decision - | Inlined :: rest -> - let inlined = - match v.inlined with - | None -> Place_map.empty - | Some inlined -> inlined - in - let inlined = loop inlined rest in - { v with inlined = Some inlined } - | Specialised _ :: rest -> - let specialised = - match v.specialised with - | None -> Place_map.empty - | Some specialised -> specialised - in - let specialised = loop specialised rest in - { v with specialised = Some specialised } - | Call _ :: _ -> assert false - | Closure _ :: _ -> assert false - in - Place_map.add key (Call v) t - | [] -> assert false - | Inlined :: _ -> assert false - | Specialised _ :: _ -> assert false - in - loop t (List.rev stack) - - let build log = - List.fold_left add_decision Place_map.empty log - - let print_stars ppf n = - let s = String.make n '*' in - Format.fprintf ppf "%s" s - - let rec print ~depth ppf t = - Place_map.iter (fun (dbg, cl, _) v -> - match v with - | Closure t -> - Format.fprintf ppf "@[%a Definition of %a%s@]@." - print_stars (depth + 1) - Closure_id.print cl - (Debuginfo.to_string dbg); - print ppf ~depth:(depth + 1) t; - if depth = 0 then Format.pp_print_newline ppf () - | Call c -> - match c.decision with - | None -> - Misc.fatal_error "Inlining_report.print: missing call decision" - | Some decision -> - Format.pp_open_vbox ppf (depth + 2); - Format.fprintf ppf "@[%a Application of %a%s@]@;@;@[%a@]" - print_stars (depth + 1) - Closure_id.print cl - (Debuginfo.to_string dbg) - Inlining_stats_types.Decision.summary decision; - Format.pp_close_box ppf (); - Format.pp_print_newline ppf (); - Format.pp_print_newline ppf (); - Inlining_stats_types.Decision.calculation ~depth:(depth + 1) - ppf decision; - begin - match c.specialised with - | None -> () - | Some specialised -> - print ppf ~depth:(depth + 1) specialised - end; - begin - match c.inlined with - | None -> () - | Some inlined -> - print ppf ~depth:(depth + 1) inlined - end; - if depth = 0 then Format.pp_print_newline ppf ()) - t - - let print ppf t = print ~depth:0 ppf t - -end - -let really_save_then_forget_decisions ~output_prefix = - let report = Inlining_report.build !log in - let out_channel = open_out (output_prefix ^ ".inlining.org") in - let ppf = Format.formatter_of_out_channel out_channel in - Inlining_report.print ppf report; - close_out out_channel; - log := [] - -let save_then_forget_decisions ~output_prefix = - if !Clflags.inlining_report then begin - really_save_then_forget_decisions ~output_prefix - end diff --git a/middle_end/flambda/inlining_stats.mli b/middle_end/flambda/inlining_stats.mli deleted file mode 100644 index f1e84fdcea3..00000000000 --- a/middle_end/flambda/inlining_stats.mli +++ /dev/null @@ -1,46 +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"] - -module Closure_stack : sig - type t - - val create : unit -> t - - val note_entering_closure - : t - -> closure_id:Closure_id.t - -> dbg:Debuginfo.t - -> t - - val note_entering_call - : t - -> closure_id:Closure_id.t - -> dbg:Debuginfo.t - -> t - - val note_entering_inlined : t -> t - val note_entering_specialised : t -> closure_ids:Closure_id.Set.t -> t - -end - -val record_decision - : Inlining_stats_types.Decision.t - -> closure_stack:Closure_stack.t - -> unit - -val save_then_forget_decisions : output_prefix:string -> unit diff --git a/middle_end/flambda/inlining_stats_types.ml b/middle_end/flambda/inlining_stats_types.ml deleted file mode 100644 index 7aef0796d9a..00000000000 --- a/middle_end/flambda/inlining_stats_types.ml +++ /dev/null @@ -1,290 +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-66"] -open! Int_replace_polymorphic_compare - -module Wsb = Inlining_cost.Whether_sufficient_benefit - -let print_stars ppf n = - let s = String.make n '*' in - Format.fprintf ppf "%s" s - -let print_calculation ~depth ~title ~subfunctions ppf wsb = - Format.pp_open_vbox ppf (depth + 2); - Format.fprintf ppf "@[%a %s@]@;@;@[%a@]" - print_stars (depth + 1) - title - (Wsb.print_description ~subfunctions) wsb; - Format.pp_close_box ppf (); - Format.pp_print_newline ppf (); - Format.pp_print_newline ppf () - -module Inlined = struct - - type t = - | Classic_mode - | Annotation - | Decl_local_to_application - | Without_subfunctions of Wsb.t - | With_subfunctions of Wsb.t * Wsb.t - - let summary ppf = function - | Classic_mode -> - Format.pp_print_text ppf - "This function was inlined because it was small enough \ - to be inlined in `-Oclassic'" - | Annotation -> - Format.pp_print_text ppf - "This function was inlined because of an annotation." - | Decl_local_to_application -> - Format.pp_print_text ppf - "This function was inlined because it was local to this application." - | Without_subfunctions _ -> - Format.pp_print_text ppf - "This function was inlined because \ - the expected benefit outweighed the change in code size." - | With_subfunctions _ -> - Format.pp_print_text ppf - "This function was inlined because \ - the expected benefit outweighed the change in code size." - - let calculation ~depth ppf = function - | Classic_mode -> () - | Annotation -> () - | Decl_local_to_application -> () - | Without_subfunctions wsb -> - print_calculation - ~depth ~title:"Inlining benefit calculation" - ~subfunctions:false ppf wsb - | With_subfunctions(_, wsb) -> - print_calculation - ~depth ~title:"Inlining benefit calculation" - ~subfunctions:true ppf wsb - -end - -module Not_inlined = struct - type t = - | Classic_mode - | Above_threshold of int - | Annotation - | No_useful_approximations - | Unrolling_depth_exceeded - | Self_call - | Without_subfunctions of Wsb.t - | With_subfunctions of Wsb.t * Wsb.t - - - let summary ppf = function - | Classic_mode -> - Format.pp_print_text ppf - "This function was not inlined because it was too \ - large to be inlined in `-Oclassic'." - | Above_threshold size -> - Format.pp_print_text ppf - "This function was not inlined because \ - it was larger than the current size threshold"; - Format.fprintf ppf "(%i)" size - | Annotation -> - Format.pp_print_text ppf - "This function was not inlined because \ - of an annotation." - | No_useful_approximations -> - Format.pp_print_text ppf - "This function was not inlined because \ - there was no useful information about any of its parameters, \ - and it was not particularly small." - | Unrolling_depth_exceeded -> - Format.pp_print_text ppf - "This function was not inlined because \ - its unrolling depth was exceeded." - | Self_call -> - Format.pp_print_text ppf - "This function was not inlined because \ - it was a self call." - | Without_subfunctions _ -> - Format.pp_print_text ppf - "This function was not inlined because \ - the expected benefit did not outweigh the change in code size." - | With_subfunctions _ -> - Format.pp_print_text ppf - "This function was not inlined because \ - the expected benefit did not outweigh the change in code size." - - let calculation ~depth ppf = function - | Classic_mode - | Above_threshold _ - | Annotation - | No_useful_approximations - | Unrolling_depth_exceeded - | Self_call -> () - | Without_subfunctions wsb -> - print_calculation - ~depth ~title:"Inlining benefit calculation" - ~subfunctions:false ppf wsb - | With_subfunctions(_, wsb) -> - print_calculation - ~depth ~title:"Inlining benefit calculation" - ~subfunctions:true ppf wsb - -end - -module Specialised = struct - type t = - | Annotation - | Without_subfunctions of Wsb.t - | With_subfunctions of Wsb.t * Wsb.t - - let summary ppf = function - | Annotation -> - Format.pp_print_text ppf - "This function was specialised because of an annotation." - | Without_subfunctions _ -> - Format.pp_print_text ppf - "This function was specialised because the expected benefit \ - outweighed the change in code size." - | With_subfunctions _ -> - Format.pp_print_text ppf - "This function was specialised because the expected benefit \ - outweighed the change in code size." - - - let calculation ~depth ppf = function - | Annotation -> () - | Without_subfunctions wsb -> - print_calculation - ~depth ~title:"Specialising benefit calculation" - ~subfunctions:false ppf wsb - | With_subfunctions(_, wsb) -> - print_calculation - ~depth ~title:"Specialising benefit calculation" - ~subfunctions:true ppf wsb -end - -module Not_specialised = struct - type t = - | Classic_mode - | Above_threshold of int - | Annotation - | Not_recursive - | Not_closed - | No_invariant_parameters - | No_useful_approximations - | Self_call - | Not_beneficial of Wsb.t * Wsb.t - - let summary ppf = function - | Classic_mode -> - Format.pp_print_text ppf - "This function was not specialised because it was \ - compiled with `-Oclassic'." - | Above_threshold size -> - Format.pp_print_text ppf - "This function was not specialised because \ - it was larger than the current size threshold"; - Format.fprintf ppf "(%i)" size - | Annotation -> - Format.pp_print_text ppf - "This function was not specialised because \ - of an annotation." - | Not_recursive -> - Format.pp_print_text ppf - "This function was not specialised because \ - it is not recursive." - | Not_closed -> - Format.pp_print_text ppf - "This function was not specialised because \ - it is not closed." - | No_invariant_parameters -> - Format.pp_print_text ppf - "This function was not specialised because \ - it has no invariant parameters." - | No_useful_approximations -> - Format.pp_print_text ppf - "This function was not specialised because \ - there was no useful information about any of its invariant \ - parameters." - | Self_call -> - Format.pp_print_text ppf - "This function was not specialised because \ - it was a self call." - | Not_beneficial _ -> - Format.pp_print_text ppf - "This function was not specialised because \ - the expected benefit did not outweigh the change in code size." - - let calculation ~depth ppf = function - | Classic_mode - | Above_threshold _ - | Annotation - | Not_recursive - | Not_closed - | No_invariant_parameters - | No_useful_approximations - | Self_call -> () - | Not_beneficial(_, wsb) -> - print_calculation - ~depth ~title:"Specialising benefit calculation" - ~subfunctions:true ppf wsb - -end - -module Prevented = struct - type t = - | Function_prevented_from_inlining - | Level_exceeded - - let summary ppf = function - | Function_prevented_from_inlining -> - Format.pp_print_text ppf - "This function was prevented from inlining or specialising." - | Level_exceeded -> - Format.pp_print_text ppf - "This function was prevented from inlining or specialising \ - because the inlining depth was exceeded." -end - -module Decision = struct - type t = - | Prevented of Prevented.t - | Specialised of Specialised.t - | Inlined of Not_specialised.t * Inlined.t - | Unchanged of Not_specialised.t * Not_inlined.t - - let summary ppf = function - | Prevented p -> - Prevented.summary ppf p - | Specialised s -> - Specialised.summary ppf s - | Inlined (s, i) -> - Format.fprintf ppf "@[@[%a@]@;@;@[%a@]@]" - Not_specialised.summary s Inlined.summary i - | Unchanged (s, i) -> - Format.fprintf ppf "@[@[%a@]@;@;@[%a@]@]" - Not_specialised.summary s Not_inlined.summary i - - let calculation ~depth ppf = function - | Prevented _ -> () - | Specialised s -> - Specialised.calculation ~depth ppf s - | Inlined (s, i) -> - Not_specialised.calculation ~depth ppf s; - Inlined.calculation ~depth ppf i - | Unchanged (s, i) -> - Not_specialised.calculation ~depth ppf s; - Not_inlined.calculation ~depth ppf i -end diff --git a/middle_end/flambda/inlining_stats_types.mli b/middle_end/flambda/inlining_stats_types.mli deleted file mode 100644 index 9d476c8981f..00000000000 --- a/middle_end/flambda/inlining_stats_types.mli +++ /dev/null @@ -1,89 +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"] - -(* Types used for producing statistics about inlining. *) - -module Inlined : sig - type t = - | Classic_mode - | Annotation - | Decl_local_to_application - | Without_subfunctions of - Inlining_cost.Whether_sufficient_benefit.t - | With_subfunctions of - Inlining_cost.Whether_sufficient_benefit.t - * Inlining_cost.Whether_sufficient_benefit.t -end - -module Not_inlined : sig - type t = - | Classic_mode - | Above_threshold of int - | Annotation - | No_useful_approximations - | Unrolling_depth_exceeded - | Self_call - | Without_subfunctions of - Inlining_cost.Whether_sufficient_benefit.t - | With_subfunctions of - Inlining_cost.Whether_sufficient_benefit.t - * Inlining_cost.Whether_sufficient_benefit.t -end - -module Specialised : sig - type t = - | Annotation - | Without_subfunctions of - Inlining_cost.Whether_sufficient_benefit.t - | With_subfunctions of - Inlining_cost.Whether_sufficient_benefit.t - * Inlining_cost.Whether_sufficient_benefit.t -end - -module Not_specialised : sig - type t = - | Classic_mode - | Above_threshold of int - | Annotation - | Not_recursive - | Not_closed - | No_invariant_parameters - | No_useful_approximations - | Self_call - | Not_beneficial of - Inlining_cost.Whether_sufficient_benefit.t - * Inlining_cost.Whether_sufficient_benefit.t -end - -module Prevented : sig - type t = - | Function_prevented_from_inlining - | Level_exceeded -end - -module Decision : sig - - type t = - | Prevented of Prevented.t - | Specialised of Specialised.t - | Inlined of Not_specialised.t * Inlined.t - | Unchanged of Not_specialised.t * Not_inlined.t - - val summary : Format.formatter -> t -> unit - val calculation : depth:int -> Format.formatter -> t -> unit -end diff --git a/middle_end/flambda/inlining_transforms.ml b/middle_end/flambda/inlining_transforms.ml deleted file mode 100644 index 1ae47aa1d02..00000000000 --- a/middle_end/flambda/inlining_transforms.ml +++ /dev/null @@ -1,696 +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-66"] -open! Int_replace_polymorphic_compare - -module B = Inlining_cost.Benefit -module E = Inline_and_simplify_aux.Env -module R = Inline_and_simplify_aux.Result -module A = Simple_value_approx - -let new_var name = - Variable.create name - ~current_compilation_unit:(Compilation_unit.get_current_exn ()) - -(** Fold over all variables bound by the given closure, which is bound to the - variable [lhs_of_application], and corresponds to the given - [function_decls]. Each variable bound by the closure is passed to the - user-specified function as an [Flambda.named] value that projects the - variable from its closure. *) -let fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied - ~lhs_of_application ~bound_variables - ~(free_vars : Flambda.specialised_to Variable.Map.t) ~init ~f = - Variable.Set.fold (fun var acc -> - let expr : Flambda.named = - Project_var { - closure = lhs_of_application; - closure_id = closure_id_being_applied; - var = Var_within_closure.wrap var; - kind = (Variable.Map.find var free_vars).kind; - } - in - f ~acc ~var ~expr) - bound_variables - init - -let set_inlined_attribute_on_all_apply body inlined specialise probe = - Flambda_iterators.map_toplevel_expr (function - | Apply apply -> Apply { apply with inlined; specialise; probe } - | expr -> expr) - body - -(** Assign fresh names for a function's parameters and rewrite the body to - use these new names. *) -let copy_of_function's_body_with_freshened_params env - ~(function_decl : A.function_declaration) - ~(function_body : A.function_body) = - let params = function_decl.params in - let param_vars = Parameter.List.vars params in - (* We cannot avoid the substitution in the case where we are inlining - inside the function itself. This can happen in two ways: either - (a) we are inlining the function itself directly inside its declaration; - or (b) we are inlining the function into an already-inlined copy. - For (a) we cannot short-cut the substitution by freshening since the - original [params] may still be referenced; for (b) we cannot do it - either since the freshening may already be renaming the parameters for - the first inlining of the function. *) - if E.does_not_bind env param_vars - && E.does_not_freshen env param_vars - then - params, function_body.body - else - let freshened_params = List.map (fun p -> Parameter.rename p) params in - let subst = - Variable.Map.of_list - (List.combine param_vars (Parameter.List.vars freshened_params)) - in - let body = Flambda_utils.toplevel_substitution subst function_body.body in - freshened_params, body - -(* CR-soon mshinwell: Add a note somewhere to explain why "bound by the closure" - does not include the function identifiers for other functions in the same - set of closures. - mshinwell: The terminology may be used inconsistently. *) - -(** Inline a function by copying its body into a context where it becomes - closed. That is to say, we bind the free variables of the body - (= "variables bound by the closure"), and any function identifiers - introduced by the corresponding set of closures. *) -let inline_by_copying_function_body ~env ~r - ~lhs_of_application - ~(inlined_requested : Lambda.inlined_attribute) - ~(specialise_requested : Lambda.specialise_attribute) - ~(probe_requested : Lambda.probe) - ~closure_id_being_applied - ~(function_decl : A.function_declaration) - ~(function_body : A.function_body) - ~fun_vars - ~(free_vars : Flambda.specialised_to Variable.Map.t) - ~args ~dbg ~reg_close ~mode:_ ~simplify = - assert (E.mem env lhs_of_application); - assert (List.for_all (E.mem env) args); - let r = - if function_body.stub then r - else R.map_benefit r B.remove_call - in - let freshened_params, body = - copy_of_function's_body_with_freshened_params env - ~function_decl ~function_body - in - let body = - let default_inline = - Lambda.equal_inlined_attribute inlined_requested Default_inlined - in - let default_specialise = - Lambda.equal_specialise_attribute specialise_requested Default_specialise - in - if function_body.stub - && ((not default_inline) || (not default_specialise) || - Option.is_some probe_requested) then - (* When the function inlined function is a stub, the annotation - is reported to the function applications inside the stub. - This allows reporting the annotation to the application the - original programmer really intended: the stub is not visible - in the source. *) - set_inlined_attribute_on_all_apply body - inlined_requested specialise_requested probe_requested - else - body - in - let body = - match reg_close with - | Lambda.Rc_close_at_apply -> Flambda.Exclave body - | Lambda.Rc_normal | Lambda.Rc_nontail -> body - in - let bindings_for_params_to_args = - (* Bind the function's parameters to the arguments from the call site. *) - let args = List.map (fun arg -> Flambda.Expr (Var arg)) args in - Flambda_utils.bind ~body - ~bindings:(List.combine (Parameter.List.vars freshened_params) args) - in - (* Add bindings for the variables bound by the closure. *) - let bindings_for_vars_bound_by_closure_and_params_to_args = - let bound_variables = - let params = Parameter.Set.vars function_decl.params in - Variable.Set.diff - (Variable.Set.diff function_body.free_variables params) - fun_vars - in - fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied - ~lhs_of_application ~bound_variables ~init:bindings_for_params_to_args - ~f:(fun ~acc:body ~var ~expr -> Flambda.create_let var expr body) - ~free_vars - in - (* Add bindings for variables corresponding to the functions introduced by - the whole set of closures. Each such variable will be bound to a closure; - each such closure is in turn produced by moving from the closure being - applied to another closure in the same set. - *) - let expr = - Variable.Set.fold (fun another_closure_in_the_same_set expr -> - let used = - Variable.Set.mem another_closure_in_the_same_set - function_body.free_variables - in - if used then - Flambda.create_let another_closure_in_the_same_set - (Move_within_set_of_closures { - closure = lhs_of_application; - start_from = closure_id_being_applied; - move_to = Closure_id.wrap another_closure_in_the_same_set; - }) - expr - else expr) - fun_vars - bindings_for_vars_bound_by_closure_and_params_to_args - in - let env = E.set_never_inline env in - let env = E.activate_freshening env in - let env = E.set_inline_debuginfo ~dbg env in - simplify env r expr - -type state = { - old_inside_to_new_inside : Variable.t Variable.Map.t; - (* Map from old inner vars to new inner vars *) - old_outside_to_new_outside : Variable.t Variable.Map.t; - (* Map from old outer vars to new outer vars *) - old_params_to_new_outside : Variable.t Variable.Map.t; - (* Map from old parameters to new outer vars. These are params - that should be specialised if they are copied to the new set of - closures. *) - old_fun_var_to_new_fun_var : Variable.t Variable.Map.t; - (* Map from old fun vars to new fun vars. These are the functions - that will be copied into the new set of closures *) - let_bindings : (Variable.t * Flambda.named) list; - (* Let bindings that will surround the definition of the new set - of closures *) - to_copy : Variable.t list; - (* List of functions that still need to be copied to the new set - of closures *) - new_funs : Flambda.function_declaration Variable.Map.t; - (* The function declarations for the new set of closures *) - new_free_vars_with_old_projections : Flambda.specialised_to Variable.Map.t; - (* The free variables for the new set of closures, but the projection - fields still point to old free variables. *) - new_specialised_args_with_old_projections : - Flambda.specialised_to Variable.Map.t; - (* The specialised parameters for the new set of closures, but the - projection fields still point to old specialised parameters. *) -} - -let empty_state = - { to_copy = []; - old_inside_to_new_inside = Variable.Map.empty; - old_outside_to_new_outside = Variable.Map.empty; - old_params_to_new_outside = Variable.Map.empty; - old_fun_var_to_new_fun_var = Variable.Map.empty; - let_bindings = []; - new_funs = Variable.Map.empty; - new_free_vars_with_old_projections = Variable.Map.empty; - new_specialised_args_with_old_projections = Variable.Map.empty; } - -(* Add let bindings for the free vars in the set_of_closures and - add them to [old_outside_to_new_outside] *) -let bind_free_vars ~lhs_of_application ~closure_id_being_applied - ~state ~free_vars = - Variable.Map.fold - (fun free_var (spec : Flambda.specialised_to) state -> - let var_clos = new_var Internal_variable_names.from_closure in - let expr : Flambda.named = - Project_var { - closure = lhs_of_application; - closure_id = closure_id_being_applied; - var = Var_within_closure.wrap free_var; - kind = spec.kind; - } - in - let let_bindings = (var_clos, expr) :: state.let_bindings in - let old_outside_to_new_outside = - Variable.Map.add spec.var var_clos state.old_outside_to_new_outside - in - { state with let_bindings; old_outside_to_new_outside }) - free_vars state - -(* For arguments of specialised parameters: - - Add them to [old_outside_to_new_outside] - - Add them and their invariant aliases to [old_params_to_new_outside] - For other arguments that are also worth specialising: - - Add them and their invariant aliases to [old_params_to_new_outside] *) -let register_arguments ~specialised_args ~invariant_params - ~state ~params ~args ~args_approxs = - let rec loop ~state ~params ~args ~args_approxs = - match params, args, args_approxs with - | [], [], [] -> state - | param :: params, arg :: args, arg_approx :: args_approxs -> begin - let param = Parameter.var param in - let worth_specialising, old_outside_to_new_outside = - match Variable.Map.find_opt param specialised_args with - | Some (spec : Flambda.specialised_to) -> - let old_outside_to_new_outside = - Variable.Map.add spec.var arg state.old_outside_to_new_outside - in - true, old_outside_to_new_outside - | None -> - let worth_specialising = - A.useful arg_approx - && Variable.Map.mem param (Lazy.force invariant_params) - in - worth_specialising, state.old_outside_to_new_outside - in - let old_params_to_new_outside = - if worth_specialising then begin - let old_params_to_new_outside = - Variable.Map.add param arg state.old_params_to_new_outside - in - match Variable.Map.find_opt param (Lazy.force invariant_params) with - | Some set -> - Variable.Set.fold - (fun elem acc -> Variable.Map.add elem arg acc) - set old_params_to_new_outside - | None -> - old_params_to_new_outside - end else begin - state.old_params_to_new_outside - end - in - let state = - { state with old_outside_to_new_outside; old_params_to_new_outside } - in - loop ~state ~params ~args ~args_approxs - end - | _, _, _ -> assert false - in - loop ~state ~params ~args ~args_approxs - -(* Add an old parameter to [old_inside_to_new_inside]. If it appears in - [old_params_to_new_outside] then also add it to the new specialised args. *) -let add_param ~specialised_args ~state ~param = - let alloc_mode = Parameter.alloc_mode param in - let kind = Parameter.kind param in - let param = Parameter.var param in - let new_param = Variable.rename param in - let old_inside_to_new_inside = - Variable.Map.add param new_param state.old_inside_to_new_inside - in - let new_specialised_args_with_old_projections = - match Variable.Map.find_opt param specialised_args with - | Some (spec : Flambda.specialised_to) -> - let new_outside_var = - Variable.Map.find spec.var state.old_outside_to_new_outside - in - let new_spec : Flambda.specialised_to = - { spec with var = new_outside_var } - in - Variable.Map.add new_param new_spec - state.new_specialised_args_with_old_projections - | None -> begin - match Variable.Map.find_opt param state.old_params_to_new_outside with - | None -> state.new_specialised_args_with_old_projections - | Some new_outside_var -> - let new_spec : Flambda.specialised_to = - { var = new_outside_var; projection = None; kind } - in - Variable.Map.add new_param new_spec - state.new_specialised_args_with_old_projections - end - in - let state = - { state with old_inside_to_new_inside; - new_specialised_args_with_old_projections } - in - state, Parameter.wrap new_param alloc_mode kind - -(* Add a let binding for an old fun_var, add it to the new free variables, and - add it to [old_inside_to_new_inside] *) -let add_fun_var ~lhs_of_application ~closure_id_being_applied ~state ~fun_var = - if Variable.Map.mem fun_var state.old_inside_to_new_inside then state - else begin - let inside_var = Variable.rename fun_var in - let outside_var = Variable.create Internal_variable_names.closure in - let expr = - Flambda.Move_within_set_of_closures - { closure = lhs_of_application; - start_from = closure_id_being_applied; - move_to = Closure_id.wrap fun_var; } - in - let let_bindings = (outside_var, expr) :: state.let_bindings in - let spec : Flambda.specialised_to = - { var = outside_var; projection = None; kind = Lambda.layout_function } - in - let new_free_vars_with_old_projections = - Variable.Map.add inside_var spec state.new_free_vars_with_old_projections - in - let old_inside_to_new_inside = - Variable.Map.add fun_var inside_var state.old_inside_to_new_inside - in - { state with - old_inside_to_new_inside; let_bindings; - new_free_vars_with_old_projections } - end - -(* Add an old free_var to the new free variables and add it to - [old_inside_to_new_inside]. *) -let add_free_var ~free_vars ~state ~free_var = - if Variable.Map.mem free_var state.old_inside_to_new_inside then state - else begin - let spec : Flambda.specialised_to = Variable.Map.find free_var free_vars in - let outside_var = spec.var in - let new_outside_var = - Variable.Map.find outside_var state.old_outside_to_new_outside - in - let new_spec : Flambda.specialised_to = - { spec with var = new_outside_var } - in - let new_inside_var = Variable.rename free_var in - let new_free_vars_with_old_projections = - Variable.Map.add new_inside_var new_spec - state.new_free_vars_with_old_projections - in - let old_inside_to_new_inside = - Variable.Map.add free_var new_inside_var state.old_inside_to_new_inside - in - { state with old_inside_to_new_inside; new_free_vars_with_old_projections } - end - -(* Add a function to the new set of closures iff: - 1) All it's specialised parameters are available in - [old_outside_to_new_outside] - 2) At least one more parameter will become specialised *) -let add_function ~specialised_args ~state ~fun_var ~function_decl = - match function_decl.A.function_body with - | None -> None - | Some _ -> begin - let rec loop worth_specialising = function - | [] -> worth_specialising - | param :: params -> begin - let param = Parameter.var param in - match Variable.Map.find_opt param specialised_args with - | Some (spec : Flambda.specialised_to) -> - Variable.Map.mem spec.var state.old_outside_to_new_outside - && loop worth_specialising params - | None -> - let worth_specialising = - worth_specialising - || Variable.Map.mem param state.old_params_to_new_outside - in - loop worth_specialising params - end - in - let worth_specialising = loop false function_decl.A.params in - if not worth_specialising then None - else begin - let new_fun_var = Variable.rename fun_var in - let old_fun_var_to_new_fun_var = - Variable.Map.add fun_var new_fun_var state.old_fun_var_to_new_fun_var - in - let to_copy = fun_var :: state.to_copy in - let state = { state with old_fun_var_to_new_fun_var; to_copy } in - Some (state, new_fun_var) - end - end - -(* Lookup a function in the new set of closures, trying to add it if - necessary. *) -let lookup_function ~specialised_args ~state ~fun_var ~function_decl = - match Variable.Map.find_opt fun_var state.old_fun_var_to_new_fun_var with - | Some new_fun_var -> Some (state, new_fun_var) - | None -> add_function ~specialised_args ~state ~fun_var ~function_decl - -(* A direct call to a function in the new set of closures can be specialised - if all the function's newly specialised parameters are passed arguments - that are specialised to the same outside variable *) -let specialisable_call ~specialised_args ~state ~args ~params = - List.for_all2 - (fun arg param -> - let param = Parameter.var param in - if Variable.Map.mem param specialised_args then true - else begin - let old_params_to_new_outside = state.old_params_to_new_outside in - match Variable.Map.find_opt param old_params_to_new_outside with - | None -> true - | Some outside_var -> begin - match Variable.Map.find_opt arg old_params_to_new_outside with - | Some outside_var' -> - Variable.equal outside_var outside_var' - | None -> false - end - end) - args params - -(* Rewrite a call iff: - 1) It is to a function in the old set of closures that can be specialised - 2) All the newly specialised parameters of that function are passed values - known to be equal to their new specialisation. *) -let rec rewrite_direct_call ~specialised_args ~funs ~direct_call_surrogates - ~state ~closure_id ~(apply : Flambda.apply) = - match Closure_id.Map.find_opt closure_id direct_call_surrogates with - | Some closure_id -> - rewrite_direct_call ~specialised_args ~funs ~direct_call_surrogates - ~state ~closure_id ~apply - | None -> begin - let fun_var = Closure_id.unwrap closure_id in - match Variable.Map.find_opt fun_var funs with - | None -> None - | Some function_decl -> begin - match - lookup_function ~specialised_args ~state ~fun_var ~function_decl - with - | None -> None - | Some (state, new_fun_var) -> begin - let args = apply.args in - let params = function_decl.A.params in - let specialisable = - specialisable_call ~specialised_args ~state ~args ~params - in - if not specialisable then None - else begin - let kind = Flambda.Direct (Closure_id.wrap new_fun_var) in - let apply = { apply with func = new_fun_var; kind } in - Some (state, Flambda.Apply apply) - end - end - end - end - -(* Rewrite the body a function declaration for use in the new set of - closures. *) -let rewrite_function ~lhs_of_application ~closure_id_being_applied - ~direct_call_surrogates ~specialised_args ~free_vars ~funs - ~state fun_var = - let function_decl : A.function_declaration = - Variable.Map.find fun_var funs - in - let function_body = - match function_decl.function_body with - | None -> assert false - | Some function_body -> function_body - in - let new_fun_var = - Variable.Map.find fun_var state.old_fun_var_to_new_fun_var - in - let state, params = - List.fold_right - (fun param (state, params) -> - let state, param = add_param ~specialised_args ~state ~param in - (state, param :: params)) - function_decl.params (state, []) - in - let state = - Variable.Set.fold - (fun var state -> - if Variable.Map.mem var funs then - add_fun_var ~lhs_of_application ~closure_id_being_applied - ~state ~fun_var:var - else if Variable.Map.mem var free_vars then - add_free_var ~free_vars ~state ~free_var:var - else - state) - function_body.free_variables state - in - let state_ref = ref state in - let body = - Flambda_iterators.map_toplevel_expr - (fun (expr : Flambda.t) -> - match expr with - | Apply ({ kind = Direct closure_id } as apply) -> begin - match - rewrite_direct_call ~specialised_args ~funs - ~direct_call_surrogates ~state:!state_ref ~closure_id ~apply - with - | None -> expr - | Some (state, expr) -> - state_ref := state; - expr - end - | _ -> expr) - function_body.body - in - let body = - Flambda_utils.toplevel_substitution state.old_inside_to_new_inside body - in - let new_function_decl = - Flambda.create_function_declaration - ~params ~alloc_mode:function_decl.alloc_mode ~region:function_decl.region - ~body - ~return_layout:function_decl.return_layout - ~stub:function_body.stub - ~inline:function_body.inline - ~specialise:function_body.specialise - ~check:function_body.check - ~is_a_functor:function_body.is_a_functor - ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var)) - ~poll:function_body.poll - in - let new_funs = - Variable.Map.add new_fun_var new_function_decl state.new_funs - in - let state = { !state_ref with new_funs } in - state - -let update_projections ~state projections = - let old_to_new = state.old_inside_to_new_inside in - Variable.Map.map - (fun (spec_to : Flambda.specialised_to) -> - let projection : Projection.t option = - match spec_to.projection with - | None -> None - | Some (Project_var proj) -> begin - match Variable.Map.find_opt proj.closure old_to_new with - | None -> None - | Some closure -> - let proj = { proj with closure } in - Some (Projection.Project_var proj) - end - | Some (Project_closure proj) -> begin - match Variable.Map.find_opt proj.set_of_closures old_to_new with - | None -> None - | Some set_of_closures -> - let proj = { proj with set_of_closures } in - Some (Projection.Project_closure proj) - end - | Some (Move_within_set_of_closures proj) -> begin - match Variable.Map.find_opt proj.closure old_to_new with - | None -> None - | Some closure -> - let proj = { proj with closure } in - Some (Projection.Move_within_set_of_closures proj) - end - | Some (Field (index, var)) -> begin - match Variable.Map.find_opt var old_to_new with - | None -> None - | Some var -> Some (Projection.Field(index, var)) - end - in - { spec_to with projection }) - projections - -(* CR-soon mshinwell: Somewhere there should be a description about - the specialisation of probe handlers. This file is probably a - reasonable place, with a short comment citing this file to be added - in [Translcore] where [Always_specialise] is set. *) - -let inline_by_copying_function_declaration - ~(env : Inline_and_simplify_aux.Env.t) - ~(r : Inline_and_simplify_aux.Result.t) - ~(function_decls : A.function_declarations) - ~(lhs_of_application : Variable.t) - ~(inlined_requested : Lambda.inlined_attribute) - ~(probe_requested: Lambda.probe) - ~(closure_id_being_applied : Closure_id.t) - ~(function_decl : A.function_declaration) - ~(args : Variable.t list) - ~(args_approxs : A.t list) - ~(invariant_params : Variable.Set.t Variable.Map.t lazy_t) - ~(specialised_args : Flambda.specialised_to Variable.Map.t) - ~(free_vars : Flambda.specialised_to Variable.Map.t) - ~(direct_call_surrogates : Closure_id.t Closure_id.Map.t) - ~(dbg : Debuginfo.t) - ~(reg_close : Lambda.region_close) - ~(mode : Lambda.alloc_mode) - ~(simplify : Inlining_decision_intf.simplify) = - let state = empty_state in - let state = - bind_free_vars ~lhs_of_application ~closure_id_being_applied - ~state ~free_vars - in - let params = function_decl.params in - let state = - register_arguments ~specialised_args ~invariant_params - ~state ~params ~args ~args_approxs - in - let fun_var = Closure_id.unwrap closure_id_being_applied in - match add_function ~specialised_args ~state ~fun_var ~function_decl with - | None -> None - | Some (state, new_fun_var) -> begin - let funs = function_decls.funs in - let rec loop state = - match state.to_copy with - | [] -> state - | next :: rest -> - let state = { state with to_copy = rest } in - let state = - rewrite_function ~lhs_of_application ~closure_id_being_applied - ~direct_call_surrogates ~specialised_args ~free_vars ~funs - ~state next - in - loop state - in - let state = loop state in - let closure_id = Closure_id.wrap new_fun_var in - let function_decls = - Flambda.create_function_declarations_with_origin - ~funs:state.new_funs - ~set_of_closures_origin:function_decls.set_of_closures_origin - ~is_classic_mode:function_decls.is_classic_mode - in - let free_vars = - update_projections ~state - state.new_free_vars_with_old_projections - in - let specialised_args = - update_projections ~state - state.new_specialised_args_with_old_projections - in - let direct_call_surrogates = Variable.Map.empty in - let set_of_closures = - Flambda.create_set_of_closures ~function_decls - ~free_vars ~specialised_args ~direct_call_surrogates - in - let closure_var = new_var Internal_variable_names.dup_func in - let set_of_closures_var = - new_var Internal_variable_names.dup_set_of_closures - in - let project : Flambda.project_closure = - {set_of_closures = set_of_closures_var; closure_id} - in - let apply : Flambda.apply = - { func = closure_var; args; kind = Direct closure_id; dbg; - reg_close; mode; result_layout = function_decl.return_layout; - inlined = inlined_requested; specialise = Default_specialise; - probe = probe_requested; - } - in - let body = - Flambda.create_let - set_of_closures_var (Set_of_closures set_of_closures) - (Flambda.create_let closure_var (Project_closure project) - (Apply apply)) - in - let expr = Flambda_utils.bind ~body ~bindings:state.let_bindings in - let env = E.activate_freshening (E.set_never_inline env) in - Some (simplify env r expr) - end diff --git a/middle_end/flambda/inlining_transforms.mli b/middle_end/flambda/inlining_transforms.mli deleted file mode 100644 index 518e4e71098..00000000000 --- a/middle_end/flambda/inlining_transforms.mli +++ /dev/null @@ -1,112 +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"] - -(** Source code transformations used during inlining. *) - -(** Inline a function by substituting its body (which may be subject to - further transformation) at a call site. The function's declaration is - not copied. - - This transformation is used when: - - inlining a call to a non-recursive function; - - inlining a call, within a recursive or mutually-recursive function, to - the same or another function being defined simultaneously ("unrolling"). - The maximum depth of unrolling is bounded (see [E.unrolling_allowed]). - - In both cases, the body of the function is copied, within a sequence of - [let]s that bind the function parameters, the variables "bound by the - closure" (see flambda.mli), and any function identifiers introduced by the - set of closures. These stages are delimited below by comments. - - As an example, suppose we are inlining the following function: - - let f x = x + y - ... - let p = f, f in - (fst p) 42 - - The call site [ (fst p) 42] will be transformed to: - - let clos_id = fst p in (* must eventually yield a closure *) - let y = in - let x' = 42 in - let x = x' in - x + y - - When unrolling a recursive function we rename the arguments to the - recursive call in order to avoid clashes with existing bindings. For - example, suppose we are inlining the following call to [f], which lies - within its own declaration: - - let rec f x y = - f (fst x) (y + snd x) - - This will be transformed to: - - let rec f x y = - let clos_id = f in (* not used this time, since [f] has no free vars *) - let x' = fst x in - let y' = y + snd x in - f (fst x') (y' + snd x') (* body of [f] with parameters freshened *) -*) -val inline_by_copying_function_body - : env:Inline_and_simplify_aux.Env.t - -> r:Inline_and_simplify_aux.Result.t - -> lhs_of_application:Variable.t - -> inlined_requested:Lambda.inlined_attribute - -> specialise_requested:Lambda.specialise_attribute - -> probe_requested:Lambda.probe - -> closure_id_being_applied:Closure_id.t - -> function_decl:Simple_value_approx.function_declaration - -> function_body:Simple_value_approx.function_body - -> fun_vars:Variable.Set.t - -> free_vars:Flambda.specialised_to Variable.Map.t - -> args:Variable.t list - -> dbg:Debuginfo.t - -> reg_close:Lambda.region_close - -> mode:Lambda.alloc_mode - -> simplify:Inlining_decision_intf.simplify - -> Flambda.t * Inline_and_simplify_aux.Result.t - -(** Inlining of recursive function(s) yields a copy of the functions' - definitions (not just their bodies, unlike the non-recursive case) and - a direct application of the new body. - Note: the function really does need to be recursive (but possibly only via - some mutual recursion) to end up in here; a simultaneous binding [that is - non-recursive] is not sufficient. -*) -val inline_by_copying_function_declaration - : env:Inline_and_simplify_aux.Env.t - -> r:Inline_and_simplify_aux.Result.t - -> function_decls:Simple_value_approx.function_declarations - -> lhs_of_application:Variable.t - -> inlined_requested:Lambda.inlined_attribute - -> probe_requested:Lambda.probe - -> closure_id_being_applied:Closure_id.t - -> function_decl:Simple_value_approx.function_declaration - -> args:Variable.t list - -> args_approxs:Simple_value_approx.t list - -> invariant_params:Variable.Set.t Variable.Map.t lazy_t - -> specialised_args:Flambda.specialised_to Variable.Map.t - -> free_vars:Flambda.specialised_to Variable.Map.t - -> direct_call_surrogates:Closure_id.t Closure_id.Map.t - -> dbg:Debuginfo.t - -> reg_close:Lambda.region_close - -> mode:Lambda.alloc_mode - -> simplify:Inlining_decision_intf.simplify - -> (Flambda.t * Inline_and_simplify_aux.Result.t) option diff --git a/middle_end/flambda/invariant_params.ml b/middle_end/flambda/invariant_params.ml deleted file mode 100644 index 890f65b6c3b..00000000000 --- a/middle_end/flambda/invariant_params.ml +++ /dev/null @@ -1,417 +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-66"] -open! Int_replace_polymorphic_compare - -(* CR-someday pchambart to pchambart: in fact partial application doesn't - work because there are no 'known' partial application left: they are - converted to applications new partial function declaration. - That can be improved (and many other cases) by keeping track of aliases in - closure of functions. *) - -(* These analyses are computed in two steps: - * accumulate the atomic <- relations - * compute the least-fixed point - - The <- relation is represented by the type - - t Variable.Pair.Map.t - - if [Variable.Pair.Map.find (f, x) relation = Top] then (f, x) <- Top - is in the relation. - - if [Variable.Pair.Map.find (f, x) relation = Implication s] and - [Variable.Pair.Set.mem (g, y) s] then (f, x) <- (g, y) is in the - relation. -*) - -type t = - | Top - | Implication of Variable.Pair.Set.t - -let _print ppf = function - | Top -> Format.fprintf ppf "Top" - | Implication args -> - Format.fprintf ppf "Implication: @[%a@]" - Variable.Pair.Set.print args - -let top relation p = - Variable.Pair.Map.add p Top relation - -let implies relation from to_ = - match Variable.Pair.Map.find to_ relation with - | Top -> relation - | Implication set -> - Variable.Pair.Map.add to_ - (Implication (Variable.Pair.Set.add from set)) - relation - | exception Not_found -> - Variable.Pair.Map.add to_ - (Implication (Variable.Pair.Set.singleton from)) - relation - -let transitive_closure state = - let union s1 s2 = - match s1, s2 with - | Top, _ | _, Top -> Top - | Implication s1, Implication s2 -> - Implication (Variable.Pair.Set.union s1 s2) - in - let equal s1 s2 = - match s1, s2 with - | Top, Implication _ | Implication _, Top -> false - | Top, Top -> true - | Implication s1, Implication s2 -> Variable.Pair.Set.equal s1 s2 - in - let update arg state = - let original_set = - try Variable.Pair.Map.find arg state with - | Not_found -> Implication Variable.Pair.Set.empty - in - match original_set with - | Top -> state - | Implication arguments -> - let set = - Variable.Pair.Set.fold - (fun orig acc-> - let set = - try Variable.Pair.Map.find orig state with - | Not_found -> Implication Variable.Pair.Set.empty in - union set acc) - arguments original_set - in - Variable.Pair.Map.add arg set state - in - let once state = - Variable.Pair.Map.fold (fun arg _ state -> update arg state) state state - in - let rec fp state = - let state' = once state in - if Variable.Pair.Map.equal equal state state' - then state - else fp state' - in - fp state - -(* CR-soon pchambart: to move to Flambda_utils and document - mshinwell: I think this calculation is basically the same as - [Flambda_utils.fun_vars_referenced_in_decls], so we should try - to share code. However let's defer until after 4.03. (And note CR - below.) -*) -(* Finds variables that represent the functions. - In a construction like: - let f x = - let g = Symbol f_closure in - .. - the variable g is bound to the symbol f_closure which - is the current closure. - The result of [function_variable_alias] will contain - the association [g -> f] -*) -let function_variable_alias - (function_decls : Flambda.function_declarations) = - let fun_vars = Variable.Map.keys function_decls.funs in - let symbols_to_fun_vars = - Variable.Set.fold (fun fun_var symbols_to_fun_vars -> - let closure_id = Closure_id.wrap fun_var in - let symbol = Symbol_utils.Flambda.for_closure closure_id in - Symbol.Map.add symbol fun_var symbols_to_fun_vars) - fun_vars - Symbol.Map.empty - in - let fun_var_bindings = ref Variable.Map.empty in - Variable.Map.iter (fun _ ( function_decl : Flambda.function_declaration ) -> - Flambda_iterators.iter_all_toplevel_immutable_let_and_let_rec_bindings - ~f:(fun var named -> - (* CR-soon mshinwell: consider having the body passed to this - function and using fv calculation instead of used_variables. - Need to be careful of "let rec" *) - match named with - | Symbol sym -> - begin match Symbol.Map.find sym symbols_to_fun_vars with - | exception Not_found -> () - | fun_var -> - fun_var_bindings := - Variable.Map.add var fun_var !fun_var_bindings - end - | _ -> ()) - function_decl.body) - function_decls.funs; - !fun_var_bindings - -let analyse_functions ~param_to_param - ~anything_to_param ~param_to_anywhere - (decls : Flambda.function_declarations) = - let function_variable_alias = function_variable_alias decls in - let param_indexes_by_fun_vars = - Variable.Map.map (fun (decl : Flambda.function_declaration) -> - Array.of_list (Parameter.List.vars decl.params)) - decls.funs - in - let find_callee_arg ~callee ~callee_pos = - match Variable.Map.find callee param_indexes_by_fun_vars with - | exception Not_found -> None (* not a recursive call *) - | arr -> - (* Ignore overapplied parameters: they are applied to a different - function. *) - if callee_pos < Array.length arr then Some arr.(callee_pos) - else None - in - let escaping_functions = Variable.Tbl.create 13 in - let escaping_function fun_var = - let fun_var = - match Variable.Map.find fun_var function_variable_alias with - | exception Not_found -> fun_var - | fun_var -> fun_var - in - if Variable.Map.mem fun_var decls.funs - then Variable.Tbl.add escaping_functions fun_var (); - in - let used_variables = Variable.Tbl.create 42 in - let used_variable var = Variable.Tbl.add used_variables var () in - let relation = ref Variable.Pair.Map.empty in - (* If the called closure is in the current set of closures, record the - relation (callee, callee_arg) <- (caller, caller_arg) *) - let check_argument ~caller ~callee ~callee_pos ~caller_arg = - escaping_function caller_arg; - match find_callee_arg ~callee ~callee_pos with - | None -> used_variable caller_arg (* not a recursive call *) - | Some callee_arg -> - match Variable.Map.find caller decls.funs with - | exception Not_found -> - assert false - | { params } -> - let new_relation = - (* We only track dataflow for parameters of functions, not - arbitrary variables. *) - if List.exists - (fun param -> Variable.equal (Parameter.var param) caller_arg) - params - then - param_to_param ~caller ~caller_arg ~callee ~callee_arg !relation - else begin - used_variable caller_arg; - anything_to_param ~callee ~callee_arg !relation - end - in - relation := new_relation - in - let arity ~callee = - match Variable.Map.find callee decls.funs with - | exception Not_found -> 0 - | func -> Flambda_utils.function_arity func - in - let check_expr ~caller (expr : Flambda.t) = - match expr with - | Apply { func; args } -> - used_variable func; - let callee = - match Variable.Map.find func function_variable_alias with - | exception Not_found -> func - | callee -> callee - in - let num_args = List.length args in - for callee_pos = num_args to (arity ~callee) - 1 do - (* If a function is partially applied, consider all missing - arguments as "anything". *) - match find_callee_arg ~callee ~callee_pos with - | None -> () - | Some callee_arg -> - relation := anything_to_param ~callee ~callee_arg !relation - done; - List.iteri (fun callee_pos caller_arg -> - check_argument ~caller ~callee ~callee_pos ~caller_arg) - args - | _ -> () - in - Variable.Map.iter (fun caller (decl : Flambda.function_declaration) -> - Flambda_iterators.iter (check_expr ~caller) - (fun (_ : Flambda.named) -> ()) - decl.body; - Variable.Set.iter - (fun var -> escaping_function var; used_variable var) - (* CR-soon mshinwell: we should avoid recomputing this, cache in - [function_declaration]. See also comment on - [only_via_symbols] in [Flambda_utils]. *) - (Flambda.free_variables ~ignore_uses_as_callee:() - ~ignore_uses_as_argument:() decl.body)) - decls.funs; - Variable.Map.iter - (fun func_var ({ params } : Flambda.function_declaration) -> - List.iter - (fun (param : Parameter.t) -> - if Variable.Tbl.mem used_variables (Parameter.var param) then - relation := - param_to_anywhere ~caller:func_var - ~caller_arg:(Parameter.var param) !relation; - if Variable.Tbl.mem escaping_functions func_var then - relation := - anything_to_param ~callee:func_var - ~callee_arg:(Parameter.var param) !relation) - params) - decls.funs; - transitive_closure !relation - - -(* A parameter [x] of the function [f] is considered as unchanging if - during an 'external' (call from outside the set of closures) call of - [f], every recursive call of [f] all the instances of [x] are aliased - to the original one. This function computes an underapproximation of - that set by computing the flow of parameters between the different - functions of the set of closures. - - We record [(f, x) <- (g, y)] when the function g calls f and - the y parameter of g is used as argument for the x parameter of f. For - instance in - - let rec f x = ... - and g y = f x - - We record [(f, x) <- Top] when some unknown values can flow to the - [y] parameter. - - let rec f x = f 1 - - We record also [(f, x) <- Top] if [f] could escape. This is over - approximated by considering that a function escape when its variable is used - for something else than an application: - - let rec f x = (f, f) - - [x] is not unchanging if either - (f, x) <- Top - or (f, x) <- (f, y) with x != y - - Notice that having (f, x) <- (g, a) and (f, x) <- (g, b) does not make - x not unchanging. This is because (g, a) and (g, b) represent necessarily - different values only if g is the externally called function. If some - value where created during the execution of the function that could - flow to (g, a), then (g, a) <- Top, so (f, x) <- Top. - - *) - -let invariant_params_in_recursion (decls : Flambda.function_declarations) = - let param_to_param ~caller ~caller_arg ~callee ~callee_arg relation = - implies relation (caller, caller_arg) (callee, callee_arg) - in - let anything_to_param ~callee ~callee_arg relation = - top relation (callee, callee_arg) - in - let param_to_anywhere ~caller:_ ~caller_arg:_ relation = relation in - let relation = - analyse_functions ~param_to_param - ~anything_to_param ~param_to_anywhere - decls - in - let not_unchanging = - Variable.Pair.Map.fold (fun (func, var) set not_unchanging -> - match set with - | Top -> Variable.Set.add var not_unchanging - | Implication set -> - if Variable.Pair.Set.exists (fun (func', var') -> - Variable.equal func func' && not (Variable.equal var var')) - set - then Variable.Set.add var not_unchanging - else not_unchanging) - relation Variable.Set.empty - in - let params = Variable.Map.fold (fun _ - ({ params } : Flambda.function_declaration) set -> - Variable.Set.union (Parameter.Set.vars params) set) - decls.funs Variable.Set.empty - in - let unchanging = Variable.Set.diff params not_unchanging in - let aliased_to = - Variable.Pair.Map.fold (fun (_, var) set aliases -> - match set with - | Implication set - when Variable.Set.mem var unchanging -> - Variable.Pair.Set.fold (fun (_, caller_args) aliases -> - if Variable.Set.mem caller_args unchanging then - let alias_set = - match Variable.Map.find caller_args aliases with - | exception Not_found -> - Variable.Set.singleton var - | alias_set -> - Variable.Set.add var alias_set - in - Variable.Map.add caller_args alias_set aliases - else - aliases) - set aliases - | Top | Implication _ -> aliases) - relation Variable.Map.empty - in - (* We complete the set of aliases such that there does not miss any - unchanging param *) - Variable.Map.of_set (fun var -> - match Variable.Map.find var aliased_to with - | exception Not_found -> Variable.Set.empty - | set -> set) - unchanging - -let invariant_param_sources decls = - let param_to_param ~caller ~caller_arg ~callee ~callee_arg relation = - implies relation (caller, caller_arg) (callee, callee_arg) - in - let anything_to_param ~callee:_ ~callee_arg:_ relation = relation in - let param_to_anywhere ~caller:_ ~caller_arg:_ relation = relation in - let relation = - analyse_functions ~param_to_param - ~anything_to_param ~param_to_anywhere - decls - in - Variable.Pair.Map.fold (fun (_, var) set relation -> - match set with - | Top -> relation - | Implication set -> Variable.Map.add var set relation) - relation Variable.Map.empty - -let pass_name = "unused-arguments" -let () = Clflags.all_passes := pass_name :: !Clflags.all_passes - -let unused_arguments (decls : Flambda.function_declarations) = - let dump = Clflags.dumped_pass pass_name in - let param_to_param ~caller ~caller_arg ~callee ~callee_arg relation = - implies relation (callee, callee_arg) (caller, caller_arg) - in - let anything_to_param ~callee:_ ~callee_arg:_ relation = relation in - let param_to_anywhere ~caller ~caller_arg relation = - top relation (caller, caller_arg) - in - let relation = - analyse_functions ~param_to_param - ~anything_to_param ~param_to_anywhere - decls - in - let arguments = - Variable.Map.fold - (fun fun_var decl acc -> - List.fold_left - (fun acc param -> - match Variable.Pair.Map.find (fun_var, param) relation with - | exception Not_found -> Variable.Set.add param acc - | Implication _ -> Variable.Set.add param acc - | Top -> acc) - acc (Parameter.List.vars decl.Flambda.params)) - decls.funs Variable.Set.empty - in - if dump then begin - Format.printf "Unused arguments: %a@." Variable.Set.print arguments - end; - arguments diff --git a/middle_end/flambda/invariant_params.mli b/middle_end/flambda/invariant_params.mli deleted file mode 100644 index 8872bfa1ea5..00000000000 --- a/middle_end/flambda/invariant_params.mli +++ /dev/null @@ -1,54 +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"] - -(* [invariant_params_in_recursion] calculates the set of parameters whose - values are known not to change during the execution of a recursive - function. As such, occurrences of the parameters may always be replaced - by the corresponding values. - - For example, [x] would be in [invariant_params] for both of the following - functions: - - let rec f x y = (f x y) + (f x (y+1)) - - let rec f x l = List.iter (f x) l - - For invariant parameters it also computes the set of parameters of functions - in the set of closures that are always aliased to it. For example in the set - of closures: - - let rec f x y = (f x y) + (f x (y+1)) + g x - and g z = z + 1 - - The map of aliases is - - x -> { x; z } -*) -val invariant_params_in_recursion - : Flambda.function_declarations - -> Variable.Set.t Variable.Map.t - -val invariant_param_sources - : Flambda.function_declarations - -> Variable.Pair.Set.t Variable.Map.t - -(* CR-soon mshinwell: think about whether this function should - be in this file. Should it be called "unused_parameters"? *) -val unused_arguments - : Flambda.function_declarations - -> Variable.Set.t diff --git a/middle_end/flambda/lift_code.ml b/middle_end/flambda/lift_code.ml deleted file mode 100644 index cd56a4c2185..00000000000 --- a/middle_end/flambda/lift_code.ml +++ /dev/null @@ -1,182 +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-66"] -open! Int_replace_polymorphic_compare - -type lifter = Flambda.program -> Flambda.program - -type def = - | Immutable of Variable.t * Flambda.named Flambda.With_free_variables.t - | Mutable of Mutable_variable.t * Variable.t * Lambda.layout - -let rebuild_let (defs : def list) (body : Flambda.t) = - let module W = Flambda.With_free_variables in - List.fold_left (fun body def -> - match def with - | Immutable(var, def) -> - W.create_let_reusing_defining_expr var def body - | Mutable(var, initial_value, contents_kind) -> - Flambda.Let_mutable {var; initial_value; contents_kind; body}) - body defs - -let rec extract_let_expr (acc:def list) (let_expr:Flambda.let_expr) : - def list * Flambda.t Flambda.With_free_variables.t = - let module W = Flambda.With_free_variables in - let acc = - match let_expr with - | { var = v1; defining_expr = Expr (Let let2); _ } -> - let acc, body2 = extract_let_expr acc let2 in - Immutable(v1, W.expr body2) :: acc - | { var = v1; defining_expr = Expr (Let_mutable let_mut); _ } -> - let acc, body2 = extract_let_mutable acc let_mut in - Immutable(v1, W.expr body2) :: acc - | { var = v; _ } -> - Immutable(v, W.of_defining_expr_of_let let_expr) :: acc - in - let body = W.of_body_of_let let_expr in - extract acc body - -and extract_let_mutable acc (let_mut : Flambda.let_mutable) = - let module W = Flambda.With_free_variables in - let { Flambda.var; initial_value; contents_kind; body } = let_mut in - let acc = Mutable(var, initial_value, contents_kind) :: acc in - extract acc (W.of_expr body) - -and extract acc (expr : Flambda.t Flambda.With_free_variables.t) = - let module W = Flambda.With_free_variables in - match W.contents expr with - | Let let_expr -> - extract_let_expr acc let_expr - | Let_mutable let_mutable -> - extract_let_mutable acc let_mutable - | _ -> - acc, expr - -let rec lift_lets_expr (expr:Flambda.t) ~toplevel : Flambda.t = - let module W = Flambda.With_free_variables in - match expr with - | Let let_expr -> - let defs, body = extract_let_expr [] let_expr in - let rev_defs = List.rev_map (lift_lets_def ~toplevel) defs in - let body = lift_lets_expr (W.contents body) ~toplevel in - rebuild_let (List.rev rev_defs) body - | Let_mutable let_mut -> - let defs, body = extract_let_mutable [] let_mut in - let rev_defs = List.rev_map (lift_lets_def ~toplevel) defs in - let body = lift_lets_expr (W.contents body) ~toplevel in - rebuild_let (List.rev rev_defs) body - | e -> - Flambda_iterators.map_subexpressions - (lift_lets_expr ~toplevel) - (lift_lets_named ~toplevel) - e - -and lift_lets_def def ~toplevel = - let module W = Flambda.With_free_variables in - match def with - | Mutable _ -> def - | Immutable(var, named) -> - let named = - match W.contents named with - | Expr e -> W.expr (W.of_expr (lift_lets_expr e ~toplevel)) - | Set_of_closures set when not toplevel -> - W.of_named - (Set_of_closures - (Flambda_iterators.map_function_bodies - ~f:(lift_lets_expr ~toplevel) set)) - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field (_, _) | Project_closure _ - | Move_within_set_of_closures _ | Project_var _ - | Prim _ | Set_of_closures _ -> - named - in - Immutable(var, named) - -and lift_lets_named _var (named:Flambda.named) ~toplevel : Flambda.named = - match named with - | Expr e -> - Expr (lift_lets_expr e ~toplevel) - | Set_of_closures set when not toplevel -> - Set_of_closures - (Flambda_iterators.map_function_bodies ~f:(lift_lets_expr ~toplevel) set) - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field (_, _) | Project_closure _ | Move_within_set_of_closures _ - | Project_var _ | Prim _ | Set_of_closures _ -> - named - -module Sort_lets = Strongly_connected_components.Make (Variable) - -let rebuild_let_rec (defs:(Variable.t * Flambda.named) list) body = - let map = Variable.Map.of_list defs in - let graph = - Variable.Map.map - (fun named -> - Variable.Set.filter (fun v -> Variable.Map.mem v map) - (Flambda.free_variables_named named)) - map - in - let components = - Sort_lets.connected_components_sorted_from_roots_to_leaf graph - in - Array.fold_left (fun body (component:Sort_lets.component) -> - match component with - | No_loop v -> - let def = Variable.Map.find v map in - Flambda.create_let v def body - | Has_loop l -> - Flambda.Let_rec - (List.map (fun v -> v, Variable.Map.find v map) l, - body)) - body components - -let lift_let_rec program = - Flambda_iterators.map_exprs_at_toplevel_of_program program - ~f:(Flambda_iterators.map_expr - (fun expr -> match expr with - | Let_rec (defs, body) -> - rebuild_let_rec defs body - | expr -> expr)) - -let lift_lets program = - let program = lift_let_rec program in - Flambda_iterators.map_exprs_at_toplevel_of_program program - ~f:(lift_lets_expr ~toplevel:false) - -let lifting_helper exprs ~evaluation_order ~create_body ~name = - let vars, lets = - (* [vars] corresponds elementwise to [exprs]; the order is unchanged. *) - List.fold_right (fun (flam : Flambda.t) (vars, lets) -> - match flam with - | Var v -> - (* Note that [v] is (statically) always an immutable variable. *) - v::vars, lets - | expr -> - let v = - Variable.create name ~current_compilation_unit: - (Compilation_unit.get_current_exn ()) - in - v::vars, (v, expr)::lets) - exprs ([], []) - in - let lets = - match evaluation_order with - | `Right_to_left -> lets - | `Left_to_right -> List.rev lets - in - List.fold_left (fun body (v, expr) -> - Flambda.create_let v (Expr expr) body) - (create_body vars) lets diff --git a/middle_end/flambda/lift_code.mli b/middle_end/flambda/lift_code.mli deleted file mode 100644 index 92ecda0154d..00000000000 --- a/middle_end/flambda/lift_code.mli +++ /dev/null @@ -1,43 +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"] - -type lifter = Flambda.program -> Flambda.program - -(** Lift [let] bindings to attempt to increase the length of scopes, as an - aid to further optimizations. For example: - let c = let b = in b, b in fst c - would be transformed to: - let b = in let c = b, b in fst c - which is then clearly just: - -*) -val lift_lets : lifter - -val lift_lets_expr : Flambda.t -> toplevel:bool -> Flambda.t - -(* CR-someday mshinwell: Rename to [bind]? Also see Flambda_utils.bind. *) -(* [create_body] always receives the variables corresponding to [evaluate] - in the same order. However [evaluation_order] specifies in which order - the (possibly complex) expressions bound to those variables are - evaluated. *) -val lifting_helper - : Flambda.t list - -> evaluation_order:[ `Left_to_right | `Right_to_left ] - -> create_body:(Variable.t list -> Flambda.t) - -> name:Internal_variable_names.t - -> Flambda.t diff --git a/middle_end/flambda/lift_constants.ml b/middle_end/flambda/lift_constants.ml deleted file mode 100644 index 0c4e2cb52cd..00000000000 --- a/middle_end/flambda/lift_constants.ml +++ /dev/null @@ -1,1017 +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-66"] -open! Int_replace_polymorphic_compare - -(* CR-someday mshinwell: move to Flambda_utils *) -let rec tail_variable : Flambda.t -> Variable.t option = function - | Var v -> Some v - | Let_rec (_, e) - | Let_mutable { body = e } - | Let { body = e; _ } -> tail_variable e - | _ -> None - -(** Traverse the given expression assigning symbols to [let]- and [let rec]- - bound constant variables. At the same time collect the definitions of - such variables. *) -let assign_symbols_and_collect_constant_definitions - ~(program : Flambda.program) - ~(inconstants : Inconstant_idents.result) = - let var_to_symbol_tbl = Variable.Tbl.create 42 in - let var_to_definition_tbl = Variable.Tbl.create 42 in - let module AA = Alias_analysis in - let assign_symbol var (named : Flambda.named) = - if not (Inconstant_idents.variable var inconstants) then begin - let assign_symbol () = - let symbol = Symbol_utils.Flambda.for_variable (Variable.rename var) in - Variable.Tbl.add var_to_symbol_tbl var symbol - in - let assign_existing_symbol = Variable.Tbl.add var_to_symbol_tbl var in - let record_definition = Variable.Tbl.add var_to_definition_tbl var in - match named with - | Symbol symbol -> - assign_existing_symbol symbol; - record_definition (AA.Symbol symbol) - | Const const -> record_definition (AA.Const const) - | Allocated_const const -> - assign_symbol (); - record_definition (AA.Allocated_const (Normal const)) - | Read_mutable _ -> - (* [Inconstant_idents] always marks these expressions as - inconstant, so we should never get here. *) - assert false - | Prim (Pmakeblock (tag, _, _value_kind, _mode), fields, _) -> - assign_symbol (); - record_definition (AA.Block (Tag.create_exn tag, fields)) - | Read_symbol_field (symbol, field) -> - record_definition (AA.Symbol_field (symbol, field)) - | Set_of_closures ( - { function_decls = { funs; set_of_closures_id; _ }; - _ } as set) -> - assert (not (Inconstant_idents.closure set_of_closures_id - inconstants)); - assign_symbol (); - record_definition (AA.Set_of_closures set); - Variable.Map.iter (fun fun_var _ -> - let closure_id = Closure_id.wrap fun_var in - let closure_symbol = Symbol_utils.Flambda.for_closure closure_id in - Variable.Tbl.add var_to_symbol_tbl fun_var closure_symbol; - let project_closure = - Alias_analysis.Project_closure - { set_of_closures = var; closure_id } - in - Variable.Tbl.add var_to_definition_tbl fun_var - project_closure) - funs - | Move_within_set_of_closures ({ closure = _; start_from = _; move_to; } - as move) -> - assign_existing_symbol (Symbol_utils.Flambda.for_closure move_to); - record_definition (AA.Move_within_set_of_closures move) - | Project_closure ({ closure_id } as project_closure) -> - assign_existing_symbol (Symbol_utils.Flambda.for_closure closure_id); - record_definition (AA.Project_closure project_closure) - | Prim (Pfield (index, Pvalue _, _, _), [block], _) -> - record_definition (AA.Field (block, index)) - | Prim (Pfield (_, _, _, _), [_], _) -> - Misc.fatal_errorf "[Pfield] with kind not value is not expected to be\ - constant: @.%a@." - Flambda.print_named named - | Prim (Pfield _, _, _) -> - Misc.fatal_errorf "[Pfield] with the wrong number of arguments" - Flambda.print_named named - | Prim (Pmakearray (Pfloatarray as kind, mutability, _mode), args, _) -> - assign_symbol (); - record_definition (AA.Allocated_const (Array (kind, mutability, args))) - | Prim (Pduparray (kind, mutability), [arg], _) -> - assign_symbol (); - record_definition (AA.Allocated_const ( - Duplicate_array (kind, mutability, arg))) - | Prim _ -> - Misc.fatal_errorf "Primitive not expected to be constant: @.%a@." - Flambda.print_named named - | Project_var project_var -> - record_definition (AA.Project_var project_var) - | Expr e -> - match tail_variable e with - | None -> assert false (* See [Inconstant_idents]. *) - | Some v -> record_definition (AA.Variable v) - end - in - let assign_symbol_program expr = - Flambda_iterators.iter_all_immutable_let_and_let_rec_bindings expr - ~f:assign_symbol - in - Flambda_iterators.iter_exprs_at_toplevel_of_program program - ~f:assign_symbol_program; - let let_symbol_to_definition_tbl = Symbol.Tbl.create 42 in - let initialize_symbol_to_definition_tbl = Symbol.Tbl.create 42 in - let rec collect_let_and_initialize_symbols (program : Flambda.program_body) = - match program with - | Let_symbol (symbol, decl, program) -> - Symbol.Tbl.add let_symbol_to_definition_tbl symbol decl; - collect_let_and_initialize_symbols program - | Let_rec_symbol (decls, program) -> - List.iter (fun (symbol, decl) -> - Symbol.Tbl.add let_symbol_to_definition_tbl symbol decl) - decls; - collect_let_and_initialize_symbols program - | Effect (_, program) -> collect_let_and_initialize_symbols program - | Initialize_symbol (symbol,_tag,fields,program) -> - collect_let_and_initialize_symbols program; - let fields = List.map tail_variable fields in - Symbol.Tbl.add initialize_symbol_to_definition_tbl symbol fields - | End _ -> () - in - collect_let_and_initialize_symbols program.program_body; - let record_set_of_closure_equalities - (set_of_closures : Flambda.set_of_closures) = - Variable.Map.iter (fun arg (var : Flambda.specialised_to) -> - if not (Inconstant_idents.variable arg inconstants) then - Variable.Tbl.add var_to_definition_tbl arg (AA.Variable var.var)) - set_of_closures.free_vars; - Variable.Map.iter (fun arg (spec_to : Flambda.specialised_to) -> - if not (Inconstant_idents.variable arg inconstants) then - Variable.Tbl.add var_to_definition_tbl arg - (AA.Variable spec_to.var)) - set_of_closures.specialised_args - in - Flambda_iterators.iter_on_set_of_closures_of_program program - ~f:(fun ~constant set_of_closures -> - record_set_of_closure_equalities set_of_closures; - if constant then begin - Variable.Map.iter (fun fun_var _ -> - let closure_id = Closure_id.wrap fun_var in - let closure_symbol = Symbol_utils.Flambda.for_closure closure_id in - Variable.Tbl.add var_to_definition_tbl fun_var - (AA.Symbol closure_symbol); - Variable.Tbl.add var_to_symbol_tbl fun_var closure_symbol) - set_of_closures.Flambda.function_decls.funs - end); - var_to_symbol_tbl, var_to_definition_tbl, - let_symbol_to_definition_tbl, initialize_symbol_to_definition_tbl - -let variable_field_definition - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl : - Alias_analysis.constant_defining_value Variable.Tbl.t) - (var : Variable.t) : Flambda.constant_defining_value_block_field = - try - Symbol (Variable.Tbl.find var_to_symbol_tbl var) - with Not_found -> - match Variable.Tbl.find var_to_definition_tbl var with - | Const c -> Const c - | const_defining_value -> - Misc.fatal_errorf "Unexpected pattern for a constant: %a: %a" - Variable.print var - Alias_analysis.print_constant_defining_value const_defining_value - | exception Not_found -> - Misc.fatal_errorf "No associated symbol for the constant %a" - Variable.print var - -let resolve_variable - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl : - Alias_analysis.constant_defining_value Variable.Tbl.t) - (var : Variable.t) : Flambda.constant_defining_value_block_field = - match Variable.Map.find var aliases with - | exception Not_found -> - variable_field_definition var_to_symbol_tbl var_to_definition_tbl var - | Symbol s -> Symbol s - | Variable aliased_variable -> - variable_field_definition var_to_symbol_tbl var_to_definition_tbl - aliased_variable - -let translate_set_of_closures - (inconstants : Inconstant_idents.result) - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl: - Alias_analysis.constant_defining_value Variable.Tbl.t) - (set_of_closures : Flambda.set_of_closures) = - let f var (named : Flambda.named) : Flambda.named = - if Inconstant_idents.variable var inconstants then - named - else - let resolved = - resolve_variable - aliases - var_to_symbol_tbl - var_to_definition_tbl - var - in - match resolved with - | Symbol s -> Symbol s - | Const c -> Const c - in - Flambda_iterators.map_function_bodies set_of_closures - ~f:(Flambda_iterators.map_all_immutable_let_and_let_rec_bindings ~f) - -let translate_constant_set_of_closures - (inconstants : Inconstant_idents.result) - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl: - Alias_analysis.constant_defining_value Variable.Tbl.t) - (constant_defining_values : Flambda.constant_defining_value Symbol.Map.t) = - Symbol.Map.map (fun (const : Flambda.constant_defining_value) -> - match const with - | Flambda.Allocated_const _ - | Flambda.Block _ - | Flambda.Project_closure _ -> - const - | Flambda.Set_of_closures set_of_closures -> - let set_of_closures = - translate_set_of_closures - (inconstants : Inconstant_idents.result) - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl: - Alias_analysis.constant_defining_value Variable.Tbl.t) - (set_of_closures : Flambda.set_of_closures) - in - Flambda.Set_of_closures set_of_closures) - constant_defining_values - -let find_original_set_of_closure - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl: - Alias_analysis.constant_defining_value Variable.Tbl.t) - project_closure_map - var = - let rec loop var = - match Variable.Map.find var aliases with - | Variable var -> - begin match Variable.Tbl.find var_to_definition_tbl var with - | Project_closure { set_of_closures = var } - | Move_within_set_of_closures { closure = var } -> - loop var - | Set_of_closures _ -> begin - match Variable.Tbl.find var_to_symbol_tbl var with - | s -> - s - | exception Not_found -> - Format.eprintf "var: %a@." Variable.print var; - assert false - end - | _ -> assert false - end - | Symbol s -> - match Symbol.Map.find s project_closure_map with - | exception Not_found -> - Misc.fatal_errorf "find_original_set_of_closure: cannot find \ - symbol %a in the project-closure map" - Symbol.print s - | s -> s - in - loop var - -let translate_definition_and_resolve_alias inconstants - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl : - Alias_analysis.constant_defining_value Variable.Tbl.t) - (symbol_definition_map : Flambda.constant_defining_value Symbol.Map.t) - (project_closure_map : Symbol.t Symbol.Map.t) - (definition : Alias_analysis.constant_defining_value) - ~(backend : (module Backend_intf.S)) - : Flambda.constant_defining_value option = - let resolve_float_array_involving_variables - ~(mutability : Lambda.mutable_flag) ~vars = - (* Resolve an [Allocated_const] of the form: - [Array (Pfloatarray, _, _)] - (which references its contents via variables; it does not contain - manifest floats). *) - let find_float_var_definition var = - match Variable.Tbl.find var_to_definition_tbl var with - | Allocated_const (Normal (Float f)) -> f - | const_defining_value -> - Misc.fatal_errorf "Bad definition for float array member %a: %a" - Variable.print var - Alias_analysis.print_constant_defining_value - const_defining_value - in - let find_float_symbol_definition sym = - match Symbol.Map.find sym symbol_definition_map with - | Allocated_const (Float f) -> f - | const_defining_value -> - Misc.fatal_errorf "Bad definition for float array member %a: %a" - Symbol.print sym - Flambda.print_constant_defining_value - const_defining_value - in - let floats = - List.map (fun var -> - match Variable.Map.find var aliases with - | exception Not_found -> find_float_var_definition var - | Variable var -> find_float_var_definition var - | Symbol sym -> find_float_symbol_definition sym) - vars - in - let const : Allocated_const.t = - match mutability with - | Immutable | Immutable_unique -> Immutable_float_array floats - | Mutable -> Float_array floats - in - Some (Flambda.Allocated_const const) - in - match definition with - | Block (tag, fields) -> - Some (Flambda.Block (tag, - List.map (resolve_variable aliases var_to_symbol_tbl - var_to_definition_tbl) - fields)) - | Allocated_const (Normal const) -> Some (Flambda.Allocated_const const) - | Allocated_const (Duplicate_array (Pfloatarray, mutability, var)) -> - (* CR-someday mshinwell: This next section could do with cleanup. - What happens is: - - Duplicate contains a variable, which is resolved to - a float array thing full of variables; - - We send that value back through this function again so the - individual members of that array are resolved from variables to - floats. - - Then we can build the Flambda.name term containing the - Allocated_const (full of floats). - We should maybe factor out the code from the - Allocated_const (Array (...)) case below so this function doesn't have - to be recursive. *) - let (constant_defining_value : Alias_analysis.constant_defining_value) = - match Variable.Map.find var aliases with - | exception Not_found -> - Variable.Tbl.find var_to_definition_tbl var - | Variable var -> - Variable.Tbl.find var_to_definition_tbl var - | Symbol sym -> - match Symbol.Map.find sym symbol_definition_map with - | Allocated_const ((Immutable_float_array _) as const) -> - Alias_analysis.Allocated_const (Normal const) - | (Allocated_const _ | Block _ | Set_of_closures _ - | Project_closure _) as wrong -> - Misc.fatal_errorf - "Lift_constants.translate_definition_and_resolve_alias: \ - Duplicate Pfloatarray %a with symbol %a mapping to \ - wrong constant defining value %a" - Variable.print var - Alias_analysis.print_constant_defining_value definition - Flambda.print_constant_defining_value wrong - | exception Not_found -> - let module Backend = (val backend) in - match (Backend.import_symbol sym).descr with - | Value_unresolved _ -> - Misc.fatal_errorf - "Lift_constants.translate_definition_and_resolve_alias: \ - Duplicate Pfloatarray %a with unknown symbol: %a" - Variable.print var - Alias_analysis.print_constant_defining_value definition - | Value_float_array value_float_array -> - let contents = - Simple_value_approx.float_array_as_constant value_float_array - in - begin match contents with - | None -> - Misc.fatal_errorf - "Lift_constants.translate_definition_and_resolve_alias: \ - Duplicate Pfloatarray %a with not completely known float \ - array from symbol: %a" - Variable.print var - Alias_analysis.print_constant_defining_value definition - | Some l -> - Alias_analysis.Allocated_const (Normal (Immutable_float_array l)) - end - | wrong -> - (* CR-someday mshinwell: we might hit this if we ever duplicate - a mutable array across compilation units (e.g. "snapshotting" - an array). We do not currently generate such code. *) - Misc.fatal_errorf - "Lift_constants.translate_definition_and_resolve_alias: \ - Duplicate Pfloatarray %a with symbol %a that does not \ - have an export description of an immutable array" - Variable.print var - Alias_analysis.print_constant_defining_value definition - Simple_value_approx.print_descr wrong - in - begin match constant_defining_value with - | Allocated_const (Normal (Float_array _)) -> - (* This example from pchambart illustrates why we do not allow - the duplication of mutable arrays: - - {| - let_symbol a = Allocated_const (Immutable_float_array [|0.|]) - initialize_symbol b = Duparray(Mutable, a) - effect b.(0) <- 1. - initialize_symbol c = Duparray(Mutable, b) - |} - - This will be converted to: - {| - let_symbol a = Allocated_const (Immutable_float_array [|0.|]) - let_symbol b = Allocated_const (Float_array [|0.|]) - effect b.(0) <- 1. - let_symbol c = Allocated_const (Float_array [|0.|]) - |} - - We can't encounter that currently, but it's scary. - *) - Misc.fatal_error "Pduparray is not allowed on mutable arrays" - | Allocated_const (Normal (Immutable_float_array floats)) -> - let const : Allocated_const.t = - match mutability with - | Immutable | Immutable_unique -> Immutable_float_array floats - | Mutable -> Float_array floats - in - Some (Flambda.Allocated_const const) - | Allocated_const (Array (Pfloatarray, _, vars)) -> - (* Important: [mutability] is from the [Duplicate_array] - construction above. *) - resolve_float_array_involving_variables ~mutability ~vars - | const -> - Misc.fatal_errorf - "Lift_constants.translate_definition_and_resolve_alias: \ - Duplicate Pfloatarray %a with wrong argument: %a" - Variable.print var - Alias_analysis.print_constant_defining_value const - end - | Allocated_const (Duplicate_array (_, _, _)) -> - Misc.fatal_errorf "Lift_constants.translate_definition_and_resolve_alias: \ - Duplicate_array with non-Pfloatarray kind: %a" - Alias_analysis.print_constant_defining_value definition - | Allocated_const (Array (Pfloatarray, mutability, vars)) -> - resolve_float_array_involving_variables ~mutability ~vars - | Allocated_const (Array (_, _, _)) -> - Misc.fatal_errorf "Lift_constants.translate_definition_and_resolve_alias: \ - Array with non-Pfloatarray kind: %a" - Alias_analysis.print_constant_defining_value definition - | Project_closure { set_of_closures; closure_id } -> - begin match Variable.Map.find set_of_closures aliases with - | Symbol s -> - Some (Flambda.Project_closure (s, closure_id)) - (* If a closure projection is a constant, the set of closures must - be assigned to a symbol. *) - | exception Not_found -> - assert false - | Variable v -> - match Variable.Tbl.find var_to_symbol_tbl v with - | s -> - Some (Flambda.Project_closure (s, closure_id)) - | exception Not_found -> - Format.eprintf "var: %a@." Variable.print v; - assert false - end - | Move_within_set_of_closures { closure; move_to } -> - let set_of_closure_symbol = - find_original_set_of_closure - aliases - var_to_symbol_tbl - var_to_definition_tbl - project_closure_map - closure - in - Some (Flambda.Project_closure (set_of_closure_symbol, move_to)) - | Set_of_closures set_of_closures -> - let set_of_closures = - translate_set_of_closures - inconstants - aliases - var_to_symbol_tbl - var_to_definition_tbl - set_of_closures - in - Some (Flambda.Set_of_closures set_of_closures) - | Project_var _ -> None - | Field (_,_) | Symbol_field _ -> None - | Const _ -> None - | Symbol _ -> None - | Variable _ -> None - -let translate_definitions_and_resolve_alias - inconstants - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl: - Alias_analysis.constant_defining_value Variable.Tbl.t) - symbol_definition_map - project_closure_map - ~backend = - Variable.Tbl.fold (fun var def map -> - match - translate_definition_and_resolve_alias inconstants aliases ~backend - var_to_symbol_tbl var_to_definition_tbl symbol_definition_map - project_closure_map def - with - | None -> map - | Some def -> - let symbol = Variable.Tbl.find var_to_symbol_tbl var in - Symbol.Map.add symbol def map) - var_to_definition_tbl Symbol.Map.empty - -(* Resorting of graph including Initialize_symbol *) -let constant_dependencies ~backend:_ - (const : Flambda.constant_defining_value) = - match const with - | Allocated_const _ -> Symbol.Set.empty - | Block (_, fields) -> - let symbol_fields = - List.filter_map - (function - | (Symbol s : Flambda.constant_defining_value_block_field) -> Some s - | Flambda.Const _ -> None) - fields - in - Symbol.Set.of_list symbol_fields - | Set_of_closures set_of_closures -> - Flambda.free_symbols_named (Set_of_closures set_of_closures) - | Project_closure (s, _) -> - Symbol.Set.singleton s - -module Symbol_SCC = Strongly_connected_components.Make (Symbol) - -let program_graph ~backend imported_symbols symbol_to_constant - (initialize_symbol_tbl : - (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t) - (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t) = - let expression_symbol_dependencies expr = Flambda.free_symbols expr in - let graph_with_only_constant_parts = - Symbol.Map.map (fun const -> - Symbol.Set.diff (constant_dependencies ~backend const) - imported_symbols) - symbol_to_constant - in - let graph_with_initialisation = - Symbol.Tbl.fold (fun sym (_tag, fields, previous) -> - let order_dep = - match previous with - | None -> Symbol.Set.empty - | Some previous -> Symbol.Set.singleton previous - in - let deps = List.fold_left (fun set field -> - Symbol.Set.union (expression_symbol_dependencies field) set) - order_dep fields - in - let deps = Symbol.Set.diff deps imported_symbols in - Symbol.Map.add sym deps) - initialize_symbol_tbl graph_with_only_constant_parts - in - let graph = - Symbol.Tbl.fold (fun sym (expr, previous) -> - let order_dep = - match previous with - | None -> Symbol.Set.empty - | Some previous -> Symbol.Set.singleton previous - in - let deps = - Symbol.Set.union (expression_symbol_dependencies expr) order_dep - in - let deps = Symbol.Set.diff deps imported_symbols in - Symbol.Map.add sym deps - ) - effect_tbl graph_with_initialisation - in - let components = - Symbol_SCC.connected_components_sorted_from_roots_to_leaf - graph - in - components - -(* rebuilding the program *) -let add_definition_of_symbol constant_definitions - (initialize_symbol_tbl : - (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t) - (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t) - (program : Flambda.program_body) component : Flambda.program_body = - let symbol_declaration sym = - (* A symbol declared through an Initialize_symbol construct - cannot be recursive, this is not allowed in the construction. - This also couldn't have been introduced by this pass, so we can - safely assert that this is not possible here *) - assert(not (Symbol.Tbl.mem initialize_symbol_tbl sym)); - (sym, Symbol.Map.find sym constant_definitions) - in - match component with - | Symbol_SCC.Has_loop l -> - let l = List.map symbol_declaration l in - Let_rec_symbol (l, program) - | Symbol_SCC.No_loop sym -> - match Symbol.Tbl.find initialize_symbol_tbl sym with - | (tag, fields, _previous) -> - Initialize_symbol (sym, tag, fields, program) - | exception Not_found -> - match Symbol.Tbl.find effect_tbl sym with - | (expr, _previous) -> - Effect (expr, program) - | exception Not_found -> - let decl = Symbol.Map.find sym constant_definitions in - Let_symbol (sym, decl, program) - -let add_definitions_of_symbols constant_definitions initialize_symbol_tbl - effect_tbl program components = - Array.fold_left - (add_definition_of_symbol constant_definitions initialize_symbol_tbl - effect_tbl) - program components - -let introduce_free_variables_in_set_of_closures - (var_to_block_field_tbl : - Flambda.constant_defining_value_block_field Variable.Tbl.t) - ({ Flambda.function_decls; free_vars; specialised_args; - direct_call_surrogates; } - as set_of_closures) = - let add_definition_and_make_substitution var (expr, subst) = - let searched_var = - match Variable.Map.find var specialised_args with - | exception Not_found -> var - | external_var -> - (* specialised arguments bound to constant can be rewritten *) - external_var.var - in - match Variable.Tbl.find var_to_block_field_tbl searched_var with - | def -> - let fresh = Variable.rename var in - let named : Flambda.named = match def with - | Symbol sym -> Symbol sym - | Const c -> Const c - in - (Flambda.create_let fresh named expr), Variable.Map.add var fresh subst - | exception Not_found -> - (* The variable is bound by the closure or the arguments or not - constant. In either case it does not need to be bound *) - expr, subst - in - let done_something = ref false in - let function_decls : Flambda.function_declarations = - Flambda.update_function_declarations function_decls - ~funs:(Variable.Map.map - (fun (func_decl : Flambda.function_declaration) -> - let variables_to_bind = - (* Closures from the same set must not be bound. *) - Variable.Set.diff func_decl.free_variables - (Variable.Map.keys function_decls.funs) - in - let body, subst = - Variable.Set.fold add_definition_and_make_substitution - variables_to_bind - (func_decl.body, Variable.Map.empty) - in - if Variable.Map.is_empty subst then begin - func_decl - end else begin - done_something := true; - let body = Flambda_utils.toplevel_substitution subst body in - Flambda.update_body_of_function_declaration func_decl ~body - end) - function_decls.funs) - in - let free_vars = - (* Keep only those that are not rewritten to constants. *) - Variable.Map.filter (fun v _ -> - let keep = not (Variable.Tbl.mem var_to_block_field_tbl v) in - if not keep then done_something := true; - keep) - free_vars - in - let free_vars = - Flambda_utils.clean_projections ~which_variables:free_vars - in - let specialised_args = - (* Keep only those that are not rewritten to constants. *) - Variable.Map.filter (fun _ (spec_to : Flambda.specialised_to) -> - let keep = - not (Variable.Tbl.mem var_to_block_field_tbl spec_to.var) - in - if not keep then begin - done_something := true - end; - keep) - specialised_args - in - let specialised_args = - Flambda_utils.clean_projections ~which_variables:specialised_args - in - if not !done_something then - set_of_closures - else - Flambda.create_set_of_closures ~function_decls ~free_vars - ~specialised_args ~direct_call_surrogates - -let rewrite_project_var - (var_to_block_field_tbl - : Flambda.constant_defining_value_block_field Variable.Tbl.t) - (project_var : Flambda.project_var) ~original : Flambda.named = - let var = Var_within_closure.unwrap project_var.var in - match Variable.Tbl.find var_to_block_field_tbl var with - | exception Not_found -> original - | Symbol sym -> Symbol sym - | Const const -> Const const - -let introduce_free_variables_in_sets_of_closures - (var_to_block_field_tbl: - Flambda.constant_defining_value_block_field Variable.Tbl.t) - (translate_definition : Flambda.constant_defining_value Symbol.Map.t) = - Symbol.Map.map (fun (def : Flambda.constant_defining_value) -> - match def with - | Allocated_const _ - | Block _ - | Project_closure _ -> def - | Set_of_closures set_of_closures -> - Flambda.Set_of_closures - (introduce_free_variables_in_set_of_closures - var_to_block_field_tbl - set_of_closures)) - translate_definition - -let var_to_block_field - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl : - Alias_analysis.constant_defining_value Variable.Tbl.t) = - let var_to_block_field_tbl = Variable.Tbl.create 42 in - Variable.Tbl.iter (fun var _ -> - let def = - resolve_variable aliases var_to_symbol_tbl var_to_definition_tbl var - in - Variable.Tbl.add var_to_block_field_tbl var def) - var_to_definition_tbl; - var_to_block_field_tbl - -let program_symbols (program : Flambda.program) = - let new_fake_symbol () = - let var = Variable.create Internal_variable_names.fake_effect_symbol in - Symbol_utils.Flambda.for_variable var - in - let initialize_symbol_tbl = Symbol.Tbl.create 42 in - let effect_tbl = Symbol.Tbl.create 42 in - let symbol_definition_tbl = Symbol.Tbl.create 42 in - let add_project_closure_definitions def_symbol - (const : Flambda.constant_defining_value) = - match const with - | Set_of_closures { function_decls = { funs } } -> - Variable.Map.iter (fun fun_var _ -> - let closure_id = Closure_id.wrap fun_var in - let closure_symbol = Symbol_utils.Flambda.for_closure closure_id in - let project_closure = - Flambda.Project_closure (def_symbol, closure_id) - in - Symbol.Tbl.add symbol_definition_tbl closure_symbol - project_closure) - funs - | Project_closure _ - | Allocated_const _ - | Block _ -> () - in - let rec loop (program : Flambda.program_body) previous_effect = - match program with - | Flambda.Let_symbol (symbol, def, program) -> - add_project_closure_definitions symbol def; - Symbol.Tbl.add symbol_definition_tbl symbol def; - loop program previous_effect - | Flambda.Let_rec_symbol (defs, program) -> - List.iter (fun (symbol, def) -> - add_project_closure_definitions symbol def; - Symbol.Tbl.add symbol_definition_tbl symbol def) - defs; - loop program previous_effect - | Flambda.Initialize_symbol (symbol, tag, fields, program) -> - (* previous_effect is used to keep the order of initialize and effect - values. Their effects order must be kept ordered. - it is used as an extra dependency when sorting the symbols. *) - (* CR-someday pchambart: if the fields expressions are pure, we could - drop this dependency - mshinwell: deferred CR *) - Symbol.Tbl.add initialize_symbol_tbl symbol - (tag, fields, previous_effect); - loop program (Some symbol) - | Flambda.Effect (expr, program) -> - (* Used to ensure that effects are correctly ordered *) - let fake_effect_symbol = new_fake_symbol () in - Symbol.Tbl.add effect_tbl fake_effect_symbol (expr, previous_effect); - loop program (Some fake_effect_symbol) - | Flambda.End _ -> () - in - loop program.program_body None; - initialize_symbol_tbl, symbol_definition_tbl, effect_tbl - -let replace_definitions_in_initialize_symbol_and_effects - (inconstants : Inconstant_idents.result) - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl : - Alias_analysis.constant_defining_value Variable.Tbl.t) - (initialize_symbol_tbl : - (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t) - (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t) = - let rewrite_expr expr = - Flambda_iterators.map_all_immutable_let_and_let_rec_bindings expr - ~f:(fun var (named : Flambda.named) : Flambda.named -> - if Inconstant_idents.variable var inconstants then - named - else - let resolved = - resolve_variable - aliases - var_to_symbol_tbl - var_to_definition_tbl - var - in - match named, resolved with - | Symbol s1, Symbol s2 -> - assert (s1 == s2); (* physical equality for speed *) - named; - | Const c1, Const c2 -> - assert (c1 == c2); - named - | _, Symbol s -> Symbol s - | _, Const c -> Const c) - in - (* This is safe because we only [replace] the current key during - iteration (cf. https://github.com/ocaml/ocaml/pull/337) *) - Symbol.Tbl.iter - (fun symbol (tag, fields, previous) -> - let fields = List.map rewrite_expr fields in - Symbol.Tbl.replace initialize_symbol_tbl symbol (tag, fields, previous)) - initialize_symbol_tbl; - Symbol.Tbl.iter - (fun symbol (expr, previous) -> - Symbol.Tbl.replace effect_tbl symbol (rewrite_expr expr, previous)) - effect_tbl - -(* CR-soon mshinwell: Update the name of [project_closure_map]. *) -let project_closure_map symbol_definition_map = - Symbol.Map.fold (fun sym (const : Flambda.constant_defining_value) acc -> - match const with - | Project_closure (set_of_closures, _) -> - Symbol.Map.add sym set_of_closures acc - | Set_of_closures _ -> - Symbol.Map.add sym sym acc - | Allocated_const _ - | Block _ -> acc) - symbol_definition_map - Symbol.Map.empty - -let lift_constants (program : Flambda.program) ~backend = - let the_dead_constant = - let var = Variable.create Internal_variable_names.the_dead_constant in - Symbol_utils.Flambda.for_variable var - in - let program_body : Flambda.program_body = - Let_symbol (the_dead_constant, Allocated_const (Nativeint 0n), - program.program_body) - in - let program : Flambda.program = - { program with program_body; } - in - let inconstants = - Inconstant_idents.inconstants_on_program program ~backend - ~compilation_unit:(Compilation_unit.get_current_exn ()) - in - let initialize_symbol_tbl, symbol_definition_tbl, effect_tbl = - program_symbols program - in - let var_to_symbol_tbl, var_to_definition_tbl, let_symbol_to_definition_tbl, - initialize_symbol_to_definition_tbl = - assign_symbols_and_collect_constant_definitions ~program ~inconstants - in - let aliases = - Alias_analysis.run var_to_definition_tbl - initialize_symbol_to_definition_tbl - let_symbol_to_definition_tbl - ~the_dead_constant - in - replace_definitions_in_initialize_symbol_and_effects - (inconstants : Inconstant_idents.result) - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl - : Alias_analysis.constant_defining_value Variable.Tbl.t) - initialize_symbol_tbl - effect_tbl; - let symbol_definition_map = - translate_constant_set_of_closures - (inconstants : Inconstant_idents.result) - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl - : Alias_analysis.constant_defining_value Variable.Tbl.t) - (Symbol.Tbl.to_map symbol_definition_tbl) - in - let project_closure_map = project_closure_map symbol_definition_map in - let translated_definitions = - translate_definitions_and_resolve_alias - inconstants - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl - : Alias_analysis.constant_defining_value Variable.Tbl.t) - symbol_definition_map - project_closure_map - ~backend - in - let var_to_block_field_tbl = - var_to_block_field - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl - : Alias_analysis.constant_defining_value Variable.Tbl.t) - in - let translated_definitions = - introduce_free_variables_in_sets_of_closures var_to_block_field_tbl - translated_definitions - in - let constant_definitions = - (* Add previous Let_symbol to the newly discovered ones *) - Symbol.Map.union - (fun _sym - (c1:Flambda.constant_defining_value) - (c2:Flambda.constant_defining_value) -> - match c1, c2 with - | Project_closure (s1, closure_id1), - Project_closure (s2, closure_id2) when - Symbol.equal s1 s2 && - Closure_id.equal closure_id1 closure_id2 -> - Some c1 - | Project_closure (s1, closure_id1), - Project_closure (s2, closure_id2) -> - Format.eprintf "not equal project closure@. s %a %a@. cid %a %a@." - Symbol.print s1 Symbol.print s2 - Closure_id.print closure_id1 Closure_id.print closure_id2; - assert false - | _ -> - assert false - ) - symbol_definition_map - translated_definitions - in - (* Upon the [Initialize_symbol]s, the [Effect]s and the constant definitions, - do the following: - 1. Introduce [Let]s to bind variables that are going to be replaced - by constants. - 2. If a variable bound by a closure gets replaced by a symbol and - thus eliminated from the [free_vars] set of the closure, we need to - rewrite any subsequent [Project_var] expressions that project that - variable. *) - let rewrite_expr expr = - Flambda_iterators.map_named (function - | (Set_of_closures set_of_closures) as named -> - let new_set_of_closures = - introduce_free_variables_in_set_of_closures - var_to_block_field_tbl set_of_closures - in - if new_set_of_closures == set_of_closures then - named - else - Set_of_closures new_set_of_closures - | (Project_var project_var) as original -> - rewrite_project_var var_to_block_field_tbl project_var ~original - | (Symbol _ | Const _ | Allocated_const _ | Project_closure _ - | Move_within_set_of_closures _ | Prim _ | Expr _ - | Read_mutable _ | Read_symbol_field _) as named -> named) - expr - in - let constant_definitions = - Symbol.Map.map (fun (const : Flambda.constant_defining_value) -> - match const with - | Allocated_const _ | Block _ | Project_closure _ -> const - | Set_of_closures set_of_closures -> - let set_of_closures = - Flambda_iterators.map_function_bodies set_of_closures - ~f:rewrite_expr - in - Flambda.Set_of_closures - (introduce_free_variables_in_set_of_closures - var_to_block_field_tbl set_of_closures)) - constant_definitions - in - let effect_tbl = - Symbol.Tbl.map effect_tbl (fun (effect, dep) -> rewrite_expr effect, dep) - in - let initialize_symbol_tbl = - Symbol.Tbl.map initialize_symbol_tbl (fun (tag, fields, dep) -> - let fields = List.map rewrite_expr fields in - tag, fields, dep) - in - let imported_symbols = Flambda_utils.imported_symbols program in - let components = - program_graph ~backend imported_symbols constant_definitions - initialize_symbol_tbl effect_tbl - in - let program_body = - add_definitions_of_symbols constant_definitions - initialize_symbol_tbl - effect_tbl - (End (Flambda_utils.root_symbol program)) - components - in - Flambda_utils.introduce_needed_import_symbols { program with program_body; } diff --git a/middle_end/flambda/lift_constants.mli b/middle_end/flambda/lift_constants.mli deleted file mode 100644 index 969c365e333..00000000000 --- a/middle_end/flambda/lift_constants.mli +++ /dev/null @@ -1,65 +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"] - -(** The aim of this pass is to assign symbols to values known to be - constant (in other words, whose values we know at compile time), with - appropriate sharing of constants, and replace the occurrences of the - constants with their corresponding symbols. - - This pass uses the results of two other passes, [Inconstant_idents] and - [Alias_analysis]. The relationship between these two deserves some - attention. - - [Inconstant_idents] is a "backwards" analysis that propagates implications - about inconstantness of variables and set of closures IDs. - - [Alias_analysis] is a "forwards" analysis that is analogous to the - propagation of [Simple_value_approx.t] values during [Inline_and_simplify]. - It gives us information about relationships between values but not actually - about their constantness. - - Combining these two into a single pass has been attempted previously, - but was not thought to be successful; this experiment could be repeated in - the future. (If "constant" is considered as "top" and "inconstant" is - considered as "bottom", then [Alias_analysis] corresponds to a least fixed - point and [Inconstant_idents] corresponds to a greatest fixed point.) - - At a high level, this pass operates as follows. Symbols are assigned to - variables known to be constant and their defining expressions examined. - Based on the results of [Alias_analysis], we simplify the destructive - elements within the defining expressions (specifically, projection of - fields from blocks), to eventually yield [Flambda.constant_defining_value]s - that are entirely constructive. These will be bound to symbols in the - resulting program. - - Another approach to this pass could be to only use the results of - [Inconstant_idents] and then repeatedly lift constants and run - [Inline_and_simplify] until a fixpoint. It was thought more robust to - instead use [Alias_analysis], where the fixpointing involves a less - complicated function. - - We still run [Inline_and_simplify] once after this pass since the lifting - of constants may enable more functions to become closed; the simplification - pass provides an easy way of cleaning up (e.g. making sure [free_vars] - maps in sets of closures are correct). -*) - -val lift_constants - : Flambda.program - -> backend:(module Backend_intf.S) - -> Flambda.program diff --git a/middle_end/flambda/lift_let_to_initialize_symbol.ml b/middle_end/flambda/lift_let_to_initialize_symbol.ml deleted file mode 100644 index 7687398afe7..00000000000 --- a/middle_end/flambda/lift_let_to_initialize_symbol.ml +++ /dev/null @@ -1,447 +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-66"] -open! Int_replace_polymorphic_compare -module Layouts = Flambda.Layouts - -type ('a, 'b) kind = - | Initialisation of (Symbol.t * Tag.t * Flambda.t list) - | Effect of 'b - -let should_copy (named:Flambda.named) = - match named with - | Symbol _ | Read_symbol_field _ | Const _ -> true - | _ -> false - -type access = - | Field of int - | Project_var of { - closure_id : Closure_id.t; - var : Var_within_closure.t; - kind : Lambda.layout; - } - -type projection = access list - -type extracted = - | Expr of Variable.t * projection * Flambda.t - | Exprs of (Variable.t * projection) list * Flambda.t - | Block of Variable.t * Tag.t * Variable.t list - -type accumulated = { - copied_lets : (Variable.t * Flambda.named) list; - extracted_lets : extracted list; - terminator : Flambda.expr; -} - -(* Values of layout not letrec cannot be stored in any kind of symbol bound - values. Currently the only kind of values that can store any layout are - the closures. - - To box a value, we create a dummy closure (with no code) and store the value - as a free var. Unboxing is done with a projection of the free var. - - The Var_within_closure id is fresh. -*) -let boxing_closure var kind : Flambda.t * access = - let inner_var = Variable.rename var in - let closure_id_var = - Variable.create Internal_variable_names.boxing_set_of_closures - ~debug_info:Debuginfo.none - in - let closure_id = Closure_id.wrap closure_id_var in - let closure_origin = Closure_origin.create closure_id in - let function_decl = - Flambda.create_function_declaration ~params:[] - ~alloc_mode:Lambda.alloc_heap - ~region:false - ~stub:false - ~return_layout:Lambda.layout_bottom - ~specialise:Default_specialise - ~check:Default_check - ~is_a_functor:false - ~poll:Default_poll - ~inline:Default_inline - ~closure_origin - ~body:Proved_unreachable - in - let function_decls = - Flambda.create_function_declarations ~is_classic_mode:true - ~funs:(Variable.Map.singleton closure_id_var function_decl) - in - let free_var : Flambda.specialised_to = - { var; projection = None; kind } - in - let set_of_closures = - Flambda.create_set_of_closures ~function_decls - ~specialised_args:Variable.Map.empty - ~direct_call_surrogates:Variable.Map.empty - ~free_vars:(Variable.Map.singleton inner_var free_var) - in - let project_var : access = - Project_var { closure_id; var = Var_within_closure.wrap inner_var; kind } - in - let closure = - let name = Internal_variable_names.boxing_closure in - let set_var = Variable.create name in - let closure_var = Variable.create name in - Flambda.create_let set_var (Set_of_closures set_of_closures) - (Flambda.create_let closure_var - (Project_closure { set_of_closures = set_var; closure_id }) - (Var closure_var)) - in - closure, project_var - -let pack_expr ~layouts (expr : Flambda.t) = - let layout = Flambda.result_layout ~layouts expr in - match layout with - | Ptop -> assert false - | Pbottom - | Pvalue _ -> expr, [] - | Punboxed_float - | Punboxed_int _ - | Punboxed_vector _ - | Punboxed_product _ -> - (* Unboxed float/int/vector could be boxed in simpler constructions. - This can be changed when all the unboxed types and have been - introduced *) - let var = Variable.create Internal_variable_names.boxed_in_closure in - let closure_var = Variable.create Internal_variable_names.boxing_closure in - let closure, access = boxing_closure var layout in - Flambda.create_let var (Expr expr) - (Flambda.create_let closure_var (Expr closure) (Var closure_var)), - [access] - -let rec accumulate ~(layouts : Layouts.t) ~substitution ~copied_lets ~extracted_lets - (expr : Flambda.t) = - match expr with - | Let { var; body = Var var'; _ } | Let_rec ([var, _], Var var') - when Variable.equal var var' -> - { copied_lets; extracted_lets; - terminator = Flambda_utils.toplevel_substitution substitution expr; - } - (* If the pattern is what lifting let_rec generates, prevent it from being - lifted again. *) - | Let_rec (defs, - Let { var; body = Var var'; - defining_expr = Prim (Pmakeblock _, fields, _); }) - when - Variable.equal var var' - && List.for_all (fun field -> - List.exists (fun (def_var, _) -> Variable.equal def_var field) defs) - fields -> - { copied_lets; extracted_lets; - terminator = Flambda_utils.toplevel_substitution substitution expr; - } - | Let { var; defining_expr = Expr (Var alias); body; _ } - | Let_rec ([var, Expr (Var alias)], body) -> - let layouts = - Layouts.add layouts var (Layouts.find layouts alias) - in - let alias = - match Variable.Map.find alias substitution with - | exception Not_found -> alias - | original_alias -> original_alias - in - accumulate - ~layouts - ~substitution:(Variable.Map.add var alias substitution) - ~copied_lets - ~extracted_lets - body - | Let { var; defining_expr = named; body; _ } - | Let_rec ([var, named], body) - when should_copy named -> - let layout = Flambda.result_layout_named ~layouts named in - let layouts = Layouts.add layouts var layout in - accumulate body - ~layouts - ~substitution - ~copied_lets:((var, named)::copied_lets) - ~extracted_lets - | Let { var; defining_expr = named; body; _ } -> - let layout = Flambda.result_layout_named ~layouts named in - let layouts = Layouts.add layouts var layout in - let extracted = - let renamed = Variable.rename var in - match named with - | Prim (Pmakeblock (tag, (Immutable | Immutable_unique), - _value_kind, Alloc_heap), - args, _dbg) -> - let tag = Tag.create_exn tag in - let args = - List.map (fun v -> - try Variable.Map.find v substitution - with Not_found -> v) - args - in - Block (var, tag, args) - | named -> - let expr = - Flambda_utils.toplevel_substitution substitution - (Flambda.create_let renamed named (Var renamed)) - in - let expr, additionnal_path = pack_expr ~layouts expr in - Expr (var, additionnal_path @ [Field 0], expr) - in - accumulate body - ~layouts - ~substitution - ~copied_lets - ~extracted_lets:(extracted::extracted_lets) - | Let_rec ([var, named], body) -> - let renamed = Variable.rename var in - let def_substitution = Variable.Map.add var renamed substitution in - let layout = Lambda.layout_letrec in - let layouts = Layouts.add layouts var layout in - let layouts = Layouts.add layouts renamed layout in - let expr = - Flambda_utils.toplevel_substitution def_substitution - (Let_rec ([renamed, named], Var renamed)) - in - let extracted = Expr (var, [Field 0], expr) in - accumulate body - ~layouts - ~substitution - ~copied_lets - ~extracted_lets:(extracted::extracted_lets) - | Let_rec (defs, body) -> - let renamed_defs, def_substitution = - List.fold_right (fun (var, def) (acc, substitution) -> - let new_var = Variable.rename var in - (new_var, def) :: acc, - Variable.Map.add var new_var substitution) - defs ([], substitution) - in - let layouts = - List.fold_left (fun layouts (var, _) -> - Layouts.add layouts var Lambda.layout_letrec) - layouts defs - in - let layouts = - List.fold_left (fun layouts (var, _) -> - Layouts.add layouts var Lambda.layout_letrec) - layouts renamed_defs - in - let extracted = - let expr = - let name = Internal_variable_names.lifted_let_rec_block in - Flambda_utils.toplevel_substitution def_substitution - (Let_rec (renamed_defs, - Flambda_utils.name_expr ~name - (Prim (Pmakeblock (0, Immutable, None, Lambda.alloc_heap), - List.map fst renamed_defs, - Debuginfo.none)))) - in - let vars = - List.mapi (fun i (field, _) -> - field, [Field i; Field 0]) - defs - in - Exprs (vars, expr) - in - accumulate body - ~layouts - ~substitution - ~copied_lets - ~extracted_lets:(extracted::extracted_lets) - | _ -> - { copied_lets; - extracted_lets; - terminator = Flambda_utils.toplevel_substitution substitution expr; - } - -let rec make_named (symbol, (path:access list)) : Flambda.named = - match path with - | [] -> Symbol symbol - | [Field i] -> Read_symbol_field (symbol, i) - | Field h :: t -> - let block_name = Internal_variable_names.symbol_field_block in - let block = Variable.create block_name in - let field_name = Internal_variable_names.get_symbol_field in - let field = Variable.create field_name in - Expr ( - Flambda.create_let block (make_named (symbol, t)) - (Flambda.create_let field - (Prim (Pfield (h, Pvalue Pgenval, Pointer, Immutable), [block], - Debuginfo.none)) - (Var field))) - | Project_var { var; kind; closure_id } :: t -> - let closure_name = Internal_variable_names.symbol_field_closure in - let closure = Variable.create closure_name in - let field_name = Internal_variable_names.get_symbol_field in - let field = Variable.create field_name in - Expr ( - Flambda.create_let closure (make_named (symbol, t)) - (Flambda.create_let field - (Project_var ({ closure; var; kind; closure_id})) - (Var field))) - -let rebuild_expr - ~(extracted_definitions : (Symbol.t * projection) Variable.Map.t) - ~(copied_definitions : Flambda.named Variable.Map.t) - ~(substitute : bool) - (expr : Flambda.t) = - let expr_with_read_symbols = - let named = Variable.Map.map make_named extracted_definitions in - Flambda_utils.substitute_named_for_variables - named expr - in - let free_variables = Flambda.free_variables expr_with_read_symbols in - let substitution = - if substitute then - Variable.Map.of_set (fun x -> Variable.rename x) free_variables - else - Variable.Map.of_set (fun x -> x) free_variables - in - let expr_with_read_symbols = - Flambda_utils.toplevel_substitution substitution - expr_with_read_symbols - in - Variable.Map.fold (fun var declaration body -> - let definition = Variable.Map.find var copied_definitions in - Flambda.create_let declaration definition body) - substitution expr_with_read_symbols - -let rebuild (used_variables:Variable.Set.t) (accumulated:accumulated) = - let copied_definitions = Variable.Map.of_list accumulated.copied_lets in - let accumulated_extracted_lets = - List.map (fun decl -> - match decl with - | Block (var, _, _) | Expr (var, _, _) -> - Symbol_utils.Flambda.for_variable (Variable.rename var), decl - | Exprs _ -> - let name = Internal_variable_names.lifted_let_rec_block in - let var = Variable.create name in - Symbol_utils.Flambda.for_variable var, decl) - accumulated.extracted_lets - in - let extracted_definitions = - (* Blocks are lifted to direct top-level Initialize_block: - accessing the value be done directly through the symbol. - Other let bound variables are initialized inside a size - one static block: - accessing the value is done directly through the field 0 - of the symbol. - let rec of size more than one is represented as a block of - all the bound variables allocated inside a size one static - block: - accessing the value is done directly through the right - field of the field 0 of the symbol. *) - List.fold_left (fun map (symbol, decl) -> - match decl with - | Block (var, _tag, _fields) -> - Variable.Map.add var (symbol, []) map - | Expr (var, projection, _expr) -> - Variable.Map.add var (symbol, projection) map - | Exprs (vars, _expr) -> - let map = - List.fold_left (fun map (var, projection) -> - Variable.Map.add var (symbol, projection) map) - map vars - in - map) - Variable.Map.empty accumulated_extracted_lets - in - let extracted = - List.map (fun (symbol, decl) -> - match decl with - | Expr (var, _, decl) -> - let expr = - rebuild_expr ~extracted_definitions ~copied_definitions - ~substitute:true decl - in - if Variable.Set.mem var used_variables then - Initialisation - (symbol, - Tag.create_exn 0, - [expr]) - else - Effect expr - | Exprs (_vars, decl) -> - let expr = - rebuild_expr ~extracted_definitions ~copied_definitions - ~substitute:true decl - in - Initialisation (symbol, Tag.create_exn 0, [expr]) - | Block (_var, tag, fields) -> - let fields = - List.map (fun var -> - rebuild_expr ~extracted_definitions ~copied_definitions - ~substitute:true (Var var)) - fields - in - Initialisation (symbol, tag, fields)) - accumulated_extracted_lets - in - let terminator = - (* We don't need to substitute the variables in the terminator, we - suppose that we did for every other occurrence. Avoiding this - substitution allows this transformation to be idempotent. *) - rebuild_expr ~extracted_definitions ~copied_definitions - ~substitute:false accumulated.terminator - in - List.rev extracted, terminator - -let introduce_symbols expr = - let accumulated = - accumulate expr - ~layouts:Layouts.empty - ~substitution:Variable.Map.empty - ~copied_lets:[] ~extracted_lets:[] - in - let used_variables = Flambda.used_variables expr in - let extracted, terminator = rebuild used_variables accumulated in - extracted, terminator - -let add_extracted introduced program = - List.fold_right (fun extracted program -> - match extracted with - | Initialisation (symbol, tag, def) -> - Flambda.Initialize_symbol (symbol, tag, def, program) - | Effect effect -> - Flambda.Effect (effect, program)) - introduced program - -let rec split_program (program : Flambda.program_body) : Flambda.program_body = - match program with - | End s -> End s - | Let_symbol (s, def, program) -> - Let_symbol (s, def, split_program program) - | Let_rec_symbol (defs, program) -> - Let_rec_symbol (defs, split_program program) - | Effect (expr, program) -> - let program = split_program program in - let introduced, expr = introduce_symbols expr in - add_extracted introduced (Flambda.Effect (expr, program)) - | Initialize_symbol (symbol, tag, ((_::_::_) as fields), program) -> - (* CR-someday pchambart: currently the only initialize_symbol with more - than 1 field is the module block. This could evolve, in that case - this pattern should be handled properly. *) - Initialize_symbol (symbol, tag, fields, split_program program) - | Initialize_symbol (sym, tag, [], program) -> - Let_symbol (sym, Block (tag, []), split_program program) - | Initialize_symbol (symbol, tag, [field], program) -> - let program = split_program program in - let introduced, field = introduce_symbols field in - add_extracted introduced - (Flambda.Initialize_symbol (symbol, tag, [field], program)) - -let lift ~backend:_ (program : Flambda.program) = - { program with - program_body = split_program program.program_body; - } diff --git a/middle_end/flambda/lift_let_to_initialize_symbol.mli b/middle_end/flambda/lift_let_to_initialize_symbol.mli deleted file mode 100644 index afb1c60f9cb..00000000000 --- a/middle_end/flambda/lift_let_to_initialize_symbol.mli +++ /dev/null @@ -1,38 +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"] - -(** Lift toplevel [Let]-expressions to Flambda [program] constructions such - that the results of evaluation of such expressions may be accessed - directly, through symbols, rather than through closures. The - [Let]-expressions typically come from the compilation of modules (using - the bytecode strategy) in [Translmod]. - - This means of compilation supersedes the old "transl_store_" methodology - for native code. - - An [Initialize_symbol] construction generated by this pass may be - subsequently rewritten to [Let_symbol] if it is discovered that the - initializer is in fact constant. (See [Initialize_symbol_to_let_symbol].) - - The [program] constructions generated by this pass will be joined by - others that arise from the lifting of constants (see [Lift_constants]). -*) -val lift - : backend:(module Backend_intf.S) - -> Flambda.program - -> Flambda.program diff --git a/middle_end/flambda/parameter.ml b/middle_end/flambda/parameter.ml deleted file mode 100644 index 9146b72869e..00000000000 --- a/middle_end/flambda/parameter.ml +++ /dev/null @@ -1,81 +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-66"] -open! Int_replace_polymorphic_compare - -[@@@ocaml.warning "+9"] -(* Warning 9 is enabled to ensure correct update of each function when - a field is added to type parameter *) - -type parameter = { - var : Variable.t; - mode : Lambda.alloc_mode; - kind : Lambda.layout; -} - -let wrap var mode kind = { var; mode; kind } - -let var p = p.var -let alloc_mode p = p.mode -let kind p = p.kind - -module M = - Identifiable.Make (struct - type t = parameter - - let compare - { var = var1; mode = _ ; kind = _ } - { var = var2; mode = _ ; kind = _ } = - Variable.compare var1 var2 - - let equal - { var = var1; mode = _ ; kind = _ } - { var = var2; mode = _ ; kind = _ } = - Variable.equal var1 var2 - - let hash { var; mode = _ ; kind = _ } = - Variable.hash var - - let print ppf { var; mode ; kind } = - let mode = match mode with - | Lambda.Alloc_heap -> "" - | Lambda.Alloc_local -> "[->L]" in - Format.fprintf ppf "%a%s[%a]" - Variable.print var mode Printlambda.layout kind - - let output o { var; mode = _ ; kind = _ } = - Variable.output o var - end) - -module T = M.T -include T - -module Map = M.Map -module Tbl = M.Tbl -module Set = struct - include M.Set - let vars l = Variable.Set.of_list (List.map var l) -end - -let rename ?current_compilation_unit p = - { p with var = Variable.rename ?current_compilation_unit p.var } - -let map_var f { var ; mode ; kind } = { var = f var; mode; kind } - -module List = struct - let vars params = List.map (fun { var ; mode = _ ; kind = _ } -> var) params -end diff --git a/middle_end/flambda/parameter.mli b/middle_end/flambda/parameter.mli deleted file mode 100644 index 07d0a01104e..00000000000 --- a/middle_end/flambda/parameter.mli +++ /dev/null @@ -1,58 +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"] - -(** [Parameter.t] carries a unique [Variable.t] used as function parameter. - It can also carry annotations about the usage of the variable. *) - -type t -type parameter = t - -(** Make a parameter from a variable with default attributes *) -val wrap : Variable.t -> Lambda.alloc_mode -> Lambda.layout -> t - -val var : t -> Variable.t - -(** Mode of the resulting closure after partially applying - up to and including this parameter *) -val alloc_mode : t -> Lambda.alloc_mode - -val kind : t -> Lambda.layout - -(** Rename the inner variable of the parameter *) -val rename - : ?current_compilation_unit:Compilation_unit.t - -> t - -> t - -val map_var : (Variable.t -> Variable.t) -> t -> t - -module T : Identifiable.Thing with type t = t - -module Set : sig - include Identifiable.Set with module T := T - val vars : parameter list -> Variable.Set.t -end - -include Identifiable.S with type t := t - and module T := T - and module Set := Set - -module List : sig - (** extract variables from a list of parameters, preserving the order *) - val vars : t list -> Variable.t list -end diff --git a/middle_end/flambda/pass_wrapper.ml b/middle_end/flambda/pass_wrapper.ml deleted file mode 100644 index a20053326f8..00000000000 --- a/middle_end/flambda/pass_wrapper.ml +++ /dev/null @@ -1,35 +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-66"] -open! Int_replace_polymorphic_compare - -let register ~pass_name = - Clflags.all_passes := pass_name :: !Clflags.all_passes - -let with_dump ~ppf_dump ~pass_name ~f ~input ~print_input ~print_output = - let dump = Clflags.dumped_pass pass_name in - let result = f () in - match result with - | None -> - if dump then Format.fprintf ppf_dump "%s: no-op.\n\n%!" pass_name; - None - | Some result -> - if dump then begin - Format.fprintf ppf_dump "Before %s:@ %a@.@." pass_name print_input input; - Format.fprintf ppf_dump "After %s:@ %a@.@." pass_name print_output result; - end; - Some result diff --git a/middle_end/flambda/pass_wrapper.mli b/middle_end/flambda/pass_wrapper.mli deleted file mode 100644 index 3a30e61d6d9..00000000000 --- a/middle_end/flambda/pass_wrapper.mli +++ /dev/null @@ -1,26 +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. *) -(* *) -(**************************************************************************) - -val register : pass_name:string -> unit - -val with_dump - : ppf_dump:Format.formatter - -> pass_name:string - -> f:(unit -> 'b option) - -> input:'a - -> print_input:(Format.formatter -> 'a -> unit) - -> print_output:(Format.formatter -> 'b -> unit) - -> 'b option diff --git a/middle_end/flambda/projection.ml b/middle_end/flambda/projection.ml deleted file mode 100644 index eeaf499bf06..00000000000 --- a/middle_end/flambda/projection.ml +++ /dev/null @@ -1,171 +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-66"] -open! Int_replace_polymorphic_compare - -(* CR-someday mshinwell: Move these three types into their own modules. *) - -type project_closure = { - set_of_closures : Variable.t; - closure_id : Closure_id.t; -} - -type move_within_set_of_closures = { - closure : Variable.t; - start_from : Closure_id.t; - move_to : Closure_id.t; -} - -type project_var = { - closure : Variable.t; - closure_id : Closure_id.t; - var : Var_within_closure.t; - kind : Lambda.layout; -} - -let compare_project_var - ({ closure = closure1; closure_id = closure_id1; var = var1; } - : project_var) - ({ closure = closure2; closure_id = closure_id2; var = var2; } - : project_var) = - let c = Variable.compare closure1 closure2 in - if c <> 0 then c - else - let c = Closure_id.compare closure_id1 closure_id2 in - if c <> 0 then c - else - Var_within_closure.compare var1 var2 - -let compare_move_within_set_of_closures - ({ closure = closure1; start_from = start_from1; move_to = move_to1; } - : move_within_set_of_closures) - ({ closure = closure2; start_from = start_from2; move_to = move_to2; } - : move_within_set_of_closures) = - let c = Variable.compare closure1 closure2 in - if c <> 0 then c - else - let c = Closure_id.compare start_from1 start_from2 in - if c <> 0 then c - else - Closure_id.compare move_to1 move_to2 - -let compare_project_closure - ({ set_of_closures = set_of_closures1; closure_id = closure_id1; } - : project_closure) - ({ set_of_closures = set_of_closures2; closure_id = closure_id2; } - : project_closure) = - let c = Variable.compare set_of_closures1 set_of_closures2 in - if c <> 0 then c - else - Closure_id.compare closure_id1 closure_id2 - -let print_project_closure ppf (project_closure : project_closure) = - Format.fprintf ppf "@[<2>(project_closure@ %a@ from@ %a)@]" - Closure_id.print project_closure.closure_id - Variable.print project_closure.set_of_closures - -let print_move_within_set_of_closures ppf - (move_within_set_of_closures : move_within_set_of_closures) = - Format.fprintf ppf - "@[<2>(move_within_set_of_closures@ %a <-- %a@ (closure = %a))@]" - Closure_id.print move_within_set_of_closures.move_to - Closure_id.print move_within_set_of_closures.start_from - Variable.print move_within_set_of_closures.closure - -let print_project_var ppf (project_var : project_var) = - Format.fprintf ppf "@[<2>(project_var@ %a@ from %a=%a)@]" - Var_within_closure.print project_var.var - Closure_id.print project_var.closure_id - Variable.print project_var.closure - -type t = - | Project_var of project_var - | Project_closure of project_closure - | Move_within_set_of_closures of move_within_set_of_closures - | Field of int * Variable.t - -include Identifiable.Make (struct - type nonrec t = t - - let compare t1 t2 = - match t1, t2 with - | Project_var project_var1, Project_var project_var2 -> - compare_project_var project_var1 project_var2 - | Project_closure project_closure1, Project_closure project_closure2 -> - compare_project_closure project_closure1 project_closure2 - | Move_within_set_of_closures move1, Move_within_set_of_closures move2 -> - compare_move_within_set_of_closures move1 move2 - | Field (index1, var1), Field (index2, var2) -> - let c = compare index1 index2 in - if c <> 0 then c - else Variable.compare var1 var2 - | Project_var _, _ -> -1 - | _, Project_var _ -> 1 - | Project_closure _, _ -> -1 - | _, Project_closure _ -> 1 - | Move_within_set_of_closures _, _ -> -1 - | _, Move_within_set_of_closures _ -> 1 - - let equal t1 t2 = - (compare t1 t2) = 0 - - let hash = Hashtbl.hash - - let print ppf t = - match t with - | Project_closure (project_closure) -> - print_project_closure ppf project_closure - | Project_var (project_var) -> print_project_var ppf project_var - | Move_within_set_of_closures (move_within_set_of_closures) -> - print_move_within_set_of_closures ppf move_within_set_of_closures - | Field (field_index, var) -> - Format.fprintf ppf "Field %d of %a" field_index Variable.print var - - let output _ _ = failwith "Projection.output: not yet implemented" -end) - -let projecting_from t = - match t with - | Project_var { closure; _ } -> closure - | Project_closure { set_of_closures; _ } -> set_of_closures - | Move_within_set_of_closures { closure; _ } -> closure - | Field (_, var) -> var - -let map_projecting_from t ~f : t = - match t with - | Project_var project_var -> - let project_var : project_var = - { project_var with - closure = f project_var.closure; - } - in - Project_var project_var - | Project_closure project_closure -> - let project_closure : project_closure = - { project_closure with - set_of_closures = f project_closure.set_of_closures; - } - in - Project_closure project_closure - | Move_within_set_of_closures move -> - let move : move_within_set_of_closures = - { move with - closure = f move.closure; - } - in - Move_within_set_of_closures move - | Field (field_index, var) -> Field (field_index, f var) diff --git a/middle_end/flambda/projection.mli b/middle_end/flambda/projection.mli deleted file mode 100644 index 4d54c57719a..00000000000 --- a/middle_end/flambda/projection.mli +++ /dev/null @@ -1,81 +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. *) -(* *) -(**************************************************************************) - -(** Representation of projections from closures and blocks. *) - -(** The selection of one closure given a set of closures, required before - a function defined by said set of closures can be applied. See more - detailed documentation below on [set_of_closures]. *) -type project_closure = { - set_of_closures : Variable.t; (** must yield a set of closures *) - closure_id : Closure_id.t; -} - -(** The selection of one closure given another closure in the same set of - closures. See more detailed documentation below on [set_of_closures]. - The [move_to] closure must be part of the free variables of - [start_from]. *) -type move_within_set_of_closures = { - closure : Variable.t; (** must yield a closure *) - start_from : Closure_id.t; - move_to : Closure_id.t; -} - -(** The selection from a closure of a variable bound by said closure. - In other words, access to a function's environment. Also see more - detailed documentation below on [set_of_closures]. *) -type project_var = { - closure : Variable.t; (** must yield a closure *) - closure_id : Closure_id.t; - var : Var_within_closure.t; - kind : Lambda.layout; -} - -val print_project_closure - : Format.formatter - -> project_closure - -> unit - -val print_move_within_set_of_closures - : Format.formatter - -> move_within_set_of_closures - -> unit - -val print_project_var - : Format.formatter - -> project_var - -> unit - -val compare_project_var : project_var -> project_var -> int -val compare_project_closure : project_closure -> project_closure -> int -val compare_move_within_set_of_closures - : move_within_set_of_closures - -> move_within_set_of_closures - -> int - -type t = - | Project_var of project_var - | Project_closure of project_closure - | Move_within_set_of_closures of move_within_set_of_closures - | Field of int * Variable.t - -include Identifiable.S with type t := t - -(** Return which variable the given projection projects from. *) -val projecting_from : t -> Variable.t - -(** Change the variable that the given projection projects from. *) -val map_projecting_from : t -> f:(Variable.t -> Variable.t) -> t diff --git a/middle_end/flambda/ref_to_variables.ml b/middle_end/flambda/ref_to_variables.ml deleted file mode 100644 index 25d67eef1b1..00000000000 --- a/middle_end/flambda/ref_to_variables.ml +++ /dev/null @@ -1,203 +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-66"] -open! Int_replace_polymorphic_compare - -let variables_not_used_as_local_reference (tree:Flambda.t) = - let set = ref Variable.Set.empty in - let rec loop_named (flam : Flambda.named) = - match flam with - (* Directly used block: does not prevent use as a variable *) - | Prim(Pfield _, [_], _) - | Prim(Poffsetref _, [_], _) -> () - | Prim(Psetfield _, [_block; v], _) -> - (* block is not prevented to be used as a local reference, but v is *) - set := Variable.Set.add v !set - | Prim(_, _, _) - | Symbol _ |Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ | Project_closure _ - | Move_within_set_of_closures _ | Project_var _ -> - set := Variable.Set.union !set (Flambda.free_variables_named flam) - | Set_of_closures set_of_closures -> - set := Variable.Set.union !set (Flambda.free_variables_named flam); - Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) -> - loop function_decl.body) - set_of_closures.function_decls.funs - | Expr e -> - loop e - and loop (flam : Flambda.t) = - match flam with - | Let { defining_expr; body; _ } -> - loop_named defining_expr; - loop body - | Let_rec (defs, body) -> - List.iter (fun (_var, named) -> loop_named named) defs; - loop body - | Var v -> - set := Variable.Set.add v !set - | Let_mutable { initial_value = v; body } -> - set := Variable.Set.add v !set; - loop body - | If_then_else (cond, ifso, ifnot, _kind) -> - set := Variable.Set.add cond !set; - loop ifso; - loop ifnot - | Switch (cond, { consts; blocks; failaction; kind = _ }) -> - set := Variable.Set.add cond !set; - List.iter (fun (_, branch) -> loop branch) consts; - List.iter (fun (_, branch) -> loop branch) blocks; - Option.iter loop failaction - | String_switch (cond, branches, default, _kind) -> - set := Variable.Set.add cond !set; - List.iter (fun (_, branch) -> loop branch) branches; - Option.iter loop default - | Static_catch (_, _, body, handler, _) -> - loop body; - loop handler - | Try_with (body, _, handler, _kind) -> - loop body; - loop handler - | While (cond, body) -> - loop cond; - loop body - | For { bound_var = _; from_value; to_value; direction = _; body; } -> - set := Variable.Set.add from_value !set; - set := Variable.Set.add to_value !set; - loop body - | Static_raise (_, args) -> - set := Variable.Set.union (Variable.Set.of_list args) !set - | Region body -> - loop body - | Exclave body -> - loop body - | Proved_unreachable | Apply _ | Send _ | Assign _ -> - set := Variable.Set.union !set (Flambda.free_variables flam) - in - loop tree; - !set - -let variables_containing_ref (flam:Flambda.t) = - let map = ref Variable.Map.empty in - let aux (flam : Flambda.t) = - match flam with - | Let { var; - defining_expr = Prim(Pmakeblock(0, Mutable, _, _), l, _); - } -> - map := Variable.Map.add var (List.length l) !map - | _ -> () - in - Flambda_iterators.iter aux (fun _ -> ()) flam; - !map - -let eliminate_ref_of_expr flam = - let variables_not_used_as_local_reference = - variables_not_used_as_local_reference flam - in - let convertible_variables = - Variable.Map.filter - (fun v _ -> - not (Variable.Set.mem v variables_not_used_as_local_reference)) - (variables_containing_ref flam) - in - if Variable.Map.cardinal convertible_variables = 0 then flam - else - let convertible_variables = - Variable.Map.mapi (fun v size -> - Array.init size (fun _ -> Mutable_variable.create_from_variable v)) - convertible_variables - in - let convertible_variable v = Variable.Map.mem v convertible_variables in - let get_variable v field = - let arr = try Variable.Map.find v convertible_variables - with Not_found -> assert false in - if Array.length arr <= field - then None (* This case could apply when inlining code containing GADTS *) - else Some (arr.(field), Array.length arr) - in - let aux (flam : Flambda.t) : Flambda.t = - match flam with - | Let { var; - defining_expr = Prim(Pmakeblock(0, Mutable, shape, _mode), l,_); - body } - when convertible_variable var -> - let shape = match shape with - | None -> List.map (fun _ -> Lambda.Pgenval) l - | Some shape -> shape - in - let _, expr = - List.fold_left2 (fun (field,body) init kind -> - match get_variable var field with - | None -> assert false - | Some (field_var, _) -> - field+1, - (Let_mutable { var = field_var; - initial_value = init; - body; - contents_kind = Lambda.Pvalue kind } : Flambda.t)) - (0,body) l shape in - expr - | Let _ | Let_mutable _ - | Assign _ | Var _ | Apply _ - | Let_rec _ | Switch _ | String_switch _ - | Static_raise _ | Static_catch _ - | Try_with _ | If_then_else _ - | While _ | For _ | Region _ | Exclave _ | Send _ | Proved_unreachable -> - flam - and aux_named (named : Flambda.named) : Flambda.named = - match named with - | Prim(Pfield (field, _, _, _), [v], _) - when convertible_variable v -> - (match get_variable v field with - | None -> Expr Proved_unreachable - | Some (var,_) -> Read_mutable var) - | Prim(Poffsetref delta, [v], dbg) - when convertible_variable v -> - (match get_variable v 0 with - | None -> Expr Proved_unreachable - | Some (var,size) -> - if size = 1 - then begin - let mut_name = Internal_variable_names.read_mutable in - let mut = Variable.create mut_name in - let new_value_name = Internal_variable_names.offsetted in - let new_value = Variable.create new_value_name in - let expr = - Flambda.create_let mut (Read_mutable var) - (Flambda.create_let new_value - (Prim(Poffsetint delta, [mut], dbg)) - (Assign { being_assigned = var; new_value })) - in - Expr expr - end - else - Expr Proved_unreachable) - | Prim(Psetfield (field, _, _), [v; new_value], _) - when convertible_variable v -> - (match get_variable v field with - | None -> Expr Proved_unreachable - | Some (being_assigned,_) -> - Expr (Assign { being_assigned; new_value })) - | Prim _ | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ | Set_of_closures _ | Project_closure _ - | Move_within_set_of_closures _ | Project_var _ | Expr _ -> - named - in - Flambda_iterators.map aux aux_named flam - -let eliminate_ref (program:Flambda.program) = - Flambda_iterators.map_exprs_at_toplevel_of_program program - ~f:eliminate_ref_of_expr diff --git a/middle_end/flambda/ref_to_variables.mli b/middle_end/flambda/ref_to_variables.mli deleted file mode 100644 index 38d36889175..00000000000 --- a/middle_end/flambda/ref_to_variables.mli +++ /dev/null @@ -1,23 +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"] - -(** Transform [let]-bound references into variables. *) - -val eliminate_ref - : Flambda.program - -> Flambda.program diff --git a/middle_end/flambda/remove_free_vars_equal_to_args.ml b/middle_end/flambda/remove_free_vars_equal_to_args.ml deleted file mode 100644 index d13a0a65edc..00000000000 --- a/middle_end/flambda/remove_free_vars_equal_to_args.ml +++ /dev/null @@ -1,98 +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-66"] -open! Int_replace_polymorphic_compare - -let pass_name = "remove-free-vars-equal-to-args" -let () = Pass_wrapper.register ~pass_name - -let rewrite_one_function_decl ~(function_decl : Flambda.function_declaration) - ~back_free_vars ~specialised_args = - let params_for_equal_free_vars = - List.fold_left (fun subst param -> - match Variable.Map.find param specialised_args with - | exception Not_found -> - (* param is not specialised *) - subst - | (spec_to : Flambda.specialised_to) -> - let outside_var = spec_to.var in - match Variable.Map.find outside_var back_free_vars with - | exception Not_found -> - (* No free variables equal to the param *) - subst - | set -> - (* Replace the free variables equal to a parameter *) - Variable.Set.fold (fun free_var subst -> - Variable.Map.add free_var param subst) - set subst) - Variable.Map.empty (Parameter.List.vars function_decl.params) - in - if Variable.Map.is_empty params_for_equal_free_vars then - function_decl - else - let body = - Flambda_utils.toplevel_substitution - params_for_equal_free_vars - function_decl.body - in - Flambda.update_function_declaration_body function_decl ~body - -let rewrite_one_set_of_closures (set_of_closures : Flambda.set_of_closures) = - let back_free_vars = - Variable.Map.fold (fun var (outside_var : Flambda.specialised_to) map -> - let set = - match Variable.Map.find outside_var.var map with - | exception Not_found -> Variable.Set.singleton var - | set -> Variable.Set.add var set - in - Variable.Map.add outside_var.var set map) - set_of_closures.free_vars Variable.Map.empty - in - let done_something = ref false in - let funs = - Variable.Map.map (fun function_decl -> - let new_function_decl = - rewrite_one_function_decl ~function_decl ~back_free_vars - ~specialised_args:set_of_closures.specialised_args - in - if not (new_function_decl == function_decl) then begin - done_something := true - end; - new_function_decl) - set_of_closures.function_decls.funs - in - if not !done_something then - None - else - let function_decls = - Flambda.update_function_declarations - set_of_closures.function_decls ~funs - in - let set_of_closures = - Flambda.create_set_of_closures - ~function_decls - ~free_vars:set_of_closures.free_vars - ~specialised_args:set_of_closures.specialised_args - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - Some set_of_closures - -let run ~ppf_dump set_of_closures = - Pass_wrapper.with_dump ~ppf_dump ~pass_name ~input:set_of_closures - ~print_input:Flambda.print_set_of_closures - ~print_output:Flambda.print_set_of_closures - ~f:(fun () -> rewrite_one_set_of_closures set_of_closures) diff --git a/middle_end/flambda/remove_free_vars_equal_to_args.mli b/middle_end/flambda/remove_free_vars_equal_to_args.mli deleted file mode 100644 index 49f25ac1067..00000000000 --- a/middle_end/flambda/remove_free_vars_equal_to_args.mli +++ /dev/null @@ -1,23 +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. *) -(* *) -(**************************************************************************) - -(** Replace free variables in closures known to be equal to specialised - arguments of such closures with those specialised arguments. *) - -val run - : ppf_dump:Format.formatter - -> Flambda.set_of_closures - -> Flambda.set_of_closures option diff --git a/middle_end/flambda/remove_unused_arguments.ml b/middle_end/flambda/remove_unused_arguments.ml deleted file mode 100644 index 00be8ad51b0..00000000000 --- a/middle_end/flambda/remove_unused_arguments.ml +++ /dev/null @@ -1,252 +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-66"] -open! Int_replace_polymorphic_compare - -let pass_name = "remove-unused-arguments" -let () = Clflags.all_passes := pass_name :: !Clflags.all_passes - -let rename_var var = - Variable.rename var - ~current_compilation_unit:(Compilation_unit.get_current_exn ()) - -let remove_params unused (fun_decl: Flambda.function_declaration) - ~new_fun_var = - let unused_params, used_params = - List.partition (fun v -> Variable.Set.mem (Parameter.var v) unused) - fun_decl.params - in - let unused_params = List.filter (fun v -> - Variable.Set.mem (Parameter.var v) fun_decl.free_variables) unused_params - in - let body = - List.fold_left (fun body param -> - Flambda.create_let (Parameter.var param) (Const (Int 0)) body) - fun_decl.body - unused_params - in - Flambda.create_function_declaration - ~params:used_params ~alloc_mode:fun_decl.alloc_mode ~region:fun_decl.region - ~body - ~return_layout:fun_decl.return_layout - ~stub:fun_decl.stub ~inline:fun_decl.inline - ~specialise:fun_decl.specialise ~check:fun_decl.check - ~is_a_functor:fun_decl.is_a_functor - ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var)) - ~poll:fun_decl.poll - -let make_stub unused var (fun_decl : Flambda.function_declaration) - ~specialised_args ~additional_specialised_args = - let renamed = rename_var var in - let args' = - List.map (fun param -> param, Parameter.rename param) fun_decl.params - in - let used_args' = - List.filter (fun (param, _) -> - not (Variable.Set.mem (Parameter.var param) unused)) args' - in - let args'_var = - List.map (fun (p1, p2) -> Parameter.var p1, Parameter.var p2) args' - in - let args_renaming = Variable.Map.of_list args'_var in - let additional_specialised_args = - List.fold_left (fun additional_specialised_args (original_arg,arg) -> - match Variable.Map.find original_arg specialised_args with - | exception Not_found -> additional_specialised_args - | (outer_var : Flambda.specialised_to) -> - (* CR-soon mshinwell: share with Augment_specialised_args *) - let outer_var : Flambda.specialised_to = - match outer_var.projection with - | None -> outer_var - | Some projection -> - let projection = - Projection.map_projecting_from projection ~f:(fun var -> - match Variable.Map.find var args_renaming with - | exception Not_found -> - (* Must always be a parameter of this - [function_decl]. *) - assert false - | wrapper_arg -> wrapper_arg) - in - { outer_var with - projection = Some projection; - } - in - Variable.Map.add arg outer_var additional_specialised_args) - additional_specialised_args args'_var - in - let args = List.map (fun (_, var) -> var) used_args' in - let kind = Flambda.Direct (Closure_id.wrap renamed) in - let body : Flambda.t = - Apply { - func = renamed; - args = Parameter.List.vars args; - result_layout = fun_decl.return_layout; - kind; - dbg = fun_decl.dbg; - reg_close = Rc_normal; - mode = if fun_decl.region then Lambda.alloc_heap else Lambda.alloc_local; - inlined = Default_inlined; - specialise = Default_specialise; - probe = None; - } - in - let function_decl = - Flambda.create_function_declaration - ~params:(List.map snd args') - ~alloc_mode:fun_decl.alloc_mode ~region:fun_decl.region - ~body ~return_layout:fun_decl.return_layout - ~stub:true ~inline:Default_inline - ~specialise:Default_specialise - ~check:Default_check - ~is_a_functor:fun_decl.is_a_functor - ~closure_origin:fun_decl.closure_origin - ~poll:Default_poll (* don't propagate attribute to wrappers *) - in - function_decl, renamed, additional_specialised_args - -let separate_unused_arguments ~only_specialised - ~(set_of_closures : Flambda.set_of_closures) = - let function_decls = set_of_closures.function_decls in - let unused = Invariant_params.unused_arguments function_decls in - let non_stub_arguments = - Variable.Map.fold (fun _ (decl : Flambda.function_declaration) acc -> - if decl.stub then - acc - else - Variable.Set.union acc (Parameter.Set.vars decl.Flambda.params)) - function_decls.funs Variable.Set.empty - in - let unused = Variable.Set.inter non_stub_arguments unused in - let specialised_args = Variable.Map.keys set_of_closures.specialised_args in - let unused = - if only_specialised then Variable.Set.inter specialised_args unused - else unused - in - if Variable.Set.is_empty unused - then None - else begin - let funs, additional_specialised_args = - Variable.Map.fold (fun fun_id (fun_decl : Flambda.function_declaration) - (funs, additional_specialised_args) -> - if List.exists (fun v -> Variable.Set.mem (Parameter.var v) unused) - fun_decl.params - then begin - let stub, renamed_fun_id, additional_specialised_args = - make_stub unused fun_id fun_decl - ~specialised_args:set_of_closures.specialised_args - ~additional_specialised_args - in - let cleaned = - remove_params unused fun_decl ~new_fun_var:renamed_fun_id - in - Variable.Map.add fun_id stub - (Variable.Map.add renamed_fun_id cleaned funs), - additional_specialised_args - end - else - Variable.Map.add fun_id fun_decl funs, - additional_specialised_args - ) - function_decls.funs (Variable.Map.empty, Variable.Map.empty) - in - let specialised_args = - Variable.Map.disjoint_union additional_specialised_args - (Variable.Map.filter (fun param _ -> - not (Variable.Set.mem param unused)) - set_of_closures.specialised_args) - in - let specialised_args = - Flambda_utils.clean_projections ~which_variables:specialised_args - in - let function_decls = - Flambda.update_function_declarations function_decls ~funs - in - let set_of_closures = - Flambda.create_set_of_closures ~function_decls - ~free_vars:set_of_closures.free_vars ~specialised_args - (* CR-soon mshinwell: Use direct_call_surrogates for this - transformation. *) - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - Some set_of_closures - end - -(* Splitting is not always beneficial. For instance when a function - is only indirectly called, suppressing unused arguments does not - benefit, and introduce an useless intermediate call. Specialised - args should always be beneficial since they should not be used in - indirect calls. *) -let should_split_only_specialised_args - (fun_decls : Flambda.function_declarations) = - if not !Clflags.remove_unused_arguments then begin - true - end else begin - let no_recursive_functions = - Variable.Set.is_empty - (Find_recursive_functions.in_function_declarations fun_decls) - in - let number_of_non_stub_functions = - Variable.Map.cardinal - (Variable.Map.filter (fun _ { Flambda.stub } -> not stub) - fun_decls.funs) - in - (* CR-soon lwhite: this criteria could use some justification. - mshinwell: pchambart cannot remember how these criteria arose, - but we're going to leave this as-is for 4.03. *) - no_recursive_functions && (number_of_non_stub_functions <= 1) - end - -let separate_unused_arguments_in_set_of_closures set_of_closures = - let dump = Clflags.dumped_pass pass_name in - let only_specialised = - should_split_only_specialised_args - set_of_closures.Flambda.function_decls - in - match separate_unused_arguments ~only_specialised ~set_of_closures with - | None -> - if dump then - Format.eprintf "No change for Remove_unused_arguments:@ %a@.@." - Flambda.print_set_of_closures set_of_closures; - None - | Some result -> - if dump then - Format.eprintf "Before Remove_unused_arguments:@ %a@.@.\ - After Remove_unused_arguments:@ %a@.@." - Flambda.print_set_of_closures set_of_closures - Flambda.print_set_of_closures result; - Some result - -let separate_unused_arguments_in_closures_expr tree = - let aux_named (named : Flambda.named) : Flambda.named = - match named with - | Set_of_closures set_of_closures -> begin - let only_specialised = - should_split_only_specialised_args - set_of_closures.function_decls - in - match separate_unused_arguments ~only_specialised ~set_of_closures with - | None -> named - | Some set_of_closures -> Set_of_closures set_of_closures - end - | e -> e - in - Flambda_iterators.map_named aux_named tree - -let separate_unused_arguments_in_closures program = - Flambda_iterators.map_exprs_at_toplevel_of_program program ~f:(fun expr -> - separate_unused_arguments_in_closures_expr expr) diff --git a/middle_end/flambda/remove_unused_arguments.mli b/middle_end/flambda/remove_unused_arguments.mli deleted file mode 100644 index 852fce48fa7..00000000000 --- a/middle_end/flambda/remove_unused_arguments.mli +++ /dev/null @@ -1,37 +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"] - -(** Introduce a stub function to avoid depending on unused arguments. - - For instance, it turns - [let rec fact n unused = - if n = 0 then 1 - else n * fact (n-1) unused] - into - [let rec fact' n = - if n = 0 then 1 - else n * fact' (n-1) - and fact n unused = fact' n] -*) -val separate_unused_arguments_in_closures - : Flambda.program - -> Flambda.program - -val separate_unused_arguments_in_set_of_closures - : Flambda.set_of_closures - -> Flambda.set_of_closures option diff --git a/middle_end/flambda/remove_unused_closure_vars.ml b/middle_end/flambda/remove_unused_closure_vars.ml deleted file mode 100644 index 394560cb6c1..00000000000 --- a/middle_end/flambda/remove_unused_closure_vars.ml +++ /dev/null @@ -1,134 +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-66"] -open! Int_replace_polymorphic_compare - -(** A variable in a closure can either be used by the closure itself - or by an inlined version of the function. *) -let remove_unused_closure_variables ~remove_direct_call_surrogates program = - let used_vars_within_closure, used_closure_ids = - let used = Var_within_closure.Tbl.create 13 in - let used_fun = Closure_id.Tbl.create 13 in - let aux_named (named : Flambda.named) = - match named with - | Project_closure { set_of_closures = _; closure_id } -> - Closure_id.Tbl.add used_fun closure_id () - | Project_var { closure_id; var } -> - Var_within_closure.Tbl.add used var (); - Closure_id.Tbl.add used_fun closure_id () - | Move_within_set_of_closures { closure = _; start_from; move_to } -> - Closure_id.Tbl.add used_fun start_from (); - Closure_id.Tbl.add used_fun move_to () - | Symbol _ | Const _ | Set_of_closures _ | Prim _ | Expr _ - | Allocated_const _ | Read_mutable _ | Read_symbol_field _ -> () - in - Flambda_iterators.iter_named_of_program ~f:aux_named program; - used, used_fun - in - let aux_named _ (named : Flambda.named) : Flambda.named = - match named with - | Set_of_closures ({ function_decls; free_vars; _ } as set_of_closures) -> - let direct_call_surrogates = - if remove_direct_call_surrogates then Variable.Set.empty - else - Variable.Set.of_list - (Variable.Map.data set_of_closures.direct_call_surrogates) - in - let rec add_needed needed_funs remaining_funs free_vars_of_kept_funs = - let new_needed_funs, remaining_funs = - (* Keep a function if it is used either by the rest of the code, - (in used_closure_ids), or by any other kept function - (in free_vars_of_kept_funs) *) - Variable.Map.partition (fun fun_id _ -> - Variable.Set.mem fun_id free_vars_of_kept_funs - || Closure_id.Tbl.mem used_closure_ids - (Closure_id.wrap fun_id) - || Variable.Set.mem fun_id direct_call_surrogates) - remaining_funs - in - if Variable.Map.is_empty new_needed_funs then - (* If no new function is needed, we reached fixpoint *) - needed_funs, free_vars_of_kept_funs - else begin - let needed_funs = - Variable.Map.disjoint_union needed_funs new_needed_funs - in - let free_vars_of_kept_funs = - Variable.Map.fold (fun _ { Flambda. free_variables } acc -> - Variable.Set.union free_variables acc) - new_needed_funs - free_vars_of_kept_funs - in - add_needed needed_funs remaining_funs free_vars_of_kept_funs - end - in - let funs, free_vars_of_kept_funs = - add_needed Variable.Map.empty function_decls.funs Variable.Set.empty - in - let free_vars = - Variable.Map.filter (fun id _var -> - Variable.Set.mem id free_vars_of_kept_funs - || Var_within_closure.Tbl.mem - used_vars_within_closure - (Var_within_closure.wrap id)) - free_vars - in - let function_decls = - Flambda.update_function_declarations function_decls ~funs - in - let specialised_args = - (* Remove specialised args that are used by removed functions *) - let all_remaining_arguments = - Variable.Map.fold (fun _ { Flambda.params } set -> - Variable.Set.union set (Parameter.Set.vars params)) - funs Variable.Set.empty - in - Variable.Map.filter (fun arg _ -> - Variable.Set.mem arg all_remaining_arguments) - set_of_closures.specialised_args - in - let free_vars = - Flambda_utils.clean_projections ~which_variables:free_vars - in - let direct_call_surrogates = - (* Remove direct call surrogates where either the existing function - or the surrogate has been eliminated. *) - Variable.Map.fold (fun existing surrogate surrogates -> - if not (Variable.Map.mem existing funs) - || not (Variable.Map.mem surrogate funs) - then surrogates - else Variable.Map.add existing surrogate surrogates) - set_of_closures.direct_call_surrogates - Variable.Map.empty - in - if Variable.Map.is_empty function_decls.funs then - (* All of the closure ids are dead. The whole set _should_ be dead, but - sometimes in odd cases we don't manage to kill it (for example, if - it's the value of an [initialize_symbol]). In any event, no one is - projecting anything out so we can just swap in the unit value. Note - that there can't even be any values being projected out, because that - would require using a closure id first. *) - Const (Int 0) - else - let set_of_closures = - Flambda.create_set_of_closures ~function_decls - ~free_vars ~specialised_args ~direct_call_surrogates - in - Set_of_closures set_of_closures - | e -> e - in - Flambda_iterators.map_named_of_program ~f:aux_named program diff --git a/middle_end/flambda/remove_unused_closure_vars.mli b/middle_end/flambda/remove_unused_closure_vars.mli deleted file mode 100644 index 225697a814f..00000000000 --- a/middle_end/flambda/remove_unused_closure_vars.mli +++ /dev/null @@ -1,26 +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-soon mshinwell: Rename this module. *) - -(** Eliminate variables bound by sets of closures that are not required. - Also eliminate functions within sets of closures that are not required. *) -val remove_unused_closure_variables - : remove_direct_call_surrogates:bool - -> Flambda.program - -> Flambda.program diff --git a/middle_end/flambda/remove_unused_program_constructs.ml b/middle_end/flambda/remove_unused_program_constructs.ml deleted file mode 100644 index 059d68bcba7..00000000000 --- a/middle_end/flambda/remove_unused_program_constructs.ml +++ /dev/null @@ -1,111 +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-66"] -open! Int_replace_polymorphic_compare - -let dependency (expr:Flambda.t) = Flambda.free_symbols expr - -(* CR-soon pchambart: copied from lift_constant. Needs remerging *) -let constant_dependencies (const:Flambda.constant_defining_value) = - let closure_dependencies (set_of_closures:Flambda.set_of_closures) = - Flambda.free_symbols_named (Set_of_closures set_of_closures) - in - match const with - | Allocated_const _ -> Symbol.Set.empty - | Block (_, fields) -> - let symbol_fields = - List.filter_map (function - | (Symbol s : Flambda.constant_defining_value_block_field) -> - Some s - | Flambda.Const _ -> None) - fields - in - Symbol.Set.of_list symbol_fields - | Set_of_closures set_of_closures -> closure_dependencies set_of_closures - | Project_closure (s, _) -> Symbol.Set.singleton s - -let let_rec_dep defs dep = - let add_deps l dep = - List.fold_left (fun dep (sym, sym_dep) -> - if Symbol.Set.mem sym dep then Symbol.Set.union dep sym_dep - else dep) - dep l - in - let defs_deps = - List.map (fun (sym, def) -> sym, constant_dependencies def) defs - in - let rec fixpoint dep = - let new_dep = add_deps defs_deps dep in - if Symbol.Set.equal dep new_dep then dep - else fixpoint new_dep - in - fixpoint dep - -let rec loop (program : Flambda.program_body) - : Flambda.program_body * Symbol.Set.t = - match program with - | Let_symbol (sym, def, program) -> - let program, dep = loop program in - if Symbol.Set.mem sym dep then - Let_symbol (sym, def, program), - Symbol.Set.union dep (constant_dependencies def) - else - program, dep - | Let_rec_symbol (defs, program) -> - let program, dep = loop program in - let dep = let_rec_dep defs dep in - let defs = - List.filter (fun (sym, _) -> Symbol.Set.mem sym dep) defs - in begin match defs with - | [] -> program, dep - | _ -> Let_rec_symbol (defs, program), dep - end - | Initialize_symbol (sym, tag, fields, program) -> - let program, dep = loop program in - if Symbol.Set.mem sym dep then - let dep = - List.fold_left (fun dep field -> - Symbol.Set.union dep (dependency field)) - dep fields - in - Initialize_symbol (sym, tag, fields, program), dep - else begin - List.fold_left - (fun (program, dep) field -> - if Effect_analysis.no_effects field then - program, dep - else - let new_dep = dependency field in - let dep = Symbol.Set.union new_dep dep in - Flambda.Effect (field, program), dep) - (program, dep) fields - end - | Effect (effect, program) -> - let program, dep = loop program in - if Effect_analysis.no_effects effect then begin - program, dep - end else begin - let new_dep = dependency effect in - let dep = Symbol.Set.union new_dep dep in - Effect (effect, program), dep - end - | End symbol -> program, Symbol.Set.singleton symbol - -let remove_unused_program_constructs (program : Flambda.program) = - { program with - program_body = fst (loop program.program_body); - } diff --git a/middle_end/flambda/remove_unused_program_constructs.mli b/middle_end/flambda/remove_unused_program_constructs.mli deleted file mode 100644 index 3a722011bb3..00000000000 --- a/middle_end/flambda/remove_unused_program_constructs.mli +++ /dev/null @@ -1,24 +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"] - -(* Remove unused [Flambda.program] constructs from the given program. - - Symbols (whose defining expressions have no effects) are eliminated - if unused. - - [Effect] constructs that turn out to have no effects are eliminated. -*) -val remove_unused_program_constructs : Flambda.program -> Flambda.program diff --git a/middle_end/flambda/share_constants.ml b/middle_end/flambda/share_constants.ml deleted file mode 100644 index 2bbd7134b8a..00000000000 --- a/middle_end/flambda/share_constants.ml +++ /dev/null @@ -1,130 +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-66"] -open! Int_replace_polymorphic_compare - -module Constant_defining_value = Flambda.Constant_defining_value - -let update_constant_for_sharing sharing_symbol_tbl const - : Flambda.constant_defining_value = - let substitute_symbol sym = - match Symbol.Tbl.find sharing_symbol_tbl sym with - | exception Not_found -> sym - | symbol -> symbol - in - match (const:Flambda.constant_defining_value) with - | Allocated_const _ -> const - | Block (tag, fields) -> - let subst_field (field:Flambda.constant_defining_value_block_field) : - Flambda.constant_defining_value_block_field = - match field with - | Const _ -> field - | Symbol sym -> - Symbol (substitute_symbol sym) - in - let fields = List.map subst_field fields in - Block (tag, fields) - | Set_of_closures set_of_closures -> - Set_of_closures ( - Flambda_iterators.map_symbols_on_set_of_closures - ~f:substitute_symbol set_of_closures - ) - | Project_closure (sym, closure_id) -> - Project_closure (substitute_symbol sym, closure_id) - -let cannot_share (const : Flambda.constant_defining_value) = - match const with - (* Strings and float arrays are mutable; we never share them. *) - | Allocated_const ((String _) | (Float_array _)) -> true - | Allocated_const _ | Set_of_closures _ | Project_closure _ | Block _ -> - false - -let share_definition constant_to_symbol_tbl sharing_symbol_tbl - symbol def end_symbol = - let def = update_constant_for_sharing sharing_symbol_tbl def in - if cannot_share def || Symbol.equal symbol end_symbol then - (* The symbol exported by the unit (end_symbol), cannot be removed - from the module. We prevent it from being shared to avoid that. *) - Some def - else - begin match Constant_defining_value.Tbl.find constant_to_symbol_tbl def with - | exception Not_found -> - Constant_defining_value.Tbl.add constant_to_symbol_tbl def symbol; - Some def - | equal_symbol -> - Symbol.Tbl.add sharing_symbol_tbl symbol equal_symbol; - None - end - -let rec end_symbol (program : Flambda.program_body) = - match program with - | End symbol -> symbol - | Let_symbol (_, _, program) - | Let_rec_symbol (_, program) - | Initialize_symbol (_, _, _, program) - | Effect (_, program) -> - end_symbol program - -let share_constants (program : Flambda.program) = - let end_symbol = end_symbol program.program_body in - let sharing_symbol_tbl = Symbol.Tbl.create 42 in - let constant_to_symbol_tbl = Constant_defining_value.Tbl.create 42 in - let rec loop (program : Flambda.program_body) : Flambda.program_body = - match program with - | Let_symbol (symbol,def,program) -> - begin match - share_definition constant_to_symbol_tbl sharing_symbol_tbl symbol - def end_symbol - with - | None -> - loop program - | Some def' -> - Let_symbol (symbol,def',loop program) - end - | Let_rec_symbol (defs,program) -> - let defs = - List.map (fun (symbol, def) -> - let def = update_constant_for_sharing sharing_symbol_tbl def in - symbol, def) - defs - in - Let_rec_symbol (defs, loop program) - | Initialize_symbol (symbol,tag,fields,program) -> - let fields = - List.map (fun field -> - Flambda_iterators.map_symbols - ~f:(fun symbol -> - try Symbol.Tbl.find sharing_symbol_tbl symbol with - | Not_found -> symbol) - field) - fields - in - Initialize_symbol (symbol,tag,fields,loop program) - | Effect (expr,program) -> - let expr = - Flambda_iterators.map_symbols - ~f:(fun symbol -> - try Symbol.Tbl.find sharing_symbol_tbl symbol with - | Not_found -> symbol) - expr - in - Effect (expr, loop program) - | End root -> End root - in - { program with - program_body = loop program.program_body; - } diff --git a/middle_end/flambda/share_constants.mli b/middle_end/flambda/share_constants.mli deleted file mode 100644 index 7fec22bc44c..00000000000 --- a/middle_end/flambda/share_constants.mli +++ /dev/null @@ -1,22 +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"] - -(** Share lifted constants that are eligible for sharing (e.g. not strings) - and have equal definitions. *) - -val share_constants : Flambda.program -> Flambda.program diff --git a/middle_end/flambda/simple_value_approx.ml b/middle_end/flambda/simple_value_approx.ml deleted file mode 100644 index 00d2b0c17ca..00000000000 --- a/middle_end/flambda/simple_value_approx.ml +++ /dev/null @@ -1,1036 +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-66"] -open! Int_replace_polymorphic_compare - -module U = Flambda_utils - -type 'a boxed_int = - | Int32 : int32 boxed_int - | Int64 : int64 boxed_int - | Nativeint : nativeint boxed_int - -type value_string = { - (* CR-soon mshinwell: use variant *) - contents : string option; (* None if unknown or mutable *) - size : int; -} - -type unresolved_value = - | Set_of_closures_id of Set_of_closures_id.t - | Symbol of Symbol.t - -type unknown_because_of = - | Unresolved_value of unresolved_value - | Other - -type t = { - descr : descr; - var : Variable.t option; - symbol : (Symbol.t * int option) option; -} - -and descr = - | Value_block of Tag.t * t array - | Value_int of int - | Value_char of char - | Value_float of float option - | Value_boxed_int : 'a boxed_int * 'a -> descr - | Value_set_of_closures of value_set_of_closures - | Value_closure of value_closure - | Value_string of value_string - | Value_float_array of value_float_array - | Value_unknown of unknown_because_of - | Value_bottom - | Value_extern of Export_id.t - | Value_symbol of Symbol.t - | Value_unresolved of unresolved_value - (* No description was found for this value *) - -and value_closure = { - set_of_closures : t; - closure_id : Closure_id.t; -} - -and function_declarations = { - is_classic_mode : bool; - set_of_closures_id : Set_of_closures_id.t; - set_of_closures_origin : Set_of_closures_origin.t; - funs : function_declaration Variable.Map.t; -} - -and function_body = { - free_variables : Variable.Set.t; - free_symbols : Symbol.Set.t; - stub : bool; - dbg : Debuginfo.t; - inline : Lambda.inline_attribute; - specialise : Lambda.specialise_attribute; - check : Lambda.check_attribute; - is_a_functor : bool; - body : Flambda.t; - poll: Lambda.poll_attribute; -} - -and function_declaration = { - closure_origin : Closure_origin.t; - params : Parameter.t list; - return_layout : Lambda.layout; - alloc_mode : Lambda.alloc_mode; - region : bool; - function_body : function_body option; -} - -and value_set_of_closures = { - function_decls : function_declarations; - bound_vars : t Var_within_closure.Map.t; - free_vars : Flambda.specialised_to Variable.Map.t; - invariant_params : Variable.Set.t Variable.Map.t Lazy.t; - recursive : Variable.Set.t Lazy.t; - size : int option Variable.Map.t Lazy.t; - specialised_args : Flambda.specialised_to Variable.Map.t; - freshening : Freshening.Project_var.t; - direct_call_surrogates : Closure_id.t Closure_id.Map.t; -} - -and value_float_array_contents = - | Contents of t array - | Unknown_or_mutable - -and value_float_array = { - contents : value_float_array_contents; - size : int; -} - -let descr t = t.descr - -let print_value_set_of_closures ppf - { function_decls = { funs }; invariant_params; freshening; size; _ } = - Format.fprintf ppf - "(set_of_closures:@ %a invariant_params=%a freshening=%a size=%a)" - (fun ppf -> Variable.Map.iter (fun id _ -> Variable.print ppf id)) funs - (Variable.Map.print Variable.Set.print) (Lazy.force invariant_params) - Freshening.Project_var.print freshening - (Variable.Map.print (fun ppf some_size -> - match some_size with - | None -> Format.fprintf ppf "None" - | Some size -> Format.fprintf ppf "Some %d" size)) - (Lazy.force size) - -let print_unresolved_value ppf = function - | Set_of_closures_id set -> - Format.fprintf ppf "Set_of_closures_id %a" Set_of_closures_id.print set - | Symbol symbol -> - Format.fprintf ppf "Symbol %a" Symbol.print symbol - -let print_function_declaration ppf var (f : function_declaration) = - let param ppf p = Variable.print ppf (Parameter.var p) in - let params ppf = List.iter (Format.fprintf ppf "@ %a" param) in - let return_layout ppf (layout : Lambda.layout) = - match layout with - | Pvalue Pgenval -> () - | _ -> Format.fprintf ppf "%a@ " Printlambda.layout layout - in - match f.function_body with - | None -> - Format.fprintf ppf "@[<2>(%a@ =@ fun@[<2>%a@])@]@ " - Variable.print var params f.params - | Some (b : function_body) -> - let stub = if b.stub then " *stub*" else "" in - let is_a_functor = if b.is_a_functor then " *functor*" else "" in - let inline = - match b.inline with - | Always_inline -> " *inline*" - | Available_inline -> " *inline_available*" - | Never_inline -> " *never_inline*" - | Unroll _ -> " *unroll*" - | Default_inline -> "" - in - let specialise = - match b.specialise with - | Always_specialise -> " *specialise*" - | Never_specialise -> " *never_specialise*" - | Default_specialise -> "" - in - let print_body ppf _ = - Format.fprintf ppf "" - in - Format.fprintf ppf "@[<2>(%a%s%s%s%s@ =@ fun@[<2>%a@] ->@ %a@[<2><%a>@])@]@ " - Variable.print var stub is_a_functor inline specialise - params f.params - return_layout f.return_layout - print_body b - -let print_function_declarations ppf (fd : function_declarations) = - let funs ppf = Variable.Map.iter (print_function_declaration ppf) in - Format.fprintf ppf "@[<2>(%a)@]" funs fd.funs - -let rec print_descr ppf = function - | Value_int i -> Format.pp_print_int ppf i - | Value_char c -> Format.fprintf ppf "%c" c - | Value_block (tag,fields) -> - let p ppf fields = - Array.iter (fun v -> Format.fprintf ppf "%a@ " print v) fields in - Format.fprintf ppf "[%i:@ @[<1>%a@]]" (Tag.to_int tag) p fields - | Value_unknown reason -> - begin match reason with - | Unresolved_value value -> - Format.fprintf ppf "?(due to unresolved %a)" print_unresolved_value value - | Other -> Format.fprintf ppf "?" - end; - | Value_bottom -> Format.fprintf ppf "bottom" - | Value_extern id -> Format.fprintf ppf "_%a_" Export_id.print id - | Value_symbol sym -> Format.fprintf ppf "%a" Symbol.print sym - | Value_closure { set_of_closures; closure_id; } -> - Format.fprintf ppf "(closure:@ %a from@ %a)" Closure_id.print closure_id - print set_of_closures - | Value_set_of_closures set_of_closures -> - print_value_set_of_closures ppf set_of_closures - | Value_unresolved value -> - Format.fprintf ppf "(unresolved %a)" print_unresolved_value value - | Value_float (Some f) -> Format.pp_print_float ppf f - | Value_float None -> Format.pp_print_string ppf "float" - | Value_string { contents; size } -> begin - match contents with - | None -> - Format.fprintf ppf "string %i" size - | Some s -> - let s = - if size > 10 - then String.sub s 0 8 ^ "..." - else s - in - Format.fprintf ppf "string %i %S" size s - end - | Value_float_array float_array -> - begin match float_array.contents with - | Unknown_or_mutable -> - Format.fprintf ppf "float_array %i" float_array.size - | Contents _ -> - Format.fprintf ppf "float_array_imm %i" float_array.size - end - | Value_boxed_int (t, i) -> - match t with - | Int32 -> Format.fprintf ppf "%li" i - | Int64 -> Format.fprintf ppf "%Li" i - | Nativeint -> Format.fprintf ppf "%ni" i - -and print ppf { descr; var; symbol; } = - let print ppf = function - | None -> Misc.Stdlib.Option.print Symbol.print ppf None - | Some (sym, None) -> Symbol.print ppf sym - | Some (sym, Some field) -> - Format.fprintf ppf "%a.(%i)" Symbol.print sym field - in - Format.fprintf ppf "{ descr=%a var=%a symbol=%a }" - print_descr descr - Variable.print_opt var - print symbol - -let approx descr = { descr; var = None; symbol = None } - -let augment_with_variable t var = { t with var = Some var } -let augment_with_symbol t symbol = { t with symbol = Some (symbol, None) } -let augment_with_symbol_field t symbol field = - match t.symbol with - | None -> { t with symbol = Some (symbol, Some field) } - | Some _ -> t -let replace_description t descr = { t with descr } - -let augment_with_kind t (kind:Lambda.value_kind) = - match kind with - | Pgenval -> t - | Pfloatval -> - begin match t.descr with - | Value_float _ -> - t - | Value_unknown _ | Value_unresolved _ -> - { t with descr = Value_float None } - | Value_block _ - | Value_int _ - | Value_char _ - | Value_boxed_int _ - | Value_set_of_closures _ - | Value_closure _ - | Value_string _ - | Value_float_array _ - | Value_bottom -> - (* Unreachable *) - { t with descr = Value_bottom } - | Value_extern _ | Value_symbol _ -> - (* We don't know yet *) - t - end - | _ -> t - -let augment_kind_with_approx t (kind:Lambda.value_kind) : Lambda.value_kind = - match t.descr with - | Value_float _ -> Pfloatval - | Value_int _ -> Pintval - | Value_boxed_int (Int32, _) -> Pboxedintval Pint32 - | Value_boxed_int (Int64, _) -> Pboxedintval Pint64 - | Value_boxed_int (Nativeint, _) -> Pboxedintval Pnativeint - | _ -> kind - -let value_unknown reason = approx (Value_unknown reason) -let value_int i = approx (Value_int i) -let value_char i = approx (Value_char i) -let value_float f = approx (Value_float (Some f)) -let value_any_float = approx (Value_float None) -let value_boxed_int bi i = approx (Value_boxed_int (bi,i)) - -let value_closure ?closure_var ?set_of_closures_var ?set_of_closures_symbol - value_set_of_closures closure_id = - let approx_set_of_closures = - { descr = Value_set_of_closures value_set_of_closures; - var = set_of_closures_var; - symbol = Option.map (fun s -> s, None) set_of_closures_symbol; - } - in - let value_closure = - { set_of_closures = approx_set_of_closures; - closure_id; - } - in - { descr = Value_closure value_closure; - var = closure_var; - symbol = None; - } - -let create_value_set_of_closures - ~(function_decls : function_declarations) ~bound_vars ~free_vars - ~invariant_params ~recursive ~specialised_args ~freshening - ~direct_call_surrogates = - let size = - lazy ( - let functions = Variable.Map.keys function_decls.funs in - Variable.Map.fold - (fun fun_var function_decl sizes -> - match function_decl.function_body with - | None -> sizes - | Some function_body -> - let params = Parameter.Set.vars function_decl.params in - let free_vars = - Variable.Set.diff - (Variable.Set.diff function_body.free_variables params) - functions - in - let num_free_vars = Variable.Set.cardinal free_vars in - let max_size = - Inlining_cost.maximum_interesting_size_of_function_body - num_free_vars - in - let size = - Inlining_cost.lambda_smaller' function_body.body ~than:max_size - in - Variable.Map.add fun_var size sizes) - function_decls.funs Variable.Map.empty) - in - { function_decls; - bound_vars; - free_vars; - invariant_params; - recursive; - size; - specialised_args; - freshening; - direct_call_surrogates; - } - -let update_freshening_of_value_set_of_closures value_set_of_closures - ~freshening = - (* CR-someday mshinwell: We could maybe check that [freshening] is - reasonable. *) - { value_set_of_closures with freshening; } - -let value_set_of_closures ?set_of_closures_var value_set_of_closures = - { descr = Value_set_of_closures value_set_of_closures; - var = set_of_closures_var; - symbol = None; - } - -let value_block t b = approx (Value_block (t, b)) -let value_extern ex = approx (Value_extern ex) -let value_symbol sym = - { (approx (Value_symbol sym)) with symbol = Some (sym, None) } -let value_bottom = approx Value_bottom -let value_unresolved value = approx (Value_unresolved value) - -let value_string size contents = approx (Value_string {size; contents }) -let value_mutable_float_array ~size = - approx (Value_float_array { contents = Unknown_or_mutable; size; } ) -let value_immutable_float_array (contents:t array) = - let size = Array.length contents in - let contents = - Array.map (fun t -> augment_with_kind t Pfloatval) contents - in - approx (Value_float_array { contents = Contents contents; size; } ) - -let name_expr_fst (named, thing) ~name = - (Flambda_utils.name_expr named ~name), thing - -let make_const_int_named n : Flambda.named * t = - Const (Int n), value_int n -let make_const_int (n : int) = - let name = - match n with - | 0 -> Internal_variable_names.const_zero - | 1 -> Internal_variable_names.const_one - | _ -> Internal_variable_names.const_int - in - name_expr_fst (make_const_int_named n) ~name - -let make_const_char_named n : Flambda.named * t = - Const (Char n), value_char n -let make_const_char n = - let name = Internal_variable_names.const_char in - name_expr_fst (make_const_char_named n) ~name - -let make_const_bool_named b : Flambda.named * t = - make_const_int_named (if b then 1 else 0) -let make_const_bool b = - name_expr_fst (make_const_bool_named b) - ~name:Internal_variable_names.const_bool - -let make_const_float_named f : Flambda.named * t = - Allocated_const (Float f), value_float f -let make_const_float f = - name_expr_fst (make_const_float_named f) - ~name:Internal_variable_names.const_float - -let make_const_boxed_int_named (type bi) (t:bi boxed_int) (i:bi) - : Flambda.named * t = - let c : Allocated_const.t = - match t with - | Int32 -> Int32 i - | Int64 -> Int64 i - | Nativeint -> Nativeint i - in - Allocated_const c, value_boxed_int t i -let make_const_boxed_int t i = - name_expr_fst (make_const_boxed_int_named t i) - ~name:Internal_variable_names.const_boxed_int - -type simplification_summary = - | Nothing_done - | Replaced_term - -type simplification_result = Flambda.t * simplification_summary * t -type simplification_result_named = Flambda.named * simplification_summary * t - -let simplify t (lam : Flambda.t) : simplification_result = - if Effect_analysis.no_effects lam then - match t.descr with - | Value_int n -> - let const, approx = make_const_int n in - const, Replaced_term, approx - | Value_char n -> - let const, approx = make_const_char n in - const, Replaced_term, approx - | Value_float (Some f) -> - let const, approx = make_const_float f in - const, Replaced_term, approx - | Value_boxed_int (t, i) -> - let const, approx = make_const_boxed_int t i in - const, Replaced_term, approx - | Value_symbol sym -> - let name = Internal_variable_names.symbol in - U.name_expr (Symbol sym) ~name, Replaced_term, t - | Value_string _ | Value_float_array _ | Value_float None - | Value_block _ | Value_set_of_closures _ | Value_closure _ - | Value_unknown _ | Value_bottom | Value_extern _ | Value_unresolved _ -> - lam, Nothing_done, t - else - lam, Nothing_done, t - -let simplify_named t (named : Flambda.named) : simplification_result_named = - if Effect_analysis.no_effects_named named then - match t.descr with - | Value_int n -> - let const, approx = make_const_int_named n in - const, Replaced_term, approx - | Value_char n -> - let const, approx = make_const_char_named n in - const, Replaced_term, approx - | Value_float (Some f) -> - let const, approx = make_const_float_named f in - const, Replaced_term, approx - | Value_boxed_int (t, i) -> - let const, approx = make_const_boxed_int_named t i in - const, Replaced_term, approx - | Value_symbol sym -> - Symbol sym, Replaced_term, t - | Value_string _ | Value_float_array _ | Value_float None - | Value_block _ | Value_set_of_closures _ | Value_closure _ - | Value_unknown _ | Value_bottom | Value_extern _ | Value_unresolved _ -> - named, Nothing_done, t - else - named, Nothing_done, t - -(* CR-soon mshinwell: bad name. This function and its call site in - [Inline_and_simplify] is also messy. *) -let simplify_var t : (Flambda.named * t) option = - match t.descr with - | Value_int n -> Some (make_const_int_named n) - | Value_char n -> Some (make_const_char_named n) - | Value_float (Some f) -> Some (make_const_float_named f) - | Value_boxed_int (t, i) -> Some (make_const_boxed_int_named t i) - | Value_symbol sym -> Some (Symbol sym, t) - | Value_string _ | Value_float_array _ | Value_float None - | Value_block _ | Value_set_of_closures _ | Value_closure _ - | Value_unknown _ | Value_bottom | Value_extern _ - | Value_unresolved _ -> - match t.symbol with - | Some (sym, None) -> Some (Symbol sym, t) - | Some (sym, Some field) -> Some (Read_symbol_field (sym, field), t) - | None -> None - -let join_summaries summary ~replaced_by_var_or_symbol = - match replaced_by_var_or_symbol, summary with - | true, Nothing_done - | true, Replaced_term - | false, Replaced_term -> Replaced_term - | false, Nothing_done -> Nothing_done - -let simplify_using_env t ~is_present_in_env flam = - let replaced_by_var_or_symbol, flam = - match t.var with - | Some var when is_present_in_env var -> true, Flambda.Var var - | _ -> - match t.symbol with - | Some (sym, None) -> - let name = Internal_variable_names.symbol in - (true, U.name_expr (Symbol sym) ~name) - | Some (sym, Some field) -> - let name = Internal_variable_names.symbol_field in - (true, U.name_expr (Read_symbol_field (sym, field)) ~name) - | None -> false, flam - in - let const, summary, approx = simplify t flam in - const, join_summaries summary ~replaced_by_var_or_symbol, approx - -let simplify_named_using_env t ~is_present_in_env named = - let replaced_by_var_or_symbol, named = - match t.var with - | Some var when is_present_in_env var -> - true, Flambda.Expr (Var var) - | _ -> - match t.symbol with - | Some (sym, None) -> true, (Flambda.Symbol sym:Flambda.named) - | Some (sym, Some field) -> - true, Flambda.Read_symbol_field (sym, field) - | None -> false, named - in - let const, summary, approx = simplify_named t named in - const, join_summaries summary ~replaced_by_var_or_symbol, approx - -let simplify_var_to_var_using_env t ~is_present_in_env = - match t.var with - | Some var when is_present_in_env var -> Some var - | _ -> None - -let known t = - match t.descr with - | Value_unresolved _ - | Value_unknown _ -> false - | Value_string _ | Value_float_array _ - | Value_bottom | Value_block _ | Value_int _ | Value_char _ - | Value_set_of_closures _ | Value_closure _ - | Value_extern _ | Value_float _ | Value_boxed_int _ | Value_symbol _ -> true - -let useful t = - match t.descr with - | Value_unresolved _ | Value_unknown _ | Value_bottom -> false - | Value_string _ | Value_float_array _ | Value_block _ | Value_int _ - | Value_char _ | Value_set_of_closures _ - | Value_float _ | Value_boxed_int _ | Value_closure _ | Value_extern _ - | Value_symbol _ -> true - -let all_not_useful ts = List.for_all (fun t -> not (useful t)) ts - -let warn_on_mutation t = - match t.descr with - | Value_block(_, fields) -> Array.length fields > 0 - | Value_string { contents = Some _ } - | Value_int _ | Value_char _ - | Value_set_of_closures _ | Value_float _ | Value_boxed_int _ - | Value_closure _ -> true - | Value_string { contents = None } | Value_float_array _ - | Value_unresolved _ | Value_unknown _ | Value_bottom -> false - | Value_extern _ | Value_symbol _ -> assert false - -type get_field_result = - | Ok of t - | Unreachable - -let get_field t ~field_index:i : get_field_result = - match t.descr with - | Value_block (_tag, fields) -> - if i >= 0 && i < Array.length fields then begin - Ok fields.(i) - end else begin - (* This (unfortunately) cannot be a fatal error; it can happen if a - .cmx file is missing. However for debugging the compiler this can - be a useful point to put a [Misc.fatal_errorf]. *) - Unreachable - end - (* CR-someday mshinwell: This should probably return Unreachable in more - cases. I added a couple more. *) - | Value_bottom - | Value_int _ | Value_char _ -> - (* Something seriously wrong is happening: either the user is doing - something exceptionally unsafe, or it is an unreachable branch. - We consider this as unreachable and mark the result accordingly. *) - Ok value_bottom - | Value_float_array _ -> - (* For the moment we return "unknown" even for immutable arrays, since - it isn't possible for user code to project from an immutable array. *) - (* CR-someday mshinwell: If Leo's array's patch lands, then we can - change this, although it's probably not Pfield that is used to - do the projection. *) - Ok (value_unknown Other) - | Value_string _ | Value_float _ | Value_boxed_int _ -> - (* The user is doing something unsafe. *) - Unreachable - | Value_set_of_closures _ | Value_closure _ - (* This is used by [CamlinternalMod]. *) - | Value_symbol _ | Value_extern _ -> - (* These should have been resolved. *) - Ok (value_unknown Other) - | Value_unknown reason -> - Ok (value_unknown reason) - | Value_unresolved value -> - (* We don't know anything, but we must remember that it comes - from another compilation unit in case it contains a closure. *) - Ok (value_unknown (Unresolved_value value)) - -type checked_approx_for_block = - | Wrong - | Ok of Tag.t * t array - -let check_approx_for_block t = - match t.descr with - | Value_block (tag, fields) -> - Ok (tag, fields) - | Value_bottom - | Value_int _ | Value_char _ - | Value_float_array _ - | Value_string _ | Value_float _ | Value_boxed_int _ - | Value_set_of_closures _ | Value_closure _ - | Value_symbol _ | Value_extern _ - | Value_unknown _ - | Value_unresolved _ -> - Wrong - -let descrs approxs = List.map (fun v -> v.descr) approxs - -let equal_boxed_int (type t1) (type t2) - (bi1:t1 boxed_int) (i1:t1) - (bi2:t2 boxed_int) (i2:t2) = - match bi1, bi2 with - | Int32, Int32 -> Int32.equal i1 i2 - | Int64, Int64 -> Int64.equal i1 i2 - | Nativeint, Nativeint -> Nativeint.equal i1 i2 - | _ -> false - -let equal_floats f1 f2 = - match f1, f2 with - | None, None -> true - | None, Some _ | Some _, None -> false - | Some f1, Some f2 -> Allocated_const.compare_floats f1 f2 = 0 - -(* Closures and set of closures descriptions cannot be merged. - - let f x = - let g y -> x + y in - g - in - let v = - if ... - then f 1 - else f 2 - in - v 3 - - The approximation for [f 1] and [f 2] could both contain the - description of [g]. But if [f] where inlined, a new [g] would - be created in each branch, leading to incompatible description. - And we must never make the description for a function less - precise that it used to be: its information are needed for - rewriting [Project_var] and [Project_closure] constructions - in [Flambdainline.loop] -*) -let rec meet_descr ~really_import_approx d1 d2 = match d1, d2 with - | Value_int i, Value_int j when i = j -> - d1 - | Value_symbol s1, Value_symbol s2 when Symbol.equal s1 s2 -> - d1 - | Value_extern e1, Value_extern e2 when Export_id.equal e1 e2 -> - d1 - | Value_float i, Value_float j when equal_floats i j -> - d1 - | Value_boxed_int (bi1, i1), Value_boxed_int (bi2, i2) when - equal_boxed_int bi1 i1 bi2 i2 -> - d1 - | Value_block (tag1, a1), Value_block (tag2, a2) - when Tag.compare tag1 tag2 = 0 && Array.length a1 = Array.length a2 -> - let fields = - Array.mapi (fun i v -> meet ~really_import_approx v a2.(i)) a1 - in - Value_block (tag1, fields) - | _ -> Value_unknown Other - -and meet ~really_import_approx a1 a2 = - match a1, a2 with - | { descr = Value_bottom }, a - | a, { descr = Value_bottom } -> a - | { descr = (Value_symbol _ | Value_extern _) }, _ - | _, { descr = (Value_symbol _ | Value_extern _) } -> - meet ~really_import_approx - (really_import_approx a1) (really_import_approx a2) - | _ -> - let var = - match a1.var, a2.var with - | None, _ | _, None -> None - | Some v1, Some v2 -> - if Variable.equal v1 v2 - then Some v1 - else None - in - let symbol = - match a1.symbol, a2.symbol with - | None, _ | _, None -> None - | Some (v1, field1), Some (v2, field2) -> - if Symbol.equal v1 v2 - then match field1, field2 with - | None, None -> a1.symbol - | Some f1, Some f2 when f1 = f2 -> - a1.symbol - | _ -> None - else None - in - { descr = meet_descr ~really_import_approx a1.descr a2.descr; - var; - symbol } - -(* Given a set-of-closures approximation and a closure ID, apply any - freshening specified in the approximation to the closure ID, and return - that new closure ID. A fatal error is produced if the new closure ID - does not correspond to a function declaration in the given approximation. *) -let freshen_and_check_closure_id - (value_set_of_closures : value_set_of_closures) closure_id = - let closure_id = - Freshening.Project_var.apply_closure_id - value_set_of_closures.freshening closure_id - in - try - ignore ( - Variable.Map.find (Closure_id.unwrap closure_id) - value_set_of_closures.function_decls.funs - ); - closure_id - with Not_found -> - Misc.fatal_error (Format.asprintf - "Function %a not found in the set of closures@ %a@.%a@." - Closure_id.print closure_id - print_value_set_of_closures value_set_of_closures - print_function_declarations value_set_of_closures.function_decls) - -type checked_approx_for_set_of_closures = - | Wrong - | Unresolved of unresolved_value - | Unknown - | Unknown_because_of_unresolved_value of unresolved_value - | Ok of Variable.t option * value_set_of_closures - -let check_approx_for_set_of_closures t : checked_approx_for_set_of_closures = - match t.descr with - | Value_unresolved value -> Unresolved value - | Value_unknown (Unresolved_value value) -> - Unknown_because_of_unresolved_value value - | Value_set_of_closures value_set_of_closures -> - (* Note that [var] might be [None]; we might be reaching the set of - closures via approximations only, with the variable originally bound - to the set now out of scope. *) - Ok (t.var, value_set_of_closures) - | Value_closure _ | Value_block _ | Value_int _ | Value_char _ - | Value_float _ | Value_boxed_int _ | Value_unknown _ - | Value_bottom | Value_extern _ | Value_string _ | Value_float_array _ - | Value_symbol _ -> - Wrong - -type strict_checked_approx_for_set_of_closures = - | Wrong - | Ok of Variable.t option * value_set_of_closures - -let strict_check_approx_for_set_of_closures t - : strict_checked_approx_for_set_of_closures = - match check_approx_for_set_of_closures t with - | Ok (var, value_set_of_closures) -> Ok (var, value_set_of_closures) - | Wrong | Unresolved _ - | Unknown | Unknown_because_of_unresolved_value _ -> Wrong - -type checked_approx_for_closure_allowing_unresolved = - | Wrong - | Unresolved of unresolved_value - | Unknown - | Unknown_because_of_unresolved_value of unresolved_value - | Ok of value_closure * Variable.t option - * Symbol.t option * value_set_of_closures - -let check_approx_for_closure_allowing_unresolved t - : checked_approx_for_closure_allowing_unresolved = - match t.descr with - | Value_closure value_closure -> - begin match value_closure.set_of_closures.descr with - | Value_set_of_closures value_set_of_closures -> - let symbol = match value_closure.set_of_closures.symbol with - | Some (symbol, None) -> Some symbol - | None | Some (_, Some _) -> None - in - Ok (value_closure, value_closure.set_of_closures.var, - symbol, value_set_of_closures) - | Value_unresolved _ - | Value_closure _ | Value_block _ | Value_int _ | Value_char _ - | Value_float _ | Value_boxed_int _ | Value_unknown _ - | Value_bottom | Value_extern _ | Value_string _ | Value_float_array _ - | Value_symbol _ -> - Wrong - end - | Value_unknown (Unresolved_value value) -> - Unknown_because_of_unresolved_value value - | Value_unresolved symbol -> Unresolved symbol - | Value_set_of_closures _ | Value_block _ | Value_int _ | Value_char _ - | Value_float _ | Value_boxed_int _ - | Value_bottom | Value_extern _ | Value_string _ | Value_float_array _ - | Value_symbol _ -> - Wrong - (* CR-soon mshinwell: This should be unwound once the reason for a value - being unknown can be correctly propagated through the export info. *) - | Value_unknown Other -> Unknown - -type checked_approx_for_closure = - | Wrong - | Ok of value_closure * Variable.t option - * Symbol.t option * value_set_of_closures - -let check_approx_for_closure t : checked_approx_for_closure = - match check_approx_for_closure_allowing_unresolved t with - | Ok (value_closure, set_of_closures_var, set_of_closures_symbol, - value_set_of_closures) -> - Ok (value_closure, set_of_closures_var, set_of_closures_symbol, - value_set_of_closures) - | Wrong | Unknown | Unresolved _ | Unknown_because_of_unresolved_value _ -> - Wrong - -let approx_for_bound_var value_set_of_closures var = - try - Var_within_closure.Map.find var value_set_of_closures.bound_vars - with - | Not_found -> - Misc.fatal_errorf "The set-of-closures approximation %a@ does not \ - bind the variable %a@.%s@." - print_value_set_of_closures value_set_of_closures - Var_within_closure.print var - (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int)) - -let check_approx_for_float t : float option = - match t.descr with - | Value_float f -> f - | Value_unresolved _ - | Value_unknown _ | Value_string _ | Value_float_array _ - | Value_bottom | Value_block _ | Value_int _ | Value_char _ - | Value_set_of_closures _ | Value_closure _ - | Value_extern _ | Value_boxed_int _ | Value_symbol _ -> - None - -let float_array_as_constant (t:value_float_array) : float list option = - match t.contents with - | Unknown_or_mutable -> None - | Contents contents -> - Array.fold_right (fun elt acc -> - match acc, elt.descr with - | Some acc, Value_float (Some f) -> - Some (f :: acc) - | None, _ - | Some _, - (Value_float None | Value_unresolved _ - | Value_unknown _ | Value_string _ | Value_float_array _ - | Value_bottom | Value_block _ | Value_int _ | Value_char _ - | Value_set_of_closures _ | Value_closure _ - | Value_extern _ | Value_boxed_int _ | Value_symbol _) - -> None) - contents (Some []) - -let check_approx_for_string t : string option = - match t.descr with - | Value_string { contents } -> contents - | Value_float _ - | Value_unresolved _ - | Value_unknown _ | Value_float_array _ - | Value_bottom | Value_block _ | Value_int _ | Value_char _ - | Value_set_of_closures _ | Value_closure _ - | Value_extern _ | Value_boxed_int _ | Value_symbol _ -> - None - -type switch_branch_selection = - | Cannot_be_taken - | Can_be_taken - | Must_be_taken - -let potentially_taken_const_switch_branch t branch = - match t.descr with - | Value_unresolved _ - | Value_unknown _ - | Value_extern _ - | Value_symbol _ -> - (* In theory symbol cannot contain integers but this shouldn't - matter as this will always be an imported approximation *) - Can_be_taken - | Value_int i when i = branch -> - Must_be_taken - | Value_char c when Char.code c = branch -> - Must_be_taken - | Value_int _ | Value_char _ -> - Cannot_be_taken - | Value_block _ | Value_float _ | Value_float_array _ - | Value_string _ | Value_closure _ | Value_set_of_closures _ - | Value_boxed_int _ | Value_bottom -> - Cannot_be_taken - -let potentially_taken_block_switch_branch t tag = - match t.descr with - | (Value_unresolved _ - | Value_unknown _ - | Value_extern _ - | Value_symbol _) -> - Can_be_taken - | (Value_int _| Value_char _) -> - Cannot_be_taken - | Value_block (block_tag, _) when Tag.to_int block_tag = tag -> - Must_be_taken - | Value_float _ when tag = Obj.double_tag -> - Must_be_taken - | Value_float_array _ when tag = Obj.double_array_tag -> - Must_be_taken - | Value_string _ when tag = Obj.string_tag -> - Must_be_taken - | (Value_closure _ | Value_set_of_closures _) - when tag = Obj.closure_tag || tag = Obj.infix_tag -> - Can_be_taken - | Value_boxed_int _ when tag = Obj.custom_tag -> - Must_be_taken - | Value_block _ | Value_float _ | Value_set_of_closures _ | Value_closure _ - | Value_string _ | Value_float_array _ | Value_boxed_int _ -> - Cannot_be_taken - | Value_bottom -> - Cannot_be_taken - -let function_arity (fun_decl : function_declaration) = - List.length fun_decl.params - -let function_declaration_approx ~keep_body fun_var - (fun_decl : Flambda.function_declaration) = - let function_body = - if not (keep_body fun_var fun_decl) then None - else begin - Some { body = fun_decl.body; - stub = fun_decl.stub; - inline = fun_decl.inline; - dbg = fun_decl.dbg; - specialise = fun_decl.specialise; - check = fun_decl.check; - is_a_functor = fun_decl.is_a_functor; - free_variables = fun_decl.free_variables; - free_symbols = fun_decl.free_symbols; - poll = fun_decl.poll } - end - in - { function_body; - params = fun_decl.params; - return_layout = fun_decl.return_layout; - alloc_mode = fun_decl.alloc_mode; - region = fun_decl.region; - closure_origin = fun_decl.closure_origin; } - -let function_declarations_approx ~keep_body - (fun_decls : Flambda.function_declarations) = - let funs = - Variable.Map.mapi (function_declaration_approx ~keep_body) fun_decls.funs - in - { funs; - is_classic_mode = fun_decls.is_classic_mode; - set_of_closures_id = fun_decls.set_of_closures_id; - set_of_closures_origin = fun_decls.set_of_closures_origin; } - -let import_function_declarations_for_pack function_decls - import_set_of_closures_id import_set_of_closures_origin = - { set_of_closures_id = - import_set_of_closures_id function_decls.set_of_closures_id; - set_of_closures_origin = - import_set_of_closures_origin function_decls.set_of_closures_origin; - funs = function_decls.funs; - is_classic_mode = function_decls.is_classic_mode; - } - -let update_function_declarations function_decls ~funs = - let compilation_unit = Compilation_unit.get_current_exn () in - let is_classic_mode = function_decls.is_classic_mode in - let set_of_closures_id = Set_of_closures_id.create compilation_unit in - let set_of_closures_origin = function_decls.set_of_closures_origin in - { is_classic_mode; - set_of_closures_id; - set_of_closures_origin; - funs; - } - -let clear_function_bodies (function_decls : function_declarations) = - let funs = - Variable.Map.map (fun (fun_decl : function_declaration) -> - match fun_decl.function_body with - | None | Some { stub = true; _ } -> - fun_decl - | Some _ -> - { fun_decl with function_body = None }) - function_decls.funs - in - { function_decls with funs } - -let update_function_declaration_body - (function_decl : function_declaration) - (f : Flambda.t -> Flambda.t) = - match function_decl.function_body with - | None -> function_decl - | Some function_body -> - let new_function_body = - let body = f function_body.body in - let free_variables = Flambda.free_variables body in - let free_symbols = Flambda.free_symbols body in - { function_body with free_variables; free_symbols; body; } - in - { function_decl with function_body = Some new_function_body } - -let make_closure_map input = - let map = ref Closure_id.Map.empty in - let add_set_of_closures _ (function_decls : function_declarations) = - Variable.Map.iter (fun var _ -> - let closure_id = Closure_id.wrap var in - map := Closure_id.Map.add closure_id function_decls !map) - function_decls.funs - in - Set_of_closures_id.Map.iter add_set_of_closures input; - !map diff --git a/middle_end/flambda/simple_value_approx.mli b/middle_end/flambda/simple_value_approx.mli deleted file mode 100644 index cef2a162d28..00000000000 --- a/middle_end/flambda/simple_value_approx.mli +++ /dev/null @@ -1,502 +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"] - -(** Simple approximations to the runtime results of computations. - This pass is designed for speed rather than accuracy; the performance - is important since it is used heavily during inlining. *) - -type 'a boxed_int = - | Int32 : int32 boxed_int - | Int64 : int64 boxed_int - | Nativeint : nativeint boxed_int - -type value_string = { - contents : string option; (* [None] if unknown or mutable *) - size : int; -} - -type unresolved_value = - | Set_of_closures_id of Set_of_closures_id.t - | Symbol of Symbol.t - -type unknown_because_of = - | Unresolved_value of unresolved_value - | Other - -(** A value of type [t] corresponds to an "approximation" of the result of - a computation in the program being compiled. That is to say, it - represents what knowledge we have about such a result at compile time. - The simplification pass exploits this information to partially evaluate - computations. - - At a high level, an approximation for a value [v] has three parts: - - the "description" (for example, "the constant integer 42"); - - an optional variable; - - an optional symbol or symbol field. - If the variable (resp. symbol) is present then that variable (resp. - symbol) may be used to obtain the value [v]. - - The exact semantics of the variable and symbol fields follows. - - Approximations are deduced at particular points in an expression tree, - but may subsequently be propagated to other locations. - - At the point at which an approximation is built for some value [v], we can - construct a set of variables (call the set [S]) that are known to alias the - same value [v]. Each member of [S] will have the same or a more precise - [descr] field in its approximation relative to the approximation for [v]. - (An increase in precision may currently be introduced for pattern - matches.) If [S] is non-empty then it is guaranteed that there is a - unique member of [S] that was declared in a scope further out ("earlier") - than all other members of [S]. If such a member exists then it is - recorded in the [var] field. Otherwise [var] is [None]. - - Analogous to the construction of the set [S], we can construct a set [T] - consisting of all symbols that are known to alias the value whose - approximation is being constructed. If [T] is non-empty then the - [symbol] field is set to some member of [T]; it does not matter which - one. (There is no notion of scope for symbols.) - - Note about mutable blocks: - - Mutable blocks are always represented by [Value_unknown] or - [Value_bottom]. Any other approximation could leave the door open to - a miscompilation. Such bad scenarios are most likely a user using - [Obj.magic] or [Obj.set_field] in an inappropriate situation. - Such a situation might be: - [let x = (1, 1) in - Obj.set_field (Obj.repr x) 0 (Obj.repr 2); - assert(fst x = 2)] - The user would probably expect the assertion to be true, but the - compiler could in fact propagate the value of [x] across the - [Obj.set_field]. - - Insisting that mutable blocks have [Value_unknown] or [Value_bottom] - approximations certainly won't always prevent this kind of error, but - should help catch many of them. - - It is possible that there may be some false positives, with correct - but unreachable code causing this check to fail. However the likelihood - of this seems sufficiently low, especially compared to the advantages - gained by performing the check, that we include it. - - An example of a pattern that might trigger a false positive is: - [type a = { a : int } - type b = { mutable b : int } - type _ t = - | A : a t - | B : b t - let f (type x) (v:x t) (r:x) = - match v with - | A -> r.a - | B -> r.b <- 2; 3 - - let v = - let r = - ref A in - r := A; (* Some pattern that the compiler can't understand *) - f !r { a = 1 }] - When inlining [f], the B branch is unreachable, yet the compiler - cannot prove it and must therefore keep it. -*) -type t = private { - descr : descr; - var : Variable.t option; - symbol : (Symbol.t * int option) option; -} - -and descr = private - | Value_block of Tag.t * t array - | Value_int of int - | Value_char of char - | Value_float of float option - | Value_boxed_int : 'a boxed_int * 'a -> descr - | Value_set_of_closures of value_set_of_closures - | Value_closure of value_closure - | Value_string of value_string - | Value_float_array of value_float_array - | Value_unknown of unknown_because_of - | Value_bottom - | Value_extern of Export_id.t - | Value_symbol of Symbol.t - | Value_unresolved of unresolved_value - (* No description was found for this value *) - -and value_closure = { - set_of_closures : t; - closure_id : Closure_id.t; -} - -and function_declarations = private { - is_classic_mode: bool; - set_of_closures_id : Set_of_closures_id.t; - set_of_closures_origin : Set_of_closures_origin.t; - funs : function_declaration Variable.Map.t; -} - -and function_body = private { - free_variables : Variable.Set.t; - free_symbols : Symbol.Set.t; - stub : bool; - dbg : Debuginfo.t; - inline : Lambda.inline_attribute; - specialise : Lambda.specialise_attribute; - check : Lambda.check_attribute; - is_a_functor : bool; - body : Flambda.t; - poll: Lambda.poll_attribute; -} - -and function_declaration = private { - closure_origin : Closure_origin.t; - params : Parameter.t list; - return_layout : Lambda.layout; - alloc_mode : Lambda.alloc_mode; - region : bool; - function_body : function_body option; -} - - -(* CR-soon mshinwell: add support for the approximations of the results, so we - can do all of the tricky higher-order cases. *) -(* when [is_classic_mode] is [false], functions in [function_declarations] - are guaranteed to have function bodies (ie: - [function_declaration.function_body] will be of the [Some] variant). - - When it [is_classic_mode] is [true], however, no guarantees about the - function_bodies are given. -*) -and value_set_of_closures = private { - function_decls : function_declarations; - bound_vars : t Var_within_closure.Map.t; - free_vars : Flambda.specialised_to Variable.Map.t; - invariant_params : Variable.Set.t Variable.Map.t Lazy.t; - recursive : Variable.Set.t Lazy.t; - size : int option Variable.Map.t Lazy.t; - (** For functions that are very likely to be inlined, the size of the - function's body. *) - specialised_args : Flambda.specialised_to Variable.Map.t; - (* Any freshening that has been applied to [function_decls]. *) - freshening : Freshening.Project_var.t; - direct_call_surrogates : Closure_id.t Closure_id.Map.t; -} - -and value_float_array_contents = - | Contents of t array - | Unknown_or_mutable - -and value_float_array = { - contents : value_float_array_contents; - size : int; -} - -(** Extraction of the description of approximation(s). *) -val descr : t -> descr -val descrs : t list -> descr list - -(** Pretty-printing of approximations to a formatter. *) -val print : Format.formatter -> t -> unit -val print_descr : Format.formatter -> descr -> unit -val print_value_set_of_closures - : Format.formatter - -> value_set_of_closures - -> unit -val print_function_declarations - : Format.formatter - -> function_declarations - -> unit - -val function_declarations_approx - : keep_body:(Variable.t -> Flambda.function_declaration -> bool) - -> Flambda.function_declarations - -> function_declarations - -val create_value_set_of_closures - : function_decls:function_declarations - -> bound_vars:t Var_within_closure.Map.t - -> free_vars:Flambda.specialised_to Variable.Map.t - -> invariant_params:Variable.Set.t Variable.Map.t lazy_t - -> recursive:Variable.Set.t Lazy.t - -> specialised_args:Flambda.specialised_to Variable.Map.t - -> freshening:Freshening.Project_var.t - -> direct_call_surrogates:Closure_id.t Closure_id.Map.t - -> value_set_of_closures - -val update_freshening_of_value_set_of_closures - : value_set_of_closures - -> freshening:Freshening.Project_var.t - -> value_set_of_closures - -(** Basic construction of approximations. *) -val value_unknown : unknown_because_of -> t -val value_int : int -> t -val value_char : char -> t -val value_float : float -> t -val value_any_float : t -val value_mutable_float_array : size:int -> t -val value_immutable_float_array : t array -> t -val value_string : int -> string option -> t -val value_boxed_int : 'i boxed_int -> 'i -> t -val value_block : Tag.t -> t array -> t -val value_extern : Export_id.t -> t -val value_symbol : Symbol.t -> t -val value_bottom : t -val value_unresolved : unresolved_value -> t - -(** Construct a closure approximation given the approximation of the - corresponding set of closures and the closure ID of the closure to - be projected from such set. [closure_var] and/or [set_of_closures_var] - may be specified to augment the approximation with variables that may - be used to access the closure value itself, so long as they are in - scope at the proposed point of use. *) -val value_closure - : ?closure_var:Variable.t - -> ?set_of_closures_var:Variable.t - -> ?set_of_closures_symbol:Symbol.t - -> value_set_of_closures - -> Closure_id.t - -> t - -(** Construct a set of closures approximation. [set_of_closures_var] is as for - the parameter of the same name in [value_closure], above. *) -val value_set_of_closures - : ?set_of_closures_var:Variable.t - -> value_set_of_closures - -> t - -(** Take the given constant and produce an appropriate approximation for it - together with an Flambda expression representing it. *) -val make_const_int : int -> Flambda.t * t -val make_const_char : char -> Flambda.t * t -val make_const_bool : bool -> Flambda.t * t -val make_const_float : float -> Flambda.t * t -val make_const_boxed_int : 'i boxed_int -> 'i -> Flambda.t * t - -val make_const_int_named : int -> Flambda.named * t -val make_const_char_named : char -> Flambda.named * t -val make_const_bool_named : bool -> Flambda.named * t -val make_const_float_named : float -> Flambda.named * t -val make_const_boxed_int_named : 'i boxed_int -> 'i -> Flambda.named * t - -(** Augment an approximation with a given variable (see comment above). - If the approximation was already augmented with a variable, the one - passed to this function replaces it within the approximation. *) -val augment_with_variable : t -> Variable.t -> t - -(** Like [augment_with_variable], but for symbol information. *) -val augment_with_symbol : t -> Symbol.t -> t - -(** Like [augment_with_symbol], but for symbol field information. *) -val augment_with_symbol_field : t -> Symbol.t -> int -> t - -(** Replace the description within an approximation. *) -val replace_description : t -> descr -> t - -(** Improve the description by taking the kind into account *) -val augment_with_kind : t -> Lambda.value_kind -> t - -(** Improve the kind by taking the description into account *) -val augment_kind_with_approx : t -> Lambda.value_kind -> Lambda.value_kind - -val equal_boxed_int : 'a boxed_int -> 'a -> 'b boxed_int -> 'b -> bool - -(* CR-soon mshinwell for pchambart: Add comment describing semantics. (Maybe - we should move the comment from the .ml file into here.) *) -val meet : really_import_approx:(t -> t) -> t -> t -> t - -(** An approximation is "known" iff it is not [Value_unknown]. *) -val known : t -> bool - -(** An approximation is "useful" iff it is neither unknown nor bottom. *) -val useful : t -> bool - -(** Whether all approximations in the given list do *not* satisfy [useful]. *) -val all_not_useful : t list -> bool - -(** Whether to warn on attempts to mutate a value. - It must have been resolved (it cannot be [Value_extern] or - [Value_symbol]). (See comment above for further explanation.) *) -val warn_on_mutation : t -> bool - -type simplification_summary = - | Nothing_done - | Replaced_term - -type simplification_result = Flambda.t * simplification_summary * t -type simplification_result_named = Flambda.named * simplification_summary * t - -(** Given an expression and its approximation, attempt to simplify the - expression to a constant (with associated approximation), taking into - account whether the expression has any side effects. *) -val simplify : t -> Flambda.t -> simplification_result - -(** As for [simplify], but also enables us to simplify based on equalities - between variables. The caller must provide a function that tells us - whether, if we simplify to a given variable, the value of that variable - will be accessible in the current environment. *) -val simplify_using_env - : t - -> is_present_in_env:(Variable.t -> bool) - -> Flambda.t - -> simplification_result - -val simplify_named : t -> Flambda.named -> simplification_result_named - -val simplify_named_using_env - : t - -> is_present_in_env:(Variable.t -> bool) - -> Flambda.named - -> simplification_result_named - -(** If the given approximation identifies another variable and - [is_present_in_env] deems it to be in scope, return that variable (wrapped - in a [Some]), otherwise return [None]. *) -val simplify_var_to_var_using_env - : t - -> is_present_in_env:(Variable.t -> bool) - -> Variable.t option - -val simplify_var : t -> (Flambda.named * t) option - -type get_field_result = - | Ok of t - | Unreachable - -(** Given the approximation [t] of a value, expected to correspond to a block - (in the [Pmakeblock] sense of the word), and a field index then return - an appropriate approximation for that field of the block (or - [Unreachable] if the code with the approximation [t] is unreachable). - N.B. Not all cases of unreachable code are returned as [Unreachable]. -*) -val get_field : t -> field_index:int -> get_field_result - -type checked_approx_for_block = - | Wrong - | Ok of Tag.t * t array - -(** Try to prove that a value with the given approximation may be used - as a block. *) -val check_approx_for_block : t -> checked_approx_for_block - -(** Find the approximation for a bound variable in a set-of-closures - approximation. A fatal error is produced if the variable is not bound in - the given approximation. *) -val approx_for_bound_var : value_set_of_closures -> Var_within_closure.t -> t - -(** Given a set-of-closures approximation and a closure ID, apply any - freshening specified by the approximation to the closure ID, and return - the resulting ID. Causes a fatal error if the resulting closure ID does - not correspond to any function declaration in the approximation. *) -val freshen_and_check_closure_id - : value_set_of_closures - -> Closure_id.t - -> Closure_id.t - -type strict_checked_approx_for_set_of_closures = - | Wrong - | Ok of Variable.t option * value_set_of_closures - -val strict_check_approx_for_set_of_closures - : t - -> strict_checked_approx_for_set_of_closures - -type checked_approx_for_set_of_closures = - | Wrong - | Unresolved of unresolved_value - | Unknown - | Unknown_because_of_unresolved_value of unresolved_value - (* In the [Ok] case, there may not be a variable associated with the set of - closures; it might be out of scope. *) - | Ok of Variable.t option * value_set_of_closures - -(** Try to prove that a value with the given approximation may be used as a - set of closures. Values coming from external compilation units with - unresolved approximations are permitted. *) -val check_approx_for_set_of_closures : t -> checked_approx_for_set_of_closures - -type checked_approx_for_closure = - | Wrong - | Ok of value_closure * Variable.t option - * Symbol.t option * value_set_of_closures - -(** Try to prove that a value with the given approximation may be used as a - closure. Values coming from external compilation units with unresolved - approximations are not permitted. *) -(* CR-someday mshinwell: naming is inconsistent: this is as "strict" - as "strict_check_approx_for_set_of_closures" *) -val check_approx_for_closure : t -> checked_approx_for_closure - -type checked_approx_for_closure_allowing_unresolved = - | Wrong - | Unresolved of unresolved_value - | Unknown - | Unknown_because_of_unresolved_value of unresolved_value - | Ok of value_closure * Variable.t option - * Symbol.t option * value_set_of_closures - -(** As for [check_approx_for_closure], but values coming from external - compilation units with unresolved approximations are permitted. *) -val check_approx_for_closure_allowing_unresolved - : t - -> checked_approx_for_closure_allowing_unresolved - -(** Returns the value if it can be proved to be a constant float *) -val check_approx_for_float : t -> float option - -(** Returns the value if it can be proved to be a constant float array *) -val float_array_as_constant : value_float_array -> float list option - -(** Returns the value if it can be proved to be a constant string *) -val check_approx_for_string : t -> string option - -type switch_branch_selection = - | Cannot_be_taken - | Can_be_taken - | Must_be_taken - -(** Check that the branch is compatible with the approximation *) -val potentially_taken_const_switch_branch : t -> int -> switch_branch_selection -val potentially_taken_block_switch_branch : t -> int -> switch_branch_selection - -val function_arity : function_declaration -> int - -(** Create a set of function declarations based on another set of function - declarations. *) -val update_function_declarations - : function_declarations - -> funs:function_declaration Variable.Map.t - -> function_declarations - -val import_function_declarations_for_pack - : function_declarations - -> (Set_of_closures_id.t -> Set_of_closures_id.t) - -> (Set_of_closures_origin.t -> Set_of_closures_origin.t) - -> function_declarations - -val update_function_declaration_body - : function_declaration - -> (Flambda.t -> Flambda.t) - -> function_declaration - -(** Creates a map from closure IDs to function declarations by iterating over - all sets of closures in the given map. *) -val make_closure_map - : function_declarations Set_of_closures_id.Map.t - -> function_declarations Closure_id.Map.t - -val clear_function_bodies : function_declarations -> function_declarations diff --git a/middle_end/flambda/simplify_boxed_integer_ops.ml b/middle_end/flambda/simplify_boxed_integer_ops.ml deleted file mode 100644 index a11d245e6da..00000000000 --- a/middle_end/flambda/simplify_boxed_integer_ops.ml +++ /dev/null @@ -1,118 +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-66"] -open! Int_replace_polymorphic_compare - -module S = Simplify_common - -(* Simplification of operations on boxed integers (nativeint, Int32, Int64). *) -module Simplify_boxed_integer_operator (I : sig - type t - val kind : Lambda.boxed_integer - val zero : t - val add : t -> t -> t - val sub : t -> t -> t - val mul : t -> t -> t - val div : t -> t -> t - val rem : t -> t -> t - val logand : t -> t -> t - val logor : t -> t -> t - val logxor : t -> t -> t - val shift_left : t -> int -> t - val shift_right : t -> int -> t - val shift_right_logical : t -> int -> t - val to_int : t -> int - val to_int32 : t -> Int32.t - val to_int64 : t -> Int64.t - val neg : t -> t - val swap : t -> t - val compare : t -> t -> int -end) : Simplify_boxed_integer_ops_intf.S with type t := I.t = struct - module A = Simple_value_approx - module C = Inlining_cost - - let equal_kind = Lambda.equal_boxed_integer - - let simplify_unop (p : Clambda_primitives.primitive) - (kind : I.t A.boxed_int) expr (n : I.t) = - let eval op = S.const_boxed_int_expr expr kind (op n) in - let eval_conv kind op = S.const_boxed_int_expr expr kind (op n) in - let eval_unboxed op = S.const_int_expr expr (op n) in - match p with - | Pintofbint kind when equal_kind kind I.kind -> eval_unboxed I.to_int - | Pcvtbint (kind, Pint32, _) when equal_kind kind I.kind -> - eval_conv A.Int32 I.to_int32 - | Pcvtbint (kind, Pint64, _) when equal_kind kind I.kind -> - eval_conv A.Int64 I.to_int64 - | Pnegbint (kind,_) when equal_kind kind I.kind -> eval I.neg - | Pbbswap (kind,_) when equal_kind kind I.kind -> eval I.swap - | _ -> expr, A.value_unknown Other, C.Benefit.zero - - let simplify_binop (p : Clambda_primitives.primitive) - (kind : I.t A.boxed_int) expr (n1 : I.t) (n2 : I.t) = - let eval op = S.const_boxed_int_expr expr kind (op n1 n2) in - let non_zero n = (I.compare I.zero n) <> 0 in - match p with - | Paddbint (kind,_) when equal_kind kind I.kind -> eval I.add - | Psubbint (kind,_) when equal_kind kind I.kind -> eval I.sub - | Pmulbint (kind,_) when equal_kind kind I.kind -> eval I.mul - | Pdivbint {size=kind} when equal_kind kind I.kind && non_zero n2 -> - eval I.div - | Pmodbint {size=kind} when equal_kind kind I.kind && non_zero n2 -> - eval I.rem - | Pandbint (kind,_) when equal_kind kind I.kind -> eval I.logand - | Porbint (kind,_) when equal_kind kind I.kind -> eval I.logor - | Pxorbint (kind,_) when equal_kind kind I.kind -> eval I.logxor - | Pbintcomp (kind, c) when equal_kind kind I.kind -> - S.const_integer_comparison_expr expr c n1 n2 - | Pcompare_bints kind when equal_kind kind I.kind -> - S.const_int_expr expr (I.compare n1 n2) - | _ -> expr, A.value_unknown Other, C.Benefit.zero - - let simplify_binop_int (p : Clambda_primitives.primitive) - (kind : I.t A.boxed_int) expr (n1 : I.t) (n2 : int) ~size_int = - let eval op = S.const_boxed_int_expr expr kind (op n1 n2) in - let precond = 0 <= n2 && n2 < 8 * size_int in - match p with - | Plslbint (kind,_) when equal_kind kind I.kind && precond -> eval I.shift_left - | Plsrbint (kind,_) when equal_kind kind I.kind && precond -> - eval I.shift_right_logical - | Pasrbint (kind,_) when equal_kind kind I.kind && precond -> eval I.shift_right - | _ -> expr, A.value_unknown Other, C.Benefit.zero -end - -module Simplify_boxed_nativeint = Simplify_boxed_integer_operator (struct - include Nativeint - let to_int64 = Int64.of_nativeint - let swap = S.swapnative - let kind = Lambda.Pnativeint -end) - -module Simplify_boxed_int32 = Simplify_boxed_integer_operator (struct - include Int32 - let to_int32 i = i - let to_int64 = Int64.of_int32 - let swap = S.swap32 - let kind = Lambda.Pint32 -end) - -module Simplify_boxed_int64 = Simplify_boxed_integer_operator (struct - include Int64 - let to_int64 i = i - let swap = S.swap64 - let kind = Lambda.Pint64 -end) diff --git a/middle_end/flambda/simplify_boxed_integer_ops.mli b/middle_end/flambda/simplify_boxed_integer_ops.mli deleted file mode 100644 index f3461043a13..00000000000 --- a/middle_end/flambda/simplify_boxed_integer_ops.mli +++ /dev/null @@ -1,28 +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"] - -(* Simplification of operations on boxed integers (nativeint, Int32, Int64). *) - -module Simplify_boxed_nativeint : Simplify_boxed_integer_ops_intf.S - with type t := Nativeint.t - -module Simplify_boxed_int32 : Simplify_boxed_integer_ops_intf.S - with type t := Int32.t - -module Simplify_boxed_int64 : Simplify_boxed_integer_ops_intf.S - with type t := Int64.t diff --git a/middle_end/flambda/simplify_boxed_integer_ops_intf.mli b/middle_end/flambda/simplify_boxed_integer_ops_intf.mli deleted file mode 100644 index f30987ae11d..00000000000 --- a/middle_end/flambda/simplify_boxed_integer_ops_intf.mli +++ /dev/null @@ -1,45 +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"] - -module type S = sig - type t - - val simplify_unop - : Clambda_primitives.primitive - -> t Simple_value_approx.boxed_int - -> Flambda.named - -> t - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - - val simplify_binop - : Clambda_primitives.primitive - -> t Simple_value_approx.boxed_int - -> Flambda.named - -> t - -> t - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - - val simplify_binop_int - : Clambda_primitives.primitive - -> t Simple_value_approx.boxed_int - -> Flambda.named - -> t - -> int - -> size_int:int - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t -end diff --git a/middle_end/flambda/simplify_common.ml b/middle_end/flambda/simplify_common.ml deleted file mode 100644 index 021ec68aa8c..00000000000 --- a/middle_end/flambda/simplify_common.ml +++ /dev/null @@ -1,81 +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-66"] -open! Int_replace_polymorphic_compare - -module A = Simple_value_approx -module C = Inlining_cost - -external swap16 : int -> int = "%bswap16" -external swap32 : int32 -> int32 = "%bswap_int32" -external swap64 : int64 -> int64 = "%bswap_int64" -external swapnative : nativeint -> nativeint = "%bswap_native" - -let const_int_expr expr n = - if Effect_analysis.no_effects_named expr then - let (new_expr, approx) = A.make_const_int_named n in - new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero - else expr, A.value_int n, C.Benefit.zero -let const_char_expr expr c = - if Effect_analysis.no_effects_named expr then - let (new_expr, approx) = A.make_const_char_named c in - new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero - else expr, A.value_char c, C.Benefit.zero -let const_bool_expr expr b = - const_int_expr expr (if b then 1 else 0) -let const_float_expr expr f = - if Effect_analysis.no_effects_named expr then - let (new_expr, approx) = A.make_const_float_named f in - new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero - else expr, A.value_float f, C.Benefit.zero -let const_boxed_int_expr expr t i = - if Effect_analysis.no_effects_named expr then - let (new_expr, approx) = A.make_const_boxed_int_named t i in - new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero - else expr, A.value_boxed_int t i, C.Benefit.zero - -let const_integer_comparison_expr expr (cmp : Lambda.integer_comparison) x y = - (* Using the [Stdlib] comparison functions here in the compiler - coincides with the definitions of such functions in the code - compiled by the user, and is thus correct. *) - let open! Stdlib in - const_bool_expr expr - (match cmp with - | Ceq -> x = y - | Cne -> x <> y - | Clt -> x < y - | Cgt -> x > y - | Cle -> x <= y - | Cge -> x >= y) - -let const_float_comparison_expr expr (cmp : Lambda.float_comparison) x y = - (* Using the [Stdlib] comparison functions here in the compiler - coincides with the definitions of such functions in the code - compiled by the user, and is thus correct. *) - let open! Stdlib in - const_bool_expr expr - (match cmp with - | CFeq -> x = y - | CFneq -> not (x = y) - | CFlt -> x < y - | CFnlt -> not (x < y) - | CFgt -> x > y - | CFngt -> not (x > y) - | CFle -> x <= y - | CFnle -> not (x <= y) - | CFge -> x >= y - | CFnge -> not (x >= y)) diff --git a/middle_end/flambda/simplify_common.mli b/middle_end/flambda/simplify_common.mli deleted file mode 100644 index ff1016717c5..00000000000 --- a/middle_end/flambda/simplify_common.mli +++ /dev/null @@ -1,75 +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"] - -(** [const_*_expr expr v annot], where the expression [expr] is known to - evaluate to the value [v], attempt to produce a more simple expression - together with its approximation and the benefit gained by replacing [expr] - with this new expression. This simplification is only performed if [expr] - is known to have no side effects. Otherwise, [expr] itself is returned, - with an appropriate approximation but zero benefit. - - [const_boxed_int_expr] takes an additional argument specifying the kind of - boxed integer to which the given expression evaluates. -*) - -val const_int_expr - : Flambda.named - -> int - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_char_expr - : Flambda.named - -> char - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_bool_expr - : Flambda.named - -> bool - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_float_expr - : Flambda.named - -> float - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_boxed_int_expr - : Flambda.named - -> 'a Simple_value_approx.boxed_int - -> 'a - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_integer_comparison_expr - : Flambda.named - -> Lambda.integer_comparison - -> 'a - -> 'a - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_float_comparison_expr - : Flambda.named - -> Lambda.float_comparison - -> float - -> float - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -(** Functions for transposing the order of bytes within words of various - sizes. *) -val swap16 : int -> int -val swap32 : int32 -> int32 -val swap64 : int64 -> int64 -val swapnative : nativeint -> nativeint diff --git a/middle_end/flambda/simplify_primitives.ml b/middle_end/flambda/simplify_primitives.ml deleted file mode 100644 index 935715a5bb9..00000000000 --- a/middle_end/flambda/simplify_primitives.ml +++ /dev/null @@ -1,297 +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-66"] -open! Int_replace_polymorphic_compare - -module A = Simple_value_approx -module C = Inlining_cost -module I = Simplify_boxed_integer_ops -module S = Simplify_common - -let phys_equal (approxs:A.t list) = - match approxs with - | [] | [_] | _ :: _ :: _ :: _ -> - Misc.fatal_error "wrong number of arguments for equality" - | [a1; a2] -> - (* N.B. The following would be incorrect if the variables are not - bound in the environment: - match a1.var, a2.var with - | Some v1, Some v2 when Variable.equal v1 v2 -> true - | _ -> ... - *) - match a1.symbol, a2.symbol with - | Some (s1, None), Some (s2, None) -> Symbol.equal s1 s2 - | Some (s1, Some f1), Some (s2, Some f2) -> Symbol.equal s1 s2 && f1 = f2 - | _ -> false - -let is_known_to_be_some_kind_of_int (arg:A.descr) = - match arg with - | Value_int _ | Value_char _ -> true - | Value_block _ | Value_float _ | Value_set_of_closures _ - | Value_closure _ | Value_string _ | Value_float_array _ - | A.Value_boxed_int _ | Value_unknown _ | Value_extern _ - | Value_symbol _ | Value_unresolved _ | Value_bottom -> false - -let is_known_to_be_some_kind_of_block (arg:A.descr) = - match arg with - | Value_block _ | Value_float _ | Value_float_array _ | A.Value_boxed_int _ - | Value_closure _ | Value_string _ -> true - | Value_set_of_closures _ | Value_int _ | Value_char _ - | Value_unknown _ | Value_extern _ | Value_symbol _ - | Value_unresolved _ | Value_bottom -> false - -let rec structurally_different (arg1:A.t) (arg2:A.t) = - match arg1.descr, arg2.descr with - | (Value_int n1), (Value_int n2) - when n1 <> n2 -> - true - | Value_block (tag1, fields1), Value_block (tag2, fields2) -> - not (Tag.equal tag1 tag2) - || (Array.length fields1 <> Array.length fields2) - || Misc.Stdlib.Array.exists2 structurally_different fields1 fields2 - | descr1, descr2 -> - (* This is not very precise as this won't allow to distinguish - blocks from strings for instance. This can be improved if it - is deemed valuable. *) - (is_known_to_be_some_kind_of_int descr1 - && is_known_to_be_some_kind_of_block descr2) - || (is_known_to_be_some_kind_of_block descr1 - && is_known_to_be_some_kind_of_int descr2) - -let phys_different (approxs:A.t list) = - match approxs with - | [] | [_] | _ :: _ :: _ :: _ -> - Misc.fatal_error "wrong number of arguments for equality" - | [a1; a2] -> - structurally_different a1 a2 - -let is_empty = function - | [] -> true - | _ :: _ -> false - -let is_pisint = function - | Clambda_primitives.Pisint -> true - | _ -> false - -let is_pstring_length = function - | Clambda_primitives.Pstringlength -> true - | _ -> false - -let is_pbytes_length = function - | Clambda_primitives.Pbyteslength -> true - | _ -> false - -let is_pstringrefs = function - | Clambda_primitives.Pstringrefs -> true - | _ -> false - -let is_pbytesrefs = function - | Clambda_primitives.Pbytesrefs -> true - | _ -> false - -let primitive (p : Clambda_primitives.primitive) (args, approxs) - expr dbg ~size_int - : Flambda.named * A.t * Inlining_cost.Benefit.t = - let fpc = !Clflags.float_const_prop in - match p with - | Pmakeblock(tag_int, (Immutable | Immutable_unique), shape, mode) -> - let tag = Tag.create_exn tag_int in - let shape = match shape with - | None -> List.map (fun _ -> Lambda.Pgenval) args - | Some shape -> List.map (fun kind -> kind) shape - in - let approxs = List.map2 A.augment_with_kind approxs shape in - let shape = List.map2 A.augment_kind_with_approx approxs shape in - Prim (Pmakeblock(tag_int, Lambda.Immutable, Some shape, mode), args, dbg), - A.value_block tag (Array.of_list approxs), C.Benefit.zero - | Praise _ -> - expr, A.value_bottom, C.Benefit.zero - | Pmakearray(_, _, mode) when is_empty approxs -> - Prim (Pmakeblock(0, Lambda.Immutable, Some [], mode), [], dbg), - A.value_block (Tag.create_exn 0) [||], C.Benefit.zero - | Pmakearray (Pfloatarray, Mutable, _) -> - let approx = - A.value_mutable_float_array ~size:(List.length args) - in - expr, approx, C.Benefit.zero - | Pmakearray (Pfloatarray, (Immutable | Immutable_unique), _) -> - let approx = - A.value_immutable_float_array (Array.of_list approxs) - in - expr, approx, C.Benefit.zero - | Pintcomp Ceq when phys_equal approxs -> - S.const_bool_expr expr true - | Pintcomp Cne when phys_equal approxs -> - S.const_bool_expr expr false - (* N.B. Having [not (phys_equal approxs)] would not on its own tell us - anything about whether the two values concerned are unequal. To judge - that, it would be necessary to prove that the approximations are - different, which would in turn entail them being completely known. - - It may seem that in the case where we have two approximations each - annotated with a symbol that we should be able to judge inequality - even if part of the approximation description(s) are unknown. This is - unfortunately not the case. Here is an example: - - let a = f 1 - let b = f 1 - let c = a, a - let d = b, b - - If [Share_constants] is run before [f] is completely inlined (assuming - [f] always generates the same result; effects of [f] aren't in fact - relevant) then [c] and [d] will not be shared. However if [f] is - inlined later, [a] and [b] could be shared and thus [c] and [d] could - be too. As such, any intermediate non-aliasing judgement would be - invalid. *) - | Pintcomp Ceq when phys_different approxs -> - S.const_bool_expr expr false - | Pintcomp Cne when phys_different approxs -> - S.const_bool_expr expr true - (* If two values are structurally different we are certain they can never - be shared*) - | _ -> - match A.descrs approxs with - | [Value_int x] -> - begin match p with - | Pnot -> S.const_bool_expr expr (x = 0) - | Pnegint -> S.const_int_expr expr (-x) - | Pbswap16 -> S.const_int_expr expr (S.swap16 x) - | Pisint -> S.const_bool_expr expr true - | Poffsetint y -> S.const_int_expr expr (x + y) - | Pfloatofint _ when fpc -> S.const_float_expr expr (float_of_int x) - | Pbintofint (Pnativeint,_) -> - S.const_boxed_int_expr expr Nativeint (Nativeint.of_int x) - | Pbintofint (Pint32,_) -> S.const_boxed_int_expr expr Int32 (Int32.of_int x) - | Pbintofint (Pint64,_) -> S.const_boxed_int_expr expr Int64 (Int64.of_int x) - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [Value_int x; Value_int y] -> - let shift_precond = 0 <= y && y < 8 * size_int in - begin match p with - | Paddint -> S.const_int_expr expr (x + y) - | Psubint -> S.const_int_expr expr (x - y) - | Pmulint -> S.const_int_expr expr (x * y) - | Pdivint _ when y <> 0 -> S.const_int_expr expr (x / y) - | Pmodint _ when y <> 0 -> S.const_int_expr expr (x mod y) - | Pandint -> S.const_int_expr expr (x land y) - | Porint -> S.const_int_expr expr (x lor y) - | Pxorint -> S.const_int_expr expr (x lxor y) - | Plslint when shift_precond -> S.const_int_expr expr (x lsl y) - | Plsrint when shift_precond -> S.const_int_expr expr (x lsr y) - | Pasrint when shift_precond -> S.const_int_expr expr (x asr y) - | Pintcomp cmp -> S.const_integer_comparison_expr expr cmp x y - | Pcompare_ints -> S.const_int_expr expr (compare x y) - | Pisout -> S.const_bool_expr expr (y > x || y < 0) - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [Value_char x; Value_char y] -> - begin match p with - | Pintcomp cmp -> S.const_integer_comparison_expr expr cmp x y - | Pcompare_ints -> S.const_int_expr expr (Char.compare x y) - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [Value_float (Some x)] when fpc -> - begin match p with - | Pintoffloat -> S.const_int_expr expr (int_of_float x) - | Pnegfloat _ -> S.const_float_expr expr (-. x) - | Pabsfloat _ -> S.const_float_expr expr (abs_float x) - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [Value_float (Some n1); Value_float (Some n2)] when fpc -> - begin match p with - | Paddfloat _ -> S.const_float_expr expr (n1 +. n2) - | Psubfloat _ -> S.const_float_expr expr (n1 -. n2) - | Pmulfloat _ -> S.const_float_expr expr (n1 *. n2) - | Pdivfloat _ -> S.const_float_expr expr (n1 /. n2) - | Pfloatcomp c -> S.const_float_comparison_expr expr c n1 n2 - | Pcompare_floats -> S.const_int_expr expr (Float.compare n1 n2) - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [A.Value_boxed_int(A.Nativeint, n)] -> - I.Simplify_boxed_nativeint.simplify_unop p Nativeint expr n - | [A.Value_boxed_int(A.Int32, n)] -> - I.Simplify_boxed_int32.simplify_unop p Int32 expr n - | [A.Value_boxed_int(A.Int64, n)] -> - I.Simplify_boxed_int64.simplify_unop p Int64 expr n - | [A.Value_boxed_int(A.Nativeint, n1); - A.Value_boxed_int(A.Nativeint, n2)] -> - I.Simplify_boxed_nativeint.simplify_binop p Nativeint expr n1 n2 - | [A.Value_boxed_int(A.Int32, n1); A.Value_boxed_int(A.Int32, n2)] -> - I.Simplify_boxed_int32.simplify_binop p Int32 expr n1 n2 - | [A.Value_boxed_int(A.Int64, n1); A.Value_boxed_int(A.Int64, n2)] -> - I.Simplify_boxed_int64.simplify_binop p Int64 expr n1 n2 - | [A.Value_boxed_int(A.Nativeint, n1); Value_int n2] -> - I.Simplify_boxed_nativeint.simplify_binop_int p Nativeint expr n1 n2 - ~size_int - | [A.Value_boxed_int(A.Int32, n1); Value_int n2] -> - I.Simplify_boxed_int32.simplify_binop_int p Int32 expr n1 n2 - ~size_int - | [A.Value_boxed_int(A.Int64, n1); Value_int n2] -> - I.Simplify_boxed_int64.simplify_binop_int p Int64 expr n1 n2 - ~size_int - | [Value_block _] when is_pisint p -> - S.const_bool_expr expr false - | [Value_string { size }] - when (is_pstring_length p || is_pbytes_length p) -> - S.const_int_expr expr size - | [Value_string { size; contents = Some s }; - (Value_int x)] when x >= 0 && x < size -> - begin match p with - | Pstringrefu - | Pstringrefs - | Pbytesrefu - | Pbytesrefs -> - S.const_char_expr (Prim(Pstringrefu, args, dbg)) s.[x] - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [Value_string { size; contents = None }; - (Value_int x)] - when x >= 0 && x < size && is_pstringrefs p -> - Flambda.Prim (Pstringrefu, args, dbg), - A.value_unknown Other, - (* we improved it, but there is no way to account for that: *) - C.Benefit.zero - | [Value_string { size; contents = None }; - (Value_int x)] - when x >= 0 && x < size && is_pbytesrefs p -> - Flambda.Prim (Pbytesrefu, args, dbg), - A.value_unknown Other, - (* we improved it, but there is no way to account for that: *) - C.Benefit.zero - - | [Value_float_array { size; contents }] -> - begin match p with - | Parraylength _ -> S.const_int_expr expr size - | Pfloatfield (i,_) -> - begin match contents with - | A.Contents a when i >= 0 && i < size -> - begin match A.check_approx_for_float a.(i) with - | None -> expr, a.(i), C.Benefit.zero - | Some v -> S.const_float_expr expr v - end - | Contents _ | Unknown_or_mutable -> - expr, A.value_unknown Other, C.Benefit.zero - end - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | _ -> - match Semantics_of_primitives.return_type_of_primitive p with - | Float -> - expr, A.value_any_float, C.Benefit.zero - | Other -> - expr, A.value_unknown Other, C.Benefit.zero diff --git a/middle_end/flambda/simplify_primitives.mli b/middle_end/flambda/simplify_primitives.mli deleted file mode 100644 index a6b6330c034..00000000000 --- a/middle_end/flambda/simplify_primitives.mli +++ /dev/null @@ -1,27 +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"] - -(** Simplifies an application of a primitive based on approximation - information. *) -val primitive - : Clambda_primitives.primitive - -> (Variable.t list * (Simple_value_approx.t list)) - -> Flambda.named - -> Debuginfo.t - -> size_int:int - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t diff --git a/middle_end/flambda/traverse_for_exported_symbols.ml b/middle_end/flambda/traverse_for_exported_symbols.ml deleted file mode 100644 index 1b7ce57f54a..00000000000 --- a/middle_end/flambda/traverse_for_exported_symbols.ml +++ /dev/null @@ -1,267 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fu Yong Quah, Jane Street Europe *) -(* *) -(* Copyright 2017 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -module A = Simple_value_approx - -type queue_elem = - | Q_symbol of Symbol.t - | Q_set_of_closures_id of Set_of_closures_id.t - | Q_export_id of Export_id.t - -type symbols_to_export = - { symbols : Symbol.Set.t; - export_ids : Export_id.Set.t; - set_of_closure_ids : Set_of_closures_id.Set.t; - set_of_closure_ids_keep_declaration : Set_of_closures_id.Set.t; - relevant_imported_closure_ids : Closure_id.Set.t; - relevant_local_closure_ids : Closure_id.Set.t; - relevant_imported_vars_within_closure : Var_within_closure.Set.t; - relevant_local_vars_within_closure : Var_within_closure.Set.t; - } - -let traverse - ~(sets_of_closures_map : - Flambda.set_of_closures Set_of_closures_id.Map.t) - ~(closure_id_to_set_of_closures_id : - Set_of_closures_id.t Closure_id.Map.t) - ~(function_declarations_map : - A.function_declarations Set_of_closures_id.Map.t) - ~(values : Export_info.descr Export_id.Map.t) - ~(symbol_id : Export_id.t Symbol.Map.t) - ~(root_symbol: Symbol.t) = - let relevant_set_of_closures_declaration_only = - ref Set_of_closures_id.Set.empty - in - let relevant_symbols = ref (Symbol.Set.singleton root_symbol) in - let relevant_set_of_closures = ref Set_of_closures_id.Set.empty in - let relevant_export_ids = ref Export_id.Set.empty in - let relevant_imported_closure_ids = ref Closure_id.Set.empty in - let relevant_local_closure_ids = ref Closure_id.Set.empty in - let relevant_imported_vars_within_closure = - ref Var_within_closure.Set.empty - in - let relevant_local_vars_with_closure = ref Var_within_closure.Set.empty in - let (queue : queue_elem Queue.t) = Queue.create () in - let conditionally_add_symbol symbol = - if not (Symbol.Set.mem symbol !relevant_symbols) then begin - relevant_symbols := - Symbol.Set.add symbol !relevant_symbols; - Queue.add (Q_symbol symbol) queue - end - in - let conditionally_add_set_of_closures_id set_of_closures_id = - if not (Set_of_closures_id.Set.mem - set_of_closures_id !relevant_set_of_closures) then begin - relevant_set_of_closures := - Set_of_closures_id.Set.add set_of_closures_id - !relevant_set_of_closures; - Queue.add (Q_set_of_closures_id set_of_closures_id) queue - end - in - let conditionally_add_export_id export_id = - if not (Export_id.Set.mem export_id !relevant_export_ids) then begin - relevant_export_ids := - Export_id.Set.add export_id !relevant_export_ids; - Queue.add (Q_export_id export_id) queue - end - in - let process_approx (approx : Export_info.approx) = - match approx with - | Value_id export_id -> - conditionally_add_export_id export_id - | Value_symbol symbol -> - conditionally_add_symbol symbol - | Value_unknown -> () - in - let process_value_set_of_closures - (soc : Export_info.value_set_of_closures) = - conditionally_add_set_of_closures_id soc.set_of_closures_id; - Var_within_closure.Map.iter - (fun _ value -> process_approx value) soc.bound_vars; - Closure_id.Map.iter - (fun _ value -> process_approx value) soc.results; - begin match soc.aliased_symbol with - | None -> () - | Some symbol -> conditionally_add_symbol symbol - end - in - let process_function_body (function_body : A.function_body) = - Flambda_iterators.iter - (fun (term : Flambda.t) -> - match term with - | Flambda.Apply { kind ; _ } -> - begin match kind with - | Indirect -> () - | Direct closure_id -> - begin match - Closure_id.Map.find - closure_id - closure_id_to_set_of_closures_id - with - | exception Not_found -> - relevant_imported_closure_ids := - Closure_id.Set.add closure_id - !relevant_imported_closure_ids - | set_of_closures_id -> - relevant_local_closure_ids := - Closure_id.Set.add closure_id - !relevant_local_closure_ids; - conditionally_add_set_of_closures_id - set_of_closures_id - end - end - | _ -> ()) - (fun (named : Flambda.named) -> - let process_closure_id closure_id = - match - Closure_id.Map.find closure_id closure_id_to_set_of_closures_id - with - | exception Not_found -> - relevant_imported_closure_ids := - Closure_id.Set.add closure_id !relevant_imported_closure_ids - | set_of_closure_id -> - relevant_local_closure_ids := - Closure_id.Set.add closure_id !relevant_local_closure_ids; - relevant_set_of_closures_declaration_only := - Set_of_closures_id.Set.add - set_of_closure_id - !relevant_set_of_closures_declaration_only - in - match named with - | Symbol symbol - | Read_symbol_field (symbol, _) -> - conditionally_add_symbol symbol - | Set_of_closures soc -> - conditionally_add_set_of_closures_id - soc.function_decls.set_of_closures_id - | Project_closure { closure_id; _ } -> - process_closure_id closure_id - | Move_within_set_of_closures { start_from; move_to; _ } -> - process_closure_id start_from; - process_closure_id move_to - | Project_var { closure_id ; var; _ } -> - begin match - Closure_id.Map.find - closure_id closure_id_to_set_of_closures_id - with - | exception Not_found -> - relevant_imported_closure_ids := - Closure_id.Set.add closure_id - !relevant_imported_closure_ids; - relevant_imported_vars_within_closure := - Var_within_closure.Set.add var - !relevant_imported_vars_within_closure - | set_of_closure_id -> - relevant_local_closure_ids := - Closure_id.Set.add closure_id - !relevant_local_closure_ids; - relevant_local_vars_with_closure := - Var_within_closure.Set.add var - !relevant_local_vars_with_closure; - relevant_set_of_closures_declaration_only := - Set_of_closures_id.Set.add - set_of_closure_id - !relevant_set_of_closures_declaration_only - end - | Prim _ - | Expr _ - | Const _ - | Allocated_const _ - | Read_mutable _ -> ()) - function_body.body - in - let rec loop () = - if Queue.is_empty queue then - () - else begin - begin match Queue.pop queue with - | Q_export_id export_id -> - begin match Export_id.Map.find export_id values with - | exception Not_found -> () - | Value_block (_, approxes) -> - Array.iter process_approx approxes - | Value_closure value_closure -> - process_value_set_of_closures value_closure.set_of_closures - | Value_set_of_closures soc -> - process_value_set_of_closures soc - | _ -> () - end - | Q_symbol symbol -> - let compilation_unit = Symbol.compilation_unit symbol in - if Compilation_unit.is_current compilation_unit then begin - match Symbol.Map.find symbol symbol_id with - | exception Not_found -> - Misc.fatal_errorf "cannot find symbol's export id %a\n" - Symbol.print symbol - | export_id -> - conditionally_add_export_id export_id - end - | Q_set_of_closures_id set_of_closures_id -> - begin match - Set_of_closures_id.Map.find - set_of_closures_id function_declarations_map - with - | exception Not_found -> () - | function_declarations -> - Variable.Map.iter - (fun (_ : Variable.t) (fun_decl : A.function_declaration) -> - match fun_decl.function_body with - | None -> () - | Some function_body -> process_function_body function_body) - function_declarations.funs - end - end; - loop () - end - in - Queue.add (Q_symbol root_symbol) queue; - loop (); - - Closure_id.Map.iter (fun closure_id set_of_closure_id -> - if Set_of_closures_id.Set.mem - set_of_closure_id !relevant_set_of_closures - then begin - relevant_local_closure_ids := - Closure_id.Set.add closure_id !relevant_local_closure_ids - end) - closure_id_to_set_of_closures_id; - - Set_of_closures_id.Set.iter (fun set_of_closures_id -> - match - Set_of_closures_id.Map.find set_of_closures_id sets_of_closures_map - with - | exception Not_found -> () - | set_of_closures -> - Variable.Map.iter (fun var _ -> - relevant_local_vars_with_closure := - Var_within_closure.Set.add - (Var_within_closure.wrap var) - !relevant_local_vars_with_closure) - set_of_closures.free_vars) - !relevant_set_of_closures; - - { symbols = !relevant_symbols; - export_ids = !relevant_export_ids; - set_of_closure_ids = !relevant_set_of_closures; - set_of_closure_ids_keep_declaration = - !relevant_set_of_closures_declaration_only; - relevant_imported_closure_ids = !relevant_imported_closure_ids; - relevant_local_closure_ids = !relevant_local_closure_ids; - relevant_imported_vars_within_closure = - !relevant_imported_vars_within_closure; - relevant_local_vars_within_closure = - !relevant_local_vars_with_closure; - } diff --git a/middle_end/flambda/traverse_for_exported_symbols.mli b/middle_end/flambda/traverse_for_exported_symbols.mli deleted file mode 100644 index 2825a386237..00000000000 --- a/middle_end/flambda/traverse_for_exported_symbols.mli +++ /dev/null @@ -1,41 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fu Yong Quah, Jane Street Europe *) -(* *) -(* Copyright 2017 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"] - -type symbols_to_export = - { symbols : Symbol.Set.t; - export_ids : Export_id.Set.t; - set_of_closure_ids : Set_of_closures_id.Set.t; - set_of_closure_ids_keep_declaration : Set_of_closures_id.Set.t; - relevant_imported_closure_ids : Closure_id.Set.t; - relevant_local_closure_ids : Closure_id.Set.t; - relevant_imported_vars_within_closure : Var_within_closure.Set.t; - relevant_local_vars_within_closure : Var_within_closure.Set.t; - } - -(** Computes the transitive closure in [Symbol.t], [Closure_id.t] and - [Set_of_closures_id.t] and determines which ones of those should be - exported (i.e: included in the cmx files). -**) -val traverse - : sets_of_closures_map: Flambda.set_of_closures Set_of_closures_id.Map.t - -> closure_id_to_set_of_closures_id: - Set_of_closures_id.t Closure_id.Map.t - -> function_declarations_map: - Simple_value_approx.function_declarations Set_of_closures_id.Map.t - -> values: Export_info.descr Export_id.Map.t - -> symbol_id: Export_id.t Symbol.Map.t - -> root_symbol: Symbol.t - -> symbols_to_export diff --git a/middle_end/flambda/un_anf.ml b/middle_end/flambda/un_anf.ml deleted file mode 100644 index 4c5567c1b5e..00000000000 --- a/middle_end/flambda/un_anf.ml +++ /dev/null @@ -1,909 +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-30-40-41-42-69"] - -(* CR-someday vlaviron for mshinwell: I believe that the phantom lets introduced - in un_anf (when the new debug_full flag is enabled) bind mostly variables - that were created in the middle-end. Is it relevant to generate debugging - information for such variables ? I expect later pull requests to refine the - generation of these phantom constructions anyway, but maybe it would already - make sense to restrict the phantom let generation to variables with an actual - provenance. -*) - -module V = Backend_var -module VP = Backend_var.With_provenance - -(* We say that an [V.t] is "linear" iff: - (a) it is used exactly once; - (b) it is never assigned to (using [Uassign]). -*) -type var_info = - { used_let_bound_vars : V.Set.t; - linear_let_bound_vars : V.Set.t; - assigned : V.Set.t; - closure_environment : V.Set.t; - let_bound_vars_that_can_be_moved : V.Set.t; - } - -let ignore_uconstant (_ : Clambda.uconstant) = () -let ignore_ulambda (_ : Clambda.ulambda) = () -let ignore_ulambda_list (_ : Clambda.ulambda list) = () -let ignore_uphantom_defining_expr_option - (_ : Clambda.uphantom_defining_expr option) = () -let ignore_function_label (_ : Clambda.function_label) = () -let ignore_apply_kind (_ : Clambda.apply_kind) = () -let ignore_debuginfo (_ : Debuginfo.t) = () -let ignore_probe (_ : Lambda.probe) = () -let ignore_int (_ : int) = () -let ignore_var (_ : V.t) = () -let ignore_var_option (_ : V.t option) = () -let ignore_primitive (_ : Clambda_primitives.primitive) = () -let ignore_string (_ : string) = () -let ignore_int_array (_ : int array) = () -let ignore_var_with_provenance (_ : VP.t) = () -let ignore_params (_ : VP.t list) = () -let ignore_params_with_layout (_ : (VP.t * Lambda.layout) list) = () -let ignore_direction_flag (_ : Asttypes.direction_flag) = () -let ignore_meth_kind (_ : Lambda.meth_kind) = () -let ignore_layout (_ : Lambda.layout) = () - -(* CR-soon mshinwell: check we aren't traversing function bodies more than - once (need to analyse exactly what the calls are from Cmmgen into this - module). *) - -let closure_environment_var (ufunction:Clambda.ufunction) = - (* The argument after the arity is the environment *) - let n = List.length ufunction.arity.params_layout in - match ufunction.arity.function_kind with - | Curried _ when List.length ufunction.params = n + 1 -> - let env_var = List.nth ufunction.params n in - assert (VP.name env_var = "env"); - Some env_var - | _ -> - (* closed function, no environment *) - None - -type var_uses = - | Zero - | One - | More_than_one - | Assigned - -type var = - { definition_depth : int; - uses : var_uses; } - -let incr_uses { definition_depth; uses } depth = - assert (definition_depth <= depth); - let uses = - match uses with - | Zero -> - if definition_depth < depth then More_than_one - else One - | One -> More_than_one - | More_than_one -> More_than_one - | Assigned -> Assigned - in - { definition_depth; uses } - -let assign_uses r = { r with uses = Assigned } - -let zero definition_depth = { definition_depth; uses = Zero } - -let add_definition t var depth = - V.Tbl.add t var (zero depth) - -let add_use t var depth = - match V.Tbl.find t var with - | info -> V.Tbl.replace t var (incr_uses info depth) - | exception Not_found -> () (* Variable is not let-bound *) - -let add_assignment t var = - match V.Tbl.find t var with - | info -> V.Tbl.replace t var (assign_uses info) - | exception Not_found -> - Misc.fatal_errorf - "make_var_info: Assigned variable %a not let-bound" - V.print var - -let make_var_info (clam : Clambda.ulambda) : var_info = - let t : var V.Tbl.t = V.Tbl.create 42 in - let environment_vars = ref V.Set.empty in - let rec loop ~depth : Clambda.ulambda -> unit = function - (* No underscores in the pattern match, to reduce the chance of failing - to traverse some subexpression. *) - | Uvar var -> add_use t var depth - | Uconst const -> - (* The only variables that might occur in [const] are those in constant - closures---and those are all bound by such closures. It follows that - [const] cannot contain any variables that are bound in the current - scope, so we do not need to count them here. (The function bodies - of the closures will be traversed when this function is called from - [Flambda_to_clambda.to_clambda_closed_set_of_closures].) *) - ignore_uconstant const - | Udirect_apply (label, args, _probe, result_layout, info, dbg) -> - ignore_function_label label; - List.iter (loop ~depth) args; - ignore_layout result_layout; - ignore_apply_kind info; - ignore_debuginfo dbg - | Ugeneric_apply (func, args, args_layout, result_layout, info, dbg) -> - loop ~depth func; - List.iter (loop ~depth) args; - List.iter ignore_layout args_layout; - ignore_layout result_layout; - ignore_apply_kind info; - ignore_debuginfo dbg - | Uclosure { functions; not_scanned_slots ; scanned_slots } -> - List.iter (loop ~depth) not_scanned_slots; - List.iter (loop ~depth) scanned_slots; - List.iter (fun ( - { Clambda. label; arity=_; params; body; dbg; env; mode=_; - check=_; poll=_ } as clos) -> - (match closure_environment_var clos with - | None -> () - | Some env_var -> - environment_vars := - V.Set.add (VP.var env_var) !environment_vars); - ignore_function_label label; - ignore_params params; - loop ~depth:(depth + 1) body; - ignore_debuginfo dbg; - ignore_var_option env) - functions - | Uoffset (expr, offset) -> - loop ~depth expr; - ignore_int offset - | Ulet (_let_kind, _layout, var, def, body) -> - add_definition t (VP.var var) depth; - loop ~depth def; - loop ~depth body - | Uphantom_let (var, defining_expr_opt, body) -> - ignore_var_with_provenance var; - ignore_uphantom_defining_expr_option defining_expr_opt; - loop ~depth body - | Uletrec (defs, body) -> - List.iter (fun (var, def) -> - ignore_var_with_provenance var; - loop ~depth def) - defs; - loop ~depth body - | Uprim (prim, args, dbg) -> - ignore_primitive prim; - List.iter (loop ~depth) args; - ignore_debuginfo dbg - | Uswitch (cond, { us_index_consts; us_actions_consts; - us_index_blocks; us_actions_blocks }, dbg, _kind) -> - loop ~depth cond; - ignore_int_array us_index_consts; - Array.iter (loop ~depth) us_actions_consts; - ignore_int_array us_index_blocks; - Array.iter (loop ~depth) us_actions_blocks; - ignore_debuginfo dbg - | Ustringswitch (cond, branches, default, _kind) -> - loop ~depth cond; - List.iter (fun (str, branch) -> - ignore_string str; - loop ~depth branch) - branches; - Option.iter (loop ~depth) default - | Ustaticfail (static_exn, args) -> - ignore_int static_exn; - List.iter (loop ~depth) args - | Ucatch (static_exn, vars, body, handler, kind) -> - ignore_layout kind; - ignore_int static_exn; - ignore_params_with_layout vars; - loop ~depth body; - loop ~depth handler - | Utrywith (body, var, handler, _kind) -> - loop ~depth body; - ignore_var_with_provenance var; - loop ~depth handler - | Uifthenelse (cond, ifso, ifnot, _kind) -> - loop ~depth cond; - loop ~depth ifso; - loop ~depth ifnot - | Usequence (e1, e2) -> - loop ~depth e1; - loop ~depth e2 - | Uwhile (cond, body) -> - loop ~depth:(depth + 1) cond; - loop ~depth:(depth + 1) body - | Ufor (var, low, high, direction_flag, body) -> - ignore_var_with_provenance var; - loop ~depth low; - loop ~depth high; - ignore_direction_flag direction_flag; - loop ~depth:(depth + 1) body - | Uassign (var, expr) -> - add_assignment t var; - loop ~depth expr - | Usend (meth_kind, e1, e2, args, args_layout, result_layout, info, dbg) -> - ignore_meth_kind meth_kind; - loop ~depth e1; - loop ~depth e2; - List.iter (loop ~depth) args; - List.iter ignore_layout args_layout; - ignore_layout result_layout; - ignore_apply_kind info; - ignore_debuginfo dbg - | Uunreachable -> - () - | Uregion e -> - loop ~depth e - | Uexclave e -> - (* Make sure we don't substitute into a `Uexclave`, which can be bad if the - definition reads from a local value *) - loop ~depth:(depth + 1) e - in - loop ~depth:0 clam; - let linear_let_bound_vars, used_let_bound_vars, assigned = - V.Tbl.fold (fun var desc ((linear, used, assigned) as acc) -> - match desc.uses with - | Zero -> acc - | One -> (V.Set.add var linear, V.Set.add var used, assigned) - | More_than_one -> (linear, V.Set.add var used, assigned) - | Assigned -> (linear, V.Set.add var used, V.Set.add var assigned)) - t (V.Set.empty, V.Set.empty, V.Set.empty) - in - { used_let_bound_vars; linear_let_bound_vars; assigned; - closure_environment = !environment_vars; - let_bound_vars_that_can_be_moved = V.Set.empty; - } - -(* When sequences of [let]-bindings match the evaluation order in a subsequent - primitive or function application whose arguments are linearly-used - non-assigned variables bound by such lets (possibly interspersed with other - variables that are known to be constant), and it is known that there were no - intervening side-effects during the evaluation of the [let]-bindings, - permit substitution of the variables for their defining expressions. *) -let let_bound_vars_that_can_be_moved var_info (clam : Clambda.ulambda) = - let obviously_constant = ref V.Set.empty in - let can_move = ref V.Set.empty in - let let_stack = ref [] in - let examine_argument_list args = - let rec loop let_bound_vars (args : Clambda.ulambda list) = - match let_bound_vars, args with - | _, [] -> - (* We've matched all arguments and will not substitute (in the - current application being considered) any of the remaining - [let_bound_vars]. As such they may stay on the stack. *) - let_bound_vars - | [], _ -> - (* There are no more [let]-bindings to consider, so the stack - is left empty. *) - [] - | let_bound_vars, (Uvar arg)::args - when V.Set.mem arg !obviously_constant -> - loop let_bound_vars args - | let_bound_var::let_bound_vars, (Uvar arg)::args - when V.same let_bound_var arg - && not (V.Set.mem arg var_info.assigned) -> - assert (V.Set.mem arg var_info.used_let_bound_vars); - assert (V.Set.mem arg var_info.linear_let_bound_vars); - can_move := V.Set.add arg !can_move; - loop let_bound_vars args - | _::_, _::_ -> - (* The [let] sequence has ceased to match the evaluation order - or we have encountered some complicated argument. In this case - we empty the stack to ensure that we do not end up moving an - outer [let] across a side effect. *) - [] - in - (* Start at the most recent let binding and the leftmost argument - (the last argument to be evaluated). *) - let_stack := loop !let_stack args - in - let rec loop : Clambda.ulambda -> unit = function - | Uvar var -> - if V.Set.mem var var_info.assigned then begin - let_stack := [] - end - | Uconst const -> - ignore_uconstant const - | Udirect_apply (label, args, probe, result_layout, info, dbg) -> - ignore_function_label label; - examine_argument_list args; - (* We don't currently traverse [args]; they should all be variables - anyway. If this is added in the future, take care to traverse [args] - following the evaluation order. *) - ignore_probe probe; - ignore_layout result_layout; - ignore_apply_kind info; - ignore_debuginfo dbg - | Ugeneric_apply (func, args, args_layout, result_layout, info, dbg) -> - examine_argument_list (args @ [func]); - List.iter ignore_layout args_layout; - ignore_layout result_layout; - ignore_apply_kind info; - ignore_debuginfo dbg - | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> - ignore_ulambda_list not_scanned_slots; - ignore_ulambda_list scanned_slots; - (* Start a new let stack for speed. *) - List.iter (fun {Clambda. label; arity=_; params; body; dbg; env; mode=_; - check=_; poll=_} -> - ignore_function_label label; - ignore_params params; - let_stack := []; - loop body; - let_stack := []; - ignore_debuginfo dbg; - ignore_var_option env) - functions - | Uoffset (expr, offset) -> - (* [expr] should usually be a variable. *) - examine_argument_list [expr]; - ignore_int offset - | Ulet (_let_kind, _layout, var, def, body) -> - let var = VP.var var in - begin match def with - | Uconst _ -> - (* The defining expression is obviously constant, so we don't - have to put this [let] on the stack, and we don't have to - traverse the defining expression either. *) - obviously_constant := V.Set.add var !obviously_constant; - loop body - | _ -> - loop def; - if V.Set.mem var var_info.linear_let_bound_vars then begin - let_stack := var::!let_stack - end else begin - (* If we encounter a non-linear [let]-binding then we must clear - the let stack, since we cannot now move any previous binding - across the non-linear one. *) - let_stack := [] - end; - loop body - end - | Uphantom_let (var, _defining_expr, body) -> - ignore_var_with_provenance var; - loop body - | Uletrec (defs, body) -> - (* Evaluation order for [defs] is not defined, and this case - probably isn't important for [Cmmgen] anyway. *) - let_stack := []; - List.iter (fun (var, def) -> - ignore_var_with_provenance var; - loop def; - let_stack := []) - defs; - loop body - | Uprim (prim, args, dbg) -> - ignore_primitive prim; - examine_argument_list args; - ignore_debuginfo dbg - | Uswitch (cond, { us_index_consts; us_actions_consts; - us_index_blocks; us_actions_blocks }, dbg, kind) -> - examine_argument_list [cond]; - ignore_int_array us_index_consts; - Array.iter (fun action -> - let_stack := []; - loop action) - us_actions_consts; - ignore_int_array us_index_blocks; - Array.iter (fun action -> - let_stack := []; - loop action) - us_actions_blocks; - ignore_debuginfo dbg; - ignore_layout kind; - let_stack := [] - | Ustringswitch (cond, branches, default, kind) -> - examine_argument_list [cond]; - List.iter (fun (str, branch) -> - ignore_string str; - let_stack := []; - loop branch) - branches; - let_stack := []; - Option.iter loop default; - ignore_layout kind; - let_stack := [] - | Ustaticfail (static_exn, args) -> - ignore_int static_exn; - examine_argument_list args - | Ucatch (static_exn, vars, body, handler, kind) -> - ignore_layout kind; - ignore_int static_exn; - ignore_params_with_layout vars; - let_stack := []; - loop body; - let_stack := []; - loop handler; - let_stack := [] - | Utrywith (body, var, handler, kind) -> - let_stack := []; - loop body; - let_stack := []; - ignore_var_with_provenance var; - loop handler; - ignore_layout kind; - let_stack := [] - | Uifthenelse (cond, ifso, ifnot, kind) -> - examine_argument_list [cond]; - let_stack := []; - loop ifso; - let_stack := []; - loop ifnot; - ignore_layout kind; - let_stack := [] - | Usequence (e1, e2) -> - loop e1; - let_stack := []; - loop e2; - let_stack := [] - | Uwhile (cond, body) -> - let_stack := []; - loop cond; - let_stack := []; - loop body; - let_stack := [] - | Ufor (var, low, high, direction_flag, body) -> - ignore_var_with_provenance var; - (* Cmmgen generates code that evaluates low before high, - but we don't do anything here at the moment anyway. *) - ignore_ulambda low; - ignore_ulambda high; - ignore_direction_flag direction_flag; - let_stack := []; - loop body; - let_stack := [] - | Uassign (var, expr) -> - ignore_var var; - ignore_ulambda expr; - let_stack := [] - | Usend (meth_kind, e1, e2, args, args_layout, result_layout, info, dbg) -> - ignore_meth_kind meth_kind; - ignore_ulambda e1; - ignore_ulambda e2; - ignore_ulambda_list args; - List.iter ignore_layout args_layout; - ignore_layout result_layout; - let_stack := []; - ignore_apply_kind info; - ignore_debuginfo dbg - | Uunreachable -> - let_stack := [] - | Uregion e -> - let_stack := []; - loop e - | Uexclave e -> - let_stack := []; - loop e - in - loop clam; - !can_move - -(* Substitution of an expression for a let-moveable variable can cause the - surrounding expression to become fixed. To avoid confusion, do the - let-moveable substitutions first. *) -let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda) - : Clambda.ulambda = - match clam with - | Uvar var -> - if not (V.Set.mem var is_let_moveable) then - clam - else - begin match V.Map.find var env with - | clam -> clam - | exception Not_found -> - Misc.fatal_errorf "substitute_let_moveable: Unbound variable %a" - V.print var - end - | Uconst _ -> clam - | Udirect_apply (label, args, probe, result_layout, kind, dbg) -> - let args = substitute_let_moveable_list is_let_moveable env args in - Udirect_apply (label, args, probe, result_layout, kind, dbg) - | Ugeneric_apply (func, args, args_layout, result_layout, kind, dbg) -> - let func = substitute_let_moveable is_let_moveable env func in - let args = substitute_let_moveable_list is_let_moveable env args in - Ugeneric_apply (func, args, args_layout, result_layout, kind, dbg) - | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> - let functions = - List.map (fun (ufunction : Clambda.ufunction) -> - { ufunction with - body = substitute_let_moveable is_let_moveable env ufunction.body; - }) - functions - in - let not_scanned_slots = - substitute_let_moveable_list is_let_moveable env - not_scanned_slots - in - let scanned_slots = - substitute_let_moveable_list is_let_moveable env - scanned_slots - in - Uclosure { functions ; not_scanned_slots; scanned_slots } - | Uoffset (clam, n) -> - let clam = substitute_let_moveable is_let_moveable env clam in - Uoffset (clam, n) - | Ulet (let_kind, layout, var, def, body) -> - let def = substitute_let_moveable is_let_moveable env def in - if V.Set.mem (VP.var var) is_let_moveable then - let env = V.Map.add (VP.var var) def env in - let body = substitute_let_moveable is_let_moveable env body in - (* If we are about to delete a [let] in debug mode, keep it for the - debugger. *) - (* CR-someday mshinwell: find out why some closure constructions were - not leaving phantom lets behind after substitution. *) - if not !Clflags.debug_full then - body - else - match def with - | Uconst const -> - Uphantom_let (var, Some (Clambda.Uphantom_const const), body) - | Uvar alias_of -> - Uphantom_let (var, Some (Clambda.Uphantom_var alias_of), body) - | _ -> - Uphantom_let (var, None, body) - else - Ulet (let_kind, layout, - var, def, substitute_let_moveable is_let_moveable env body) - | Uphantom_let (var, defining_expr, body) -> - let body = substitute_let_moveable is_let_moveable env body in - Uphantom_let (var, defining_expr, body) - | Uletrec (defs, body) -> - let defs = - List.map (fun (var, def) -> - var, substitute_let_moveable is_let_moveable env def) - defs - in - let body = substitute_let_moveable is_let_moveable env body in - Uletrec (defs, body) - | Uprim (prim, args, dbg) -> - let args = substitute_let_moveable_list is_let_moveable env args in - Uprim (prim, args, dbg) - | Uswitch (cond, sw, dbg, kind) -> - let cond = substitute_let_moveable is_let_moveable env cond in - let sw = - { sw with - us_actions_consts = - substitute_let_moveable_array is_let_moveable env - sw.us_actions_consts; - us_actions_blocks = - substitute_let_moveable_array is_let_moveable env - sw.us_actions_blocks; - } - in - Uswitch (cond, sw, dbg, kind) - | Ustringswitch (cond, branches, default, kind) -> - let cond = substitute_let_moveable is_let_moveable env cond in - let branches = - List.map (fun (s, branch) -> - s, substitute_let_moveable is_let_moveable env branch) - branches - in - let default = - Option.map (substitute_let_moveable is_let_moveable env) default - in - Ustringswitch (cond, branches, default, kind) - | Ustaticfail (n, args) -> - let args = substitute_let_moveable_list is_let_moveable env args in - Ustaticfail (n, args) - | Ucatch (n, vars, body, handler, kind) -> - let body = substitute_let_moveable is_let_moveable env body in - let handler = substitute_let_moveable is_let_moveable env handler in - Ucatch (n, vars, body, handler, kind) - | Utrywith (body, var, handler, kind) -> - let body = substitute_let_moveable is_let_moveable env body in - let handler = substitute_let_moveable is_let_moveable env handler in - Utrywith (body, var, handler, kind) - | Uifthenelse (cond, ifso, ifnot, kind) -> - let cond = substitute_let_moveable is_let_moveable env cond in - let ifso = substitute_let_moveable is_let_moveable env ifso in - let ifnot = substitute_let_moveable is_let_moveable env ifnot in - Uifthenelse (cond, ifso, ifnot, kind) - | Usequence (e1, e2) -> - let e1 = substitute_let_moveable is_let_moveable env e1 in - let e2 = substitute_let_moveable is_let_moveable env e2 in - Usequence (e1, e2) - | Uwhile (cond, body) -> - let cond = substitute_let_moveable is_let_moveable env cond in - let body = substitute_let_moveable is_let_moveable env body in - Uwhile (cond, body) - | Ufor (var, low, high, direction, body) -> - let low = substitute_let_moveable is_let_moveable env low in - let high = substitute_let_moveable is_let_moveable env high in - let body = substitute_let_moveable is_let_moveable env body in - Ufor (var, low, high, direction, body) - | Uassign (var, expr) -> - let expr = substitute_let_moveable is_let_moveable env expr in - Uassign (var, expr) - | Usend (kind, e1, e2, args, args_layout, result_layout, pos, dbg) -> - let e1 = substitute_let_moveable is_let_moveable env e1 in - let e2 = substitute_let_moveable is_let_moveable env e2 in - let args = substitute_let_moveable_list is_let_moveable env args in - Usend (kind, e1, e2, args, args_layout, result_layout, pos, dbg) - | Uunreachable -> - Uunreachable - | Uregion e -> - let e = substitute_let_moveable is_let_moveable env e in - Uregion (e) - | Uexclave e -> - let e = substitute_let_moveable is_let_moveable env e in - Uexclave (e) - -and substitute_let_moveable_list is_let_moveable env clams = - List.map (substitute_let_moveable is_let_moveable env) clams - -and substitute_let_moveable_array is_let_moveable env clams = - Array.map (substitute_let_moveable is_let_moveable env) clams - -(* We say that an expression is "moveable" iff it has neither effects nor - coeffects. (See semantics_of_primitives.mli.) -*) -type moveable = Fixed | Constant | Moveable - -let both_moveable a b = - match a, b with - | Constant, Constant -> Constant - | Constant, Moveable - | Moveable, Constant - | Moveable, Moveable -> Moveable - | Constant, Fixed - | Moveable, Fixed - | Fixed, Constant - | Fixed, Moveable - | Fixed, Fixed -> Fixed - -let primitive_moveable (prim : Clambda_primitives.primitive) - (args : Clambda.ulambda list) - (var_info : var_info) = - match prim, args with - | Pfield _, [Uconst (Uconst_ref (_, _))] -> - (* CR-someday mshinwell: Actually, maybe this shouldn't be needed; these - should have been simplified to [Read_symbol_field], which doesn't yield - a Clambda let. This might be fixed when Inline_and_simplify can - turn Pfield into Read_symbol_field. *) - (* Allow field access of symbols to be moveable. (The comment in - flambda.mli on [Read_symbol_field] may be helpful to the reader.) *) - Moveable - | Pfield _, [Uvar var] when V.Set.mem var var_info.closure_environment -> - (* accesses to the function environment is coeffect free: this block - is never mutated *) - Moveable - | _ -> - match Semantics_of_primitives.for_primitive prim with - | No_effects, No_coeffects -> Moveable - | No_effects, Has_coeffects - | Only_generative_effects, No_coeffects - | Only_generative_effects, Has_coeffects - | Arbitrary_effects, No_coeffects - | Arbitrary_effects, Has_coeffects -> Fixed - -type moveable_for_env = Constant | Moveable - -(** Eliminate, through substitution, [let]-bindings of linear variables with - moveable defining expressions. *) -let rec un_anf_and_moveable var_info env (clam : Clambda.ulambda) - : Clambda.ulambda * moveable = - match clam with - | Uvar var -> - begin match V.Map.find var env with - | Constant, def -> def, Constant - | Moveable, def -> def, Moveable - | exception Not_found -> - let moveable : moveable = - if V.Set.mem var var_info.assigned then - Fixed - else - Moveable - in - clam, moveable - end - | Uconst _ -> - (* Constant closures are rewritten separately. *) - clam, Constant - | Udirect_apply (label, args, probe, result_layout, kind, dbg) -> - let args = un_anf_list var_info env args in - Udirect_apply (label, args, probe, result_layout, kind, dbg), Fixed - | Ugeneric_apply (func, args, args_layout, result_layout, kind, dbg) -> - let func = un_anf var_info env func in - let args = un_anf_list var_info env args in - Ugeneric_apply (func, args, args_layout, result_layout, kind, dbg), Fixed - | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> - let functions = - List.map (fun (ufunction : Clambda.ufunction) -> - { ufunction with - body = un_anf var_info env ufunction.body; - }) - functions - in - let not_scanned_slots = un_anf_list var_info env not_scanned_slots in - let scanned_slots = un_anf_list var_info env scanned_slots in - Uclosure { functions ; not_scanned_slots ; scanned_slots }, Fixed - | Uoffset (clam, n) -> - let clam, moveable = un_anf_and_moveable var_info env clam in - Uoffset (clam, n), both_moveable Moveable moveable - | Ulet (_let_kind, _layout, var, def, Uvar var') - when V.same (VP.var var) var' -> - un_anf_and_moveable var_info env def - | Ulet (let_kind, layout, var, def, body) -> - let def, def_moveable = un_anf_and_moveable var_info env def in - let is_linear = V.Set.mem (VP.var var) var_info.linear_let_bound_vars in - let is_used = V.Set.mem (VP.var var) var_info.used_let_bound_vars in - let is_assigned = - V.Set.mem (VP.var var) var_info.assigned - in - let maybe_for_debugger (body, moveable) : Clambda.ulambda * moveable = - if not !Clflags.debug_full then - body, moveable - else - match def with - | Uconst const -> - Uphantom_let (var, Some (Clambda.Uphantom_const const), - body), moveable - | Uvar alias_of -> - Uphantom_let (var, Some (Clambda.Uphantom_var alias_of), body), - moveable - | _ -> - Uphantom_let (var, None, body), moveable - in - begin match def_moveable, is_linear, is_used, is_assigned with - | (Constant | Moveable), _, false, _ -> - (* A moveable expression that is never used may be eliminated. - However, if in debug mode and the defining expression is - appropriate, keep the let (as a phantom let) for the debugger. *) - maybe_for_debugger (un_anf_and_moveable var_info env body) - | Constant, _, true, false - (* A constant expression bound to an unassigned variable can replace any - occurrences of the variable. The same comment as above concerning - phantom lets applies. *) - | Moveable, true, true, false -> - (* A moveable expression bound to a linear unassigned [V.t] - may replace the single occurrence of the variable. The same comment - as above concerning phantom lets applies. *) - let def_moveable = - match def_moveable with - | Moveable -> Moveable - | Constant -> Constant - | Fixed -> assert false - in - let env = V.Map.add (VP.var var) (def_moveable, def) env in - maybe_for_debugger (un_anf_and_moveable var_info env body) - | (Constant | Moveable), _, _, true - (* Constant or Moveable but assigned. *) - | Moveable, false, _, _ - (* Moveable but not used linearly. *) - | Fixed, _, _, _ -> - let body, body_moveable = un_anf_and_moveable var_info env body in - Ulet (let_kind, layout, var, def, body), - both_moveable def_moveable body_moveable - end - | Uphantom_let (var, defining_expr, body) -> - let body, body_moveable = un_anf_and_moveable var_info env body in - Uphantom_let (var, defining_expr, body), body_moveable - | Uletrec (defs, body) -> - let defs = - List.map (fun (var, def) -> var, un_anf var_info env def) defs - in - let body = un_anf var_info env body in - Uletrec (defs, body), Fixed - | Uprim (prim, args, dbg) -> - let args, args_moveable = un_anf_list_and_moveable var_info env args in - let moveable = - both_moveable args_moveable (primitive_moveable prim args var_info) - in - Uprim (prim, args, dbg), moveable - | Uswitch (cond, sw, dbg, kind) -> - let cond = un_anf var_info env cond in - let sw = - { sw with - us_actions_consts = un_anf_array var_info env sw.us_actions_consts; - us_actions_blocks = un_anf_array var_info env sw.us_actions_blocks; - } - in - Uswitch (cond, sw, dbg, kind), Fixed - | Ustringswitch (cond, branches, default, kind) -> - let cond = un_anf var_info env cond in - let branches = - List.map (fun (s, branch) -> s, un_anf var_info env branch) - branches - in - let default = Option.map (un_anf var_info env) default in - Ustringswitch (cond, branches, default, kind), Fixed - | Ustaticfail (n, args) -> - let args = un_anf_list var_info env args in - Ustaticfail (n, args), Fixed - | Ucatch (n, vars, body, handler, kind) -> - let body = un_anf var_info env body in - let handler = un_anf var_info env handler in - Ucatch (n, vars, body, handler, kind), Fixed - | Utrywith (body, var, handler, kind) -> - let body = un_anf var_info env body in - let handler = un_anf var_info env handler in - Utrywith (body, var, handler, kind), Fixed - | Uifthenelse (cond, ifso, ifnot, kind) -> - let cond, cond_moveable = un_anf_and_moveable var_info env cond in - let ifso, ifso_moveable = un_anf_and_moveable var_info env ifso in - let ifnot, ifnot_moveable = un_anf_and_moveable var_info env ifnot in - let moveable = - both_moveable cond_moveable - (both_moveable ifso_moveable ifnot_moveable) - in - Uifthenelse (cond, ifso, ifnot, kind), moveable - | Usequence (e1, e2) -> - let e1 = un_anf var_info env e1 in - let e2 = un_anf var_info env e2 in - Usequence (e1, e2), Fixed - | Uwhile (cond, body) -> - let cond = un_anf var_info env cond in - let body = un_anf var_info env body in - Uwhile (cond, body), Fixed - | Ufor (var, low, high, direction, body) -> - let low = un_anf var_info env low in - let high = un_anf var_info env high in - let body = un_anf var_info env body in - Ufor (var, low, high, direction, body), Fixed - | Uassign (var, expr) -> - let expr = un_anf var_info env expr in - Uassign (var, expr), Fixed - | Usend (kind, e1, e2, args, args_layout, result_layout, pos, dbg) -> - let e1 = un_anf var_info env e1 in - let e2 = un_anf var_info env e2 in - let args = un_anf_list var_info env args in - Usend (kind, e1, e2, args, args_layout, result_layout, pos, dbg), Fixed - | Uunreachable -> - Uunreachable, Fixed - | Uregion e -> - let e = un_anf var_info env e in - Uregion e, Fixed - | Uexclave e -> - let e = un_anf var_info env e in - Uexclave e, Fixed - -and un_anf var_info env clam : Clambda.ulambda = - let clam, _moveable = un_anf_and_moveable var_info env clam in - clam - -and un_anf_list_and_moveable var_info env clams - : Clambda.ulambda list * moveable = - List.fold_right (fun clam (l, acc_moveable) -> - let clam, moveable = un_anf_and_moveable var_info env clam in - clam :: l, both_moveable moveable acc_moveable) - clams ([], (Moveable : moveable)) - -and un_anf_list var_info env clams : Clambda.ulambda list = - let clams, _moveable = un_anf_list_and_moveable var_info env clams in - clams - -and un_anf_array var_info env clams : Clambda.ulambda array = - Array.map (un_anf var_info env) clams - -let apply ~what ~ppf_dump clam = - let var_info = make_var_info clam in - let let_bound_vars_that_can_be_moved = - let_bound_vars_that_can_be_moved var_info clam - in - let clam = - substitute_let_moveable let_bound_vars_that_can_be_moved - V.Map.empty clam - in - let var_info = make_var_info clam in - let clam = un_anf var_info V.Map.empty clam in - Compiler_hooks.execute Compiler_hooks.Clambda clam; - if !Clflags.dump_clambda then begin - Format.fprintf ppf_dump - "@.un-anf (%a):@ %a@." - Symbol.print what - Printclambda.clambda clam - end; - clam diff --git a/middle_end/flambda/un_anf.mli b/middle_end/flambda/un_anf.mli deleted file mode 100644 index a7d5e94e841..00000000000 --- a/middle_end/flambda/un_anf.mli +++ /dev/null @@ -1,23 +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. *) -(* *) -(**************************************************************************) - -(** Expand ANF-like constructs so that pattern matches in [Cmmgen] will - work correctly. *) -val apply - : what:Symbol.t - -> ppf_dump:Format.formatter - -> Clambda.ulambda - -> Clambda.ulambda diff --git a/middle_end/flambda/unbox_closures.ml b/middle_end/flambda/unbox_closures.ml deleted file mode 100644 index 2045ca90c38..00000000000 --- a/middle_end/flambda/unbox_closures.ml +++ /dev/null @@ -1,88 +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-66"] -open! Int_replace_polymorphic_compare - -module ASA = Augment_specialised_args -module W = ASA.What_to_specialise -module E = Inline_and_simplify_aux.Env - -module Transform = struct - let pass_name = "unbox-closures" - - let precondition ~env ~(set_of_closures : Flambda.set_of_closures) = - !Clflags.unbox_closures - && not (E.at_toplevel env) - && not (Variable.Map.is_empty set_of_closures.free_vars) - - let what_to_specialise ~env ~(set_of_closures : Flambda.set_of_closures) = - let what_to_specialise = W.create ~set_of_closures in - if not (precondition ~env ~set_of_closures) then - what_to_specialise - else begin - let round = E.round env in - let num_closure_vars = Variable.Map.cardinal set_of_closures.free_vars in - let module B = Inlining_cost.Benefit in - let saved_by_not_building_closure = - (* For the moment assume that we're going to cause all functions in the - set to become closed. *) - B.remove_prims (B.remove_call B.zero) num_closure_vars - in - Flambda_iterators.fold_function_decls_ignoring_stubs set_of_closures - ~init:what_to_specialise - ~f:(fun ~fun_var ~(function_decl : Flambda.function_declaration) - what_to_specialise -> - let body_size = Inlining_cost.lambda_size function_decl.body in - (* If the function is small enough, make a direct call surrogate - for it, so that indirect calls are not penalised by having to - bounce through the stub. (Making such a surrogate involves - duplicating the function.) *) - let small_enough_to_duplicate = - let module W = Inlining_cost.Whether_sufficient_benefit in - let wsb = - W.create_estimate ~original_size:0 - ~toplevel:false - ~branch_depth:0 - ~new_size:((body_size / !Clflags.unbox_closures_factor) + 1) - ~benefit:saved_by_not_building_closure - ~lifting:false - ~round - in - W.evaluate wsb - in - let what_to_specialise = - if small_enough_to_duplicate then - W.make_direct_call_surrogate_for what_to_specialise ~fun_var - else - what_to_specialise - in - let bound_by_the_closure = - Flambda_utils.variables_bound_by_the_closure - (Closure_id.wrap fun_var) - set_of_closures.function_decls - in - Variable.Set.fold (fun inner_free_var what_to_specialise -> - let kind = (Variable.Map.find inner_free_var set_of_closures.free_vars).kind in - W.new_specialised_arg what_to_specialise - ~fun_var ~group:inner_free_var - ~definition:(Existing_inner_free_var (inner_free_var, kind))) - bound_by_the_closure - what_to_specialise) - end -end - -include ASA.Make (Transform) diff --git a/middle_end/flambda/unbox_closures.mli b/middle_end/flambda/unbox_closures.mli deleted file mode 100644 index fb935a622b1..00000000000 --- a/middle_end/flambda/unbox_closures.mli +++ /dev/null @@ -1,33 +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"] - -(** Turn free variables of closures into specialised arguments. - The aim is to cause the closure to become closed. *) - -val rewrite_set_of_closures - : env:Inline_and_simplify_aux.Env.t - (* CR-soon mshinwell: eliminate superfluous parameter *) - -> duplicate_function:( - env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> fun_var:Variable.t - -> new_fun_var:Variable.t - -> Flambda.function_declaration - * Flambda.specialised_to Variable.Map.t) - -> set_of_closures:Flambda.set_of_closures - -> (Flambda.expr * Inlining_cost.Benefit.t) option diff --git a/middle_end/flambda/unbox_free_vars_of_closures.ml b/middle_end/flambda/unbox_free_vars_of_closures.ml deleted file mode 100644 index a9a20422bd5..00000000000 --- a/middle_end/flambda/unbox_free_vars_of_closures.ml +++ /dev/null @@ -1,172 +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-66"] -open! Int_replace_polymorphic_compare - -module B = Inlining_cost.Benefit - -let pass_name = "unbox-free-vars-of-closures" -let () = Pass_wrapper.register ~pass_name - -(* CR-someday mshinwell: Nearly but not quite the same as something that - Augment_specialised_args uses. *) -let add_lifted_projections_around_set_of_closures - ~set_of_closures ~existing_inner_to_outer_vars ~benefit - ~definitions_indexed_by_new_inner_vars = - let body = - Flambda_utils.name_expr (Set_of_closures set_of_closures) - ~name:Internal_variable_names.unbox_free_vars_of_closures - in - Variable.Map.fold (fun new_inner_var (projection : Projection.t) - (expr, benefit) -> - let find_outer_var inner_var = - match - Variable.Map.find inner_var existing_inner_to_outer_vars - with - | (outer_var : Flambda.specialised_to) -> outer_var.var - | exception Not_found -> - Misc.fatal_errorf "(UFV) find_outer_var: expected %a \ - to be in [existing_inner_to_outer_vars], but it is \ - not. (The projection was: %a)" - Variable.print inner_var - Projection.print projection - in - let benefit = B.add_projection projection benefit in - let named : Flambda.named = - (* The lifted projection must be in terms of outer variables, - not inner variables. *) - let projection = - Projection.map_projecting_from projection ~f:find_outer_var - in - Flambda_utils.projection_to_named projection - in - let expr = - Flambda.create_let (find_outer_var new_inner_var) named expr - in - (expr, benefit)) - definitions_indexed_by_new_inner_vars - (body, benefit) - -let run ~env ~(set_of_closures : Flambda.set_of_closures) = - if not !Clflags.unbox_free_vars_of_closures then - None - else - let definitions_indexed_by_new_inner_vars, _, free_vars, done_something = - let all_existing_definitions = - Variable.Map.fold (fun _inner_var (outer_var : Flambda.specialised_to) - all_existing_definitions -> - match outer_var.projection with - | None -> all_existing_definitions - | Some projection -> - Projection.Set.add projection all_existing_definitions) - set_of_closures.free_vars - Projection.Set.empty - in - Flambda_iterators.fold_function_decls_ignoring_stubs set_of_closures - ~init:(Variable.Map.empty, all_existing_definitions, - set_of_closures.free_vars, false) - ~f:(fun ~fun_var:_ ~function_decl result -> - let extracted = - Extract_projections.from_function_decl ~env ~function_decl - ~which_variables:set_of_closures.free_vars - in - Projection.Set.fold (fun projection - ((definitions_indexed_by_new_inner_vars, - all_existing_definitions_including_added_ones, - additional_free_vars, _done_something) as result) -> - (* Don't add a new free variable if there already exists a - free variable with the desired projection. We need to - dedup not only across the existing free variables but - also across newly-added ones (unlike in - [Augment_specialised_args]), since free variables are - not local to a function declaration but rather to a - set of closures. *) - if Projection.Set.mem projection - all_existing_definitions_including_added_ones - then begin - result - end else begin - (* Add a new free variable. This needs both a fresh - "new inner" and a fresh "new outer" var, since we know - the definition is not a duplicate. *) - let projecting_from = Projection.projecting_from projection in - let kind = (Variable.Map.find projecting_from set_of_closures.free_vars).kind in - let new_inner_var = Variable.rename projecting_from in - let new_outer_var = Variable.rename projecting_from in - let definitions_indexed_by_new_inner_vars = - Variable.Map.add new_inner_var projection - definitions_indexed_by_new_inner_vars - in - let all_existing_definitions_including_added_ones = - Projection.Set.add projection - all_existing_definitions_including_added_ones - in - let new_outer_var : Flambda.specialised_to = - { var = new_outer_var; - projection = Some projection; - kind; - } - in - let additional_free_vars = - Variable.Map.add new_inner_var new_outer_var - additional_free_vars - in - definitions_indexed_by_new_inner_vars, - all_existing_definitions_including_added_ones, - additional_free_vars, - true - end) - extracted - result) - in - if not done_something then - None - else - (* CR-someday mshinwell: could consider doing the grouping thing - similar to Augment_specialised_args *) - let num_free_vars_before = - Variable.Map.cardinal set_of_closures.free_vars - in - let num_free_vars_after = - Variable.Map.cardinal free_vars - in - assert (num_free_vars_after > num_free_vars_before); - (* Don't let the closure grow too large. *) - if num_free_vars_after > 2 * num_free_vars_before then - None - else - let set_of_closures = - Flambda.create_set_of_closures - ~function_decls:set_of_closures.function_decls - ~free_vars - ~specialised_args:set_of_closures.specialised_args - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - let expr, benefit = - add_lifted_projections_around_set_of_closures ~set_of_closures - ~benefit:B.zero - ~existing_inner_to_outer_vars:set_of_closures.free_vars - ~definitions_indexed_by_new_inner_vars - in - Some (expr, benefit) - -let run ~env ~set_of_closures = - Pass_wrapper.with_dump ~ppf_dump:(Inline_and_simplify_aux.Env.ppf_dump env) - ~pass_name ~input:set_of_closures - ~print_input:Flambda.print_set_of_closures - ~print_output:(fun ppf (expr, _) -> Flambda.print ppf expr) - ~f:(fun () -> run ~env ~set_of_closures) diff --git a/middle_end/flambda/unbox_free_vars_of_closures.mli b/middle_end/flambda/unbox_free_vars_of_closures.mli deleted file mode 100644 index 3ee181ee3c5..00000000000 --- a/middle_end/flambda/unbox_free_vars_of_closures.mli +++ /dev/null @@ -1,26 +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. *) -(* *) -(**************************************************************************) - -(** When approximations of free variables of closures indicate that they - are closures or blocks, rewrite projections from such blocks to new - variables (which become free in the closures), with the defining - expressions of the projections lifted out of the corresponding sets - of closures. *) - -val run - : env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> (Flambda.expr * Inlining_cost.Benefit.t) option diff --git a/middle_end/flambda/unbox_specialised_args.ml b/middle_end/flambda/unbox_specialised_args.ml deleted file mode 100644 index ac928428a08..00000000000 --- a/middle_end/flambda/unbox_specialised_args.ml +++ /dev/null @@ -1,104 +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-66"] -open! Int_replace_polymorphic_compare - -module ASA = Augment_specialised_args -module W = ASA.What_to_specialise - -module Transform = struct - let pass_name = "unbox-specialised-args" - - let precondition ~env:_ ~(set_of_closures : Flambda.set_of_closures) = - !Clflags.unbox_specialised_args - && not (Variable.Map.is_empty set_of_closures.specialised_args) - - let what_to_specialise ~env ~(set_of_closures : Flambda.set_of_closures) = - let what_to_specialise = W.create ~set_of_closures in - if not (precondition ~env ~set_of_closures) then - what_to_specialise - else - let projections_by_function = - set_of_closures.function_decls.funs |> Variable.Map.filter_map - (fun _fun_var (function_decl : Flambda.function_declaration) -> - if function_decl.stub then None - else - Some (Extract_projections.from_function_decl ~env - ~function_decl - ~which_variables:set_of_closures.specialised_args)) - in - (* CR-soon mshinwell: consider caching the Invariant_params *relation* - as well as the "_in_recursion" map *) - let invariant_params_flow = - Invariant_params.invariant_param_sources set_of_closures.function_decls - in - Variable.Map.fold (fun fun_var extractions what_to_specialise -> - Projection.Set.fold (fun (projection : Projection.t) - what_to_specialise -> - let group = Projection.projecting_from projection in - assert (Variable.Map.mem group set_of_closures.specialised_args); - let kind = (Variable.Map.find group set_of_closures.specialised_args).kind in - let what_to_specialise = - W.new_specialised_arg what_to_specialise ~fun_var ~group - ~definition:(Projection_from_existing_specialised_arg - (projection, kind)) - in - match Variable.Map.find group invariant_params_flow with - | exception Not_found -> what_to_specialise - | flow -> - (* If for function [f] we would extract a projection expression - [e] from some specialised argument [x] of [f], and we know - from [Invariant_params] that a specialised argument [y] of - another function [g] flows to [x], we will add [e] with - [y] substituted for [x] throughout as a newly-specialised - argument for [g]. This should help reduce the number of - simplification rounds required for mutually-recursive - functions. *) - Variable.Pair.Set.fold (fun (target_fun_var, target_spec_arg) - what_to_specialise -> - if Variable.equal fun_var target_fun_var - || not (Variable.Map.mem target_spec_arg - set_of_closures.specialised_args) - then begin - what_to_specialise - end else begin - (* Rewrite the projection (that was in terms of an inner - specialised arg of [fun_var]) to be in terms of the - corresponding inner specialised arg of - [target_fun_var]. (The outer vars referenced in the - projection remain unchanged.) *) - let kind = (Variable.Map.find target_spec_arg set_of_closures.specialised_args).kind in - let projection = - Projection.map_projecting_from projection - ~f:(fun var -> - assert (Variable.equal var group); - target_spec_arg) - in - W.new_specialised_arg what_to_specialise - ~fun_var:target_fun_var ~group - ~definition: - (Projection_from_existing_specialised_arg (projection, kind)) - end) - flow - what_to_specialise) - extractions - what_to_specialise) - projections_by_function - what_to_specialise -end - -include ASA.Make (Transform) diff --git a/middle_end/flambda/unbox_specialised_args.mli b/middle_end/flambda/unbox_specialised_args.mli deleted file mode 100644 index f0191764821..00000000000 --- a/middle_end/flambda/unbox_specialised_args.mli +++ /dev/null @@ -1,50 +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. *) -(* *) -(**************************************************************************) - -(** When approximations of specialised arguments indicate that they are - closures or blocks, add more specialised arguments corresponding to - the projections from such blocks (with definitions of such projections - lifted out), such that the original specialised arguments may later be - eliminated. - - This in particular enables elimination of closure allocations in - examples such as: - - let rec map f = function - | [] -> [] - | a::l -> let r = f a in r :: map f l - - let g x = - map (fun y -> x + y) [1; 2; 3; 4] - - Here, the specialised version of [map] initially has a specialised - argument [f]; and upon inlining there will be a projection of [x] from - the closure of [f]. This pass adds a new specialised argument to carry - that projection, at which point the closure of [f] is redundant. -*) - -val rewrite_set_of_closures - : env:Inline_and_simplify_aux.Env.t - (* CR-soon mshinwell: eliminate superfluous parameter *) - -> duplicate_function:( - env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> fun_var:Variable.t - -> new_fun_var:Variable.t - -> Flambda.function_declaration - * Flambda.specialised_to Variable.Map.t) - -> set_of_closures:Flambda.set_of_closures - -> (Flambda.expr * Inlining_cost.Benefit.t) option diff --git a/middle_end/flambda2/flambda2.ml b/middle_end/flambda2/flambda2.ml index fa4bd809d15..87c7199123d 100644 --- a/middle_end/flambda2/flambda2.ml +++ b/middle_end/flambda2/flambda2.ml @@ -34,18 +34,6 @@ let get_module_info comp_unit = match Compilenv.get_unit_export_info comp_unit with | None | Some (Flambda2 None) -> None | Some (Flambda2 (Some info)) -> Some info - | Some (Clambda _) -> - (* CR mshinwell: This should be a user error, not a fatal error. Same - below. *) - Misc.fatal_errorf - "The .cmx file for unit %a was compiled with the Closure middle-end, \ - not Flambda 2, and cannot be loaded" - Compilation_unit.Name.print cmx_name - | Some (Flambda1 _) -> - Misc.fatal_errorf - "The .cmx file for unit %a was compiled with the Flambda 1 middle-end, \ - not Flambda 2, and cannot be loaded" - Compilation_unit.Name.print cmx_name let dump_to_target_if_any main_dump_ppf target ~header ~f a = match (target : Flambda_features.dump_target) with diff --git a/middle_end/flambda2/to_cmm/to_cmm.ml b/middle_end/flambda2/to_cmm/to_cmm.ml index a435b98a2e8..8c8aec666d3 100644 --- a/middle_end/flambda2/to_cmm/to_cmm.ml +++ b/middle_end/flambda2/to_cmm/to_cmm.ml @@ -40,13 +40,9 @@ let flush_cmm_helpers_state res = | Const_table (global, l) -> let res, sym = R.raw_symbol res ~global name in res, C.cdata (C.define_symbol sym @ l) :: acc - | Const_closure _ -> - Misc.fatal_errorf - "There shouldn't be any closures in Cmmgen_state during Flambda 2 to \ - Cmm translation" in (* reset the structured constants, just in case *) - Cmmgen_state.set_local_structured_constants []; + Cmmgen_state.clear_local_structured_constants (); match Cmmgen_state.get_and_clear_data_items () with | [] -> let cst_map = Cmmgen_state.get_and_clear_constants () in diff --git a/middle_end/flambda2/to_cmm/to_cmm_static.ml b/middle_end/flambda2/to_cmm/to_cmm_static.ml index 22f3680aa4d..583eab03427 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_static.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_static.ml @@ -129,21 +129,21 @@ let static_const0 env res ~updates (bound_static : Bound_static.Pattern.t) | Block_like symbol, Boxed_float v -> let default = Numeric_types.Float_by_bit_pattern.zero in let transl = Numeric_types.Float_by_bit_pattern.to_float in - let structured f = Clambda.Uconst_float f in + let structured f = Cmmgen_state.Const_float f in let res, env, updates = static_boxed_number ~kind:Double ~env ~symbol ~default ~emit:C.emit_float_constant ~transl ~structured v res updates in env, res, updates | Block_like symbol, Boxed_int32 v -> - let structured i = Clambda.Uconst_int32 i in + let structured i = Cmmgen_state.Const_int32 i in let res, env, updates = static_boxed_number ~kind:Word_int ~env ~symbol ~default:0l ~emit:C.emit_int32_constant ~transl:Fun.id ~structured v res updates in env, res, updates | Block_like symbol, Boxed_int64 v -> - let structured i = Clambda.Uconst_int64 i in + let structured i = Cmmgen_state.Const_int64 i in let res, env, updates = static_boxed_number ~kind:Word_int ~env ~symbol ~default:0L ~emit:C.emit_int64_constant ~transl:Fun.id ~structured v res updates @@ -152,7 +152,7 @@ let static_const0 env res ~updates (bound_static : Bound_static.Pattern.t) | Block_like symbol, Boxed_nativeint v -> let default = Targetint_32_64.zero in let transl = C.nativeint_of_targetint in - let structured i = Clambda.Uconst_nativeint i in + let structured i = Cmmgen_state.Const_nativeint i in let res, env, updates = static_boxed_number ~kind:Word_int ~env ~symbol ~default ~emit:C.emit_nativeint_constant ~transl ~structured v res updates @@ -166,7 +166,9 @@ let static_const0 env res ~updates (bound_static : Bound_static.Pattern.t) in { Cmm.high; low } in - let structured { Cmm.high; low } = Clambda.Uconst_vec128 { high; low } in + let structured { Cmm.high; low } = + Cmmgen_state.Const_vec128 { high; low } + in let res, env, updates = (* Unaligned because boxed vec128 constants are not aligned during code emission. Aligning them would complicate block layout. *) diff --git a/middle_end/internal_variable_names.ml b/middle_end/internal_variable_names.ml deleted file mode 100644 index 2411306b80f..00000000000 --- a/middle_end/internal_variable_names.ml +++ /dev/null @@ -1,646 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fu Yong Quah, Jane Street Europe *) -(* *) -(* Copyright 2017 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-66"] -open! Int_replace_polymorphic_compare - -type t = string - -let apply_arg = "apply_arg" -let apply_funct = "apply_funct" -let block_symbol = "block_symbol" -let block_symbol_get = "block_symbol_get" -let block_symbol_get_field = "block_symbol_get_field" -let boxed_in_closure = "boxed_in_closure" -let boxing_closure = "boxing_closure" -let boxing_closure_field = "boxing_closure_field" -let boxing_set_of_closures = "boxing_set_of_closures" -let closure = "closure" -let cond = "cond" -let cond_sequor = "cond_sequor" -let const_block = "const_block" -let const_bool = "const_bool" -let const_boxed_int = "const_boxed_int" -let const_char = "const_char" -let const_false = "const_false" -let const_float = "const_float" -let const_int = "const_int" -let const_one = "const_one" -let const_ptr = "const_ptr" -let const_ptr_one = "const_ptr_one" -let const_ptr_zero = "const_ptr_zero" -let const_sequand = "const_sequand" -let const_string = "const_string" -let const_true = "const_true" -let const_zero = "const_zero" -let denominator = "denominator" -let division_by_zero = "division_by_zero" -let dummy = "dummy" -let dup_func = "dup_func" -let dup_set_of_closures = "dup_set_of_closures" -let const_float_array = "const_float_array" -let fake_effect_symbol = "fake_effect_symbol" -let for_from = "for_from" -let for_to = "for_to" -let from_closure = "from_closure" -let full_apply = "full_apply" -let get_symbol_field = "get_symbol_field" -let const_immstring = "const_immstring" -let const_int32 = "const_int32" -let const_int64 = "const_int64" -let ignore = "ignore" -let is_zero = "is_zero" -let lifted_let_rec_block = "lifted_let_rec_block" -let meth = "meth" -let module_as_block = "module_as_block" -let const_nativeint = "const_nativeint" -let new_value = "new_value" -let numerator = "numerator" -let obj = "obj" -let offsetted = "offsetted" -let pabsfloat = "Pabsfloat" -let paddbint = "Paddbint" -let paddfloat = "Paddfloat" -let paddint = "Paddint" -let pandbint = "Pandbint" -let pandint = "Pandint" -let parraylength = "Parraylength" -let parrayrefs = "Parrayrefs" -let parrayrefu = "Parrayrefu" -let parraysets = "Parraysets" -let parraysetu = "Parraysetu" -let pasrbint = "Pasrbint" -let pasrint = "Pasrint" -let pbbswap = "Pbbswap" -let pbigarraydim = "Pbigarraydim" -let pbigarrayref = "Pbigarrayref" -let pbigarrayset = "Pbigarrayset" -let pbigstring_load_16 = "Pbigstring_load_16" -let pbigstring_load_32 = "Pbigstring_load_32" -let pbigstring_load_64 = "Pbigstring_load_64" -let pbigstring_load_128 = "Pbigstring_load_128" -let pbigstring_set_16 = "Pbigstring_set_16" -let pbigstring_set_32 = "Pbigstring_set_32" -let pbigstring_set_64 = "Pbigstring_set_64" -let pbigstring_set_128 = "Pbigstring_set_128" -let pbintcomp = "Pbintcomp" -let pbintofint = "Pbintofint" -let pbswap16 = "Pbswap16" -let pbytes_of_string = "Pbytes_of_string" -let pbytes_load_16 = "Pbytes_load_16" -let pbytes_load_32 = "Pbytes_load_32" -let pbytes_load_64 = "Pbytes_load_64" -let pbytes_load_128 = "Pbytes_load_128" -let pbytes_set_16 = "Pbytes_set_16" -let pbytes_set_32 = "Pbytes_set_32" -let pbytes_set_64 = "Pbytes_set_64" -let pbytes_set_128 = "Pbytes_set_128" -let pbytes_to_string = "Pbytes_to_string" -let pbyteslength = "Pbyteslength" -let pbytesrefs = "Pbytesrefs" -let pbytesrefu = "Pbytesrefu" -let pbytessets = "Pbytessets" -let pbytessetu = "Pbytessetu" -let pccall = "Pccall" -let pctconst = "Pctconst" -let pcvtbint = "Pcvtbint" -let pdivbint = "Pdivbint" -let pdivfloat = "Pdivfloat" -let pdivint = "Pdivint" -let pduparray = "Pduparray" -let pduprecord = "Pduprecord" -let pfield = "Pfield" -let pfield_computed = "Pfield_computed" -let pfloatcomp = "Pfloatcomp" -let punboxed_float_comp = "Punboxed_float_comp" -let pfloatfield = "Pfloatfield" -let pufloatfield = "Pufloatfield" -let pfloatofint = "Pfloatofint" -let pgetglobal = "Pgetglobal" -let pgetpredef = "Pgetpredef" -let pignore = "Pignore" -let pint_as_pointer = "Pint_as_pointer" -let pintcomp = "Pintcomp" -let pcompare_ints = "Pcompare_ints" -let pcompare_floats = "Pcompare_floats" -let pcompare_bints = "Pcompare_bints" -let pobj_dup = "Pobj_dup" -let pobj_magic = "Pobj_magic" -let pintofbint = "Pintofbint" -let pintoffloat = "Pintoffloat" -let pisint = "Pisint" -let pisout = "Pisout" -let plslbint = "Plslbint" -let plslint = "Plslint" -let plsrbint = "Plsrbint" -let plsrint = "Plsrint" -let pmakearray = "Pmakearray" -let pmakeblock = "Pmakeblock" -let pmakefloatblock = "Pmakefloatblock" -let pmakeufloatblock = "Pmakeufloatblock" -let pmodbint = "Pmodbint" -let pmodint = "Pmodint" -let pmulbint = "Pmulbint" -let pmulfloat = "Pmulfloat" -let pmulint = "Pmulint" -let pnegbint = "Pnegbint" -let pnegfloat = "Pnegfloat" -let pnegint = "Pnegint" -let pnot = "Pnot" -let poffsetint = "Poffsetint" -let poffsetref = "Poffsetref" -let pointer = "pointer" -let popaque = "Popaque" -let porbint = "Porbint" -let porint = "Porint" -let praise = "Praise" -let predef_exn = "predef_exn" -let project_closure = "project_closure" -let psequand = "Psequand" -let psequor = "Psequor" -let psetfield = "Psetfield" -let psetfield_computed = "Psetfield_computed" -let psetfloatfield = "Psetfloatfield" -let psetufloatfield = "Psetufloatfield" -let psetglobal = "Psetglobal" -let pstring_load_16 = "Pstring_load_16" -let pstring_load_32 = "Pstring_load_32" -let pstring_load_64 = "Pstring_load_64" -let pstring_load_128 = "Pstring_load_128" -let pstringlength = "Pstringlength" -let pstringrefs = "Pstringrefs" -let pstringrefu = "Pstringrefu" -let psubbint = "Psubbint" -let psubfloat = "Psubfloat" -let psubint = "Psubint" -let pxorbint = "Pxorbint" -let pxorint = "Pxorint" -let pprobe_is_enabled = "Pprobe_is_enabled" -let parray_of_iarray = "Parray_of_iarray" -let parray_to_iarray = "Parray_to_iarray" -let pget_header = "Pget_header" -let patomic_cas = "Patomic_cas" -let patomic_exchange = "Patomic_exchange" -let patomic_fetch_add = "Patomic_fetch_add" -let patomic_load = "Patomic_load" -let prunstack = "Prunstack" -let pperform = "Pperform" -let presume = "Presume" -let preperform = "Preperform" -let pdls_get = "Pdls_get" - -let pabsfloat_arg = "Pabsfloat_arg" -let paddbint_arg = "Paddbint_arg" -let paddfloat_arg = "Paddfloat_arg" -let paddint_arg = "Paddint_arg" -let pandbint_arg = "Pandbint_arg" -let pandint_arg = "Pandint_arg" -let parraylength_arg = "Parraylength_arg" -let parrayrefs_arg = "Parrayrefs_arg" -let parrayrefu_arg = "Parrayrefu_arg" -let parraysets_arg = "Parraysets_arg" -let parraysetu_arg = "Parraysetu_arg" -let partial_fun = "partial_fun" -let pasrbint_arg = "Pasrbint_arg" -let pasrint_arg = "Pasrint_arg" -let pbbswap_arg = "Pbbswap_arg" -let pbigarraydim_arg = "Pbigarraydim_arg" -let pbigarrayref_arg = "Pbigarrayref_arg" -let pbigarrayset_arg = "Pbigarrayset_arg" -let pbigstring_load_16_arg = "Pbigstring_load_16_arg" -let pbigstring_load_32_arg = "Pbigstring_load_32_arg" -let pbigstring_load_64_arg = "Pbigstring_load_64_arg" -let pbigstring_load_128_arg = "Pbigstring_load_128_arg" -let pbigstring_set_16_arg = "Pbigstring_set_16_arg" -let pbigstring_set_32_arg = "Pbigstring_set_32_arg" -let pbigstring_set_64_arg = "Pbigstring_set_64_arg" -let pbigstring_set_128_arg = "Pbigstring_set_128_arg" -let pbintcomp_arg = "Pbintcomp_arg" -let pbintofint_arg = "Pbintofint_arg" -let pbswap16_arg = "Pbswap16_arg" -let pbytes_of_string_arg = "Pbytes_of_string_arg" -let pbytes_to_string_arg = "Pbytes_to_string_arg" -let pbyteslength_arg = "Pbyteslength_arg" -let pbytesrefs_arg = "Pbytesrefs_arg" -let pbytesrefu_arg = "Pbytesrefu_arg" -let pbytessets_arg = "Pbytessets_arg" -let pbytessetu_arg = "Pbytessetu_arg" -let pccall_arg = "Pccall_arg" -let pctconst_arg = "Pctconst_arg" -let pcvtbint_arg = "Pcvtbint_arg" -let pdivbint_arg = "Pdivbint_arg" -let pdivfloat_arg = "Pdivfloat_arg" -let pdivint_arg = "Pdivint_arg" -let pduparray_arg = "Pduparray_arg" -let pduprecord_arg = "Pduprecord_arg" -let pfield_arg = "Pfield_arg" -let pfield_computed_arg = "Pfield_computed_arg" -let pfloatcomp_arg = "Pfloatcomp_arg" -let punboxed_float_comp_arg = "Punboxed_float_comp_arg" -let pfloatfield_arg = "Pfloatfield_arg" -let pufloatfield_arg = "Pufloatfield_arg" -let pfloatofint_arg = "Pfloatofint_arg" -let pgetglobal_arg = "Pgetglobal_arg" -let pgetpredef_arg = "Pgetpredef_arg" -let pobj_dup_arg = "Pobj_dup_arg" -let pobj_magic_arg = "Pobj_magic_arg" -let pignore_arg = "Pignore_arg" -let pint_as_pointer_arg = "Pint_as_pointer_arg" -let pintcomp_arg = "Pintcomp_arg" -let pcompare_ints_arg = "Pcompare_ints_arg" -let pcompare_floats_arg = "Pcompare_floats_arg" -let pcompare_bints_arg = "Pcompare_bints_arg" -let pintofbint_arg = "Pintofbint_arg" -let pintoffloat_arg = "Pintoffloat_arg" -let pisint_arg = "Pisint_arg" -let pisout_arg = "Pisout_arg" -let plslbint_arg = "Plslbint_arg" -let plslint_arg = "Plslint_arg" -let plsrbint_arg = "Plsrbint_arg" -let plsrint_arg = "Plsrint_arg" -let pmakearray_arg = "Pmakearray_arg" -let pmakeblock_arg = "Pmakeblock_arg" -let pmakefloatblock_arg = "Pmakefloatblock_arg" -let pmakeufloatblock_arg = "Pmakeufloatblock_arg" -let pmodbint_arg = "Pmodbint_arg" -let pmodint_arg = "Pmodint_arg" -let pmulbint_arg = "Pmulbint_arg" -let pmulfloat_arg = "Pmulfloat_arg" -let pmulint_arg = "Pmulint_arg" -let pnegbint_arg = "Pnegbint_arg" -let pnegfloat_arg = "Pnegfloat_arg" -let pnegint_arg = "Pnegint_arg" -let pnot_arg = "Pnot_arg" -let poffsetint_arg = "Poffsetint_arg" -let poffsetref_arg = "Poffsetref_arg" -let popaque_arg = "Popaque_arg" -let porbint_arg = "Porbint_arg" -let porint_arg = "Porint_arg" -let praise_arg = "Praise_arg" -let psequand_arg = "Psequand_arg" -let psequor_arg = "Psequor_arg" -let psetfield_arg = "Psetfield_arg" -let psetfield_computed_arg = "Psetfield_computed_arg" -let psetfloatfield_arg = "Psetfloatfield_arg" -let psetufloatfield_arg = "Psetufloatfield_arg" -let psetglobal_arg = "Psetglobal_arg" -let pstring_load_16_arg = "Pstring_load_16_arg" -let pstring_load_32_arg = "Pstring_load_32_arg" -let pstring_load_64_arg = "Pstring_load_64_arg" -let pstring_load_128_arg = "Pstring_load_128_arg" -let pbytes_load_16_arg = "Pbytes_load_16_arg" -let pbytes_load_32_arg = "Pbytes_load_32_arg" -let pbytes_load_64_arg = "Pbytes_load_64_arg" -let pbytes_load_128_arg = "Pbytes_load_128_arg" -let pbytes_set_16_arg = "Pbytes_set_16_arg" -let pbytes_set_32_arg = "Pbytes_set_32_arg" -let pbytes_set_64_arg = "Pbytes_set_64_arg" -let pbytes_set_128_arg = "Pbytes_set_128_arg" -let pstringlength_arg = "Pstringlength_arg" -let pstringrefs_arg = "Pstringrefs_arg" -let pstringrefu_arg = "Pstringrefu_arg" -let psubbint_arg = "Psubbint_arg" -let psubfloat_arg = "Psubfloat_arg" -let psubint_arg = "Psubint_arg" -let pxorbint_arg = "Pxorbint_arg" -let pxorint_arg = "Pxorint_arg" -let pprobe_is_enabled_arg = "Pprobe_is_enabled_arg" -let parray_of_iarray_arg = "Parray_of_iarray_arg" -let parray_to_iarray_arg = "Parray_to_iarray_arg" -let pget_header_arg = "Pget_header_arg" -let patomic_cas_arg = "Patomic_cas_arg" -let patomic_exchange_arg = "Patomic_exchange_arg" -let patomic_fetch_add_arg = "Patomic_fetch_add_arg" -let patomic_load_arg = "Patomic_load_arg" -let prunstack_arg = "Prunstack_arg" -let pperform_arg = "Pperform_arg" -let presume_arg = "Presume_arg" -let preperform_arg = "Preperform_arg" -let pdls_get_arg = "Pdls_get_arg" - -let raise = "raise" -let raise_arg = "raise_arg" -let read_mutable = "read_mutable" -let remove_unused_arguments = "remove_unused_arguments" -let result = "result" -let send_arg = "send_arg" -let sequence = "sequence" -let set_of_closures = "set_of_closures" -let simplify_fv = "simplify_fv" -let staticraise_arg = "staticraise_arg" -let string_switch = "string_switch" -let switch = "switch" -let symbol = "symbol" -let symbol_field = "symbol_field" -let symbol_field_block = "symbol_field_block" -let symbol_field_closure = "symbol_field_closure" -let the_dead_constant = "the_dead_constant" -let toplevel_substitution_named = "toplevel_substitution_named" -let unbox_free_vars_of_closures = "unbox_free_vars_of_closures" -let unit = "unit" -let zero = "zero" -let probe_handler = "probe_handler" -let punbox_float = "Punbox_float" -let pbox_float = "Pbox_float" -let punbox_float_arg = "Punbox_float_arg" -let pbox_float_arg = "Pbox_float_arg" -let punbox_int = "Punbox_int" -let pbox_int = "Pbox_int" -let punbox_int_arg = "Punbox_int_arg" -let pbox_int_arg = "Pbox_int_arg" -let pmake_unboxed_product = "Pmake_unboxed_product" -let punboxed_product_field = "Punboxed_product_field" -let pmake_unboxed_product_arg = "Pmake_unboxed_product_arg" -let punboxed_product_field_arg = "Punboxed_product_field_arg" - -let anon_fn_with_loc (sloc: Lambda.scoped_location) = - let loc = Debuginfo.Scoped_location.to_location sloc in - let (file, line, startchar) = Location.get_pos_info loc.loc_start in - let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_bol in - let pp_chars ppf = - if startchar >= 0 then Format.fprintf ppf ",%i--%i" startchar endchar in - if loc.Location.loc_ghost then "anon_fn" - else - Format.asprintf "anon_fn[%s:%i%t]" - (Filename.basename file) line pp_chars - -let of_primitive : Lambda.primitive -> string = function - | Pbytes_of_string -> pbytes_of_string - | Pbytes_to_string -> pbytes_to_string - | Pignore -> pignore - | Pgetglobal _ -> pgetglobal - | Psetglobal _ -> psetglobal - | Pgetpredef _ -> pgetpredef - | Pmakeblock _ -> pmakeblock - | Pmakefloatblock _ -> pmakefloatblock - | Pmakeufloatblock _ -> pmakeufloatblock - | Pfield _ -> pfield - | Pfield_computed _ -> pfield_computed - | Psetfield _ -> psetfield - | Psetfield_computed _ -> psetfield_computed - | Pfloatfield _ -> pfloatfield - | Psetfloatfield _ -> psetfloatfield - | Pufloatfield _ -> pufloatfield - | Psetufloatfield _ -> psetufloatfield - | Pduprecord _ -> pduprecord - | Pccall _ -> pccall - | Praise _ -> praise - | Psequand -> psequand - | Psequor -> psequor - | Pnot -> pnot - | Pnegint -> pnegint - | Paddint -> paddint - | Psubint -> psubint - | Pmulint -> pmulint - | Pdivint _ -> pdivint - | Pmodint _ -> pmodint - | Pandint -> pandint - | Porint -> porint - | Pxorint -> pxorint - | Plslint -> plslint - | Plsrint -> plsrint - | Pasrint -> pasrint - | Pintcomp _ -> pintcomp - | Pcompare_ints -> pcompare_ints - | Pcompare_floats -> pcompare_floats - | Pcompare_bints _ -> pcompare_bints - | Poffsetint _ -> poffsetint - | Poffsetref _ -> poffsetref - | Pintoffloat -> pintoffloat - | Pfloatofint _ -> pfloatofint - | Pnegfloat _ -> pnegfloat - | Pabsfloat _ -> pabsfloat - | Paddfloat _ -> paddfloat - | Psubfloat _ -> psubfloat - | Pmulfloat _ -> pmulfloat - | Pdivfloat _ -> pdivfloat - | Pfloatcomp _ -> pfloatcomp - | Punboxed_float_comp _ -> punboxed_float_comp - | Pstringlength -> pstringlength - | Pstringrefu -> pstringrefu - | Pstringrefs -> pstringrefs - | Pbyteslength -> pbyteslength - | Pbytesrefu -> pbytesrefu - | Pbytessetu -> pbytessetu - | Pbytesrefs -> pbytesrefs - | Pbytessets -> pbytessets - | Parraylength _ -> parraylength - | Pmakearray _ -> pmakearray - | Pduparray _ -> pduparray - | Parrayrefu _ -> parrayrefu - | Parraysetu _ -> parraysetu - | Parrayrefs _ -> parrayrefs - | Parraysets _ -> parraysets - | Pctconst _ -> pctconst - | Pisint _ -> pisint - | Pisout -> pisout - | Pbintofint _ -> pbintofint - | Pintofbint _ -> pintofbint - | Pcvtbint _ -> pcvtbint - | Pnegbint _ -> pnegbint - | Paddbint _ -> paddbint - | Psubbint _ -> psubbint - | Pmulbint _ -> pmulbint - | Pdivbint _ -> pdivbint - | Pmodbint _ -> pmodbint - | Pandbint _ -> pandbint - | Porbint _ -> porbint - | Pxorbint _ -> pxorbint - | Plslbint _ -> plslbint - | Plsrbint _ -> plsrbint - | Pasrbint _ -> pasrbint - | Pbintcomp _ -> pbintcomp - | Pbigarrayref _ -> pbigarrayref - | Pbigarrayset _ -> pbigarrayset - | Pbigarraydim _ -> pbigarraydim - | Pstring_load_16 _ -> pstring_load_16 - | Pstring_load_32 _ -> pstring_load_32 - | Pstring_load_64 _ -> pstring_load_64 - | Pstring_load_128 _ -> pstring_load_128 - | Pbytes_load_16 _ -> pbytes_load_16 - | Pbytes_load_32 _ -> pbytes_load_32 - | Pbytes_load_64 _ -> pbytes_load_64 - | Pbytes_load_128 _ -> pbytes_load_128 - | Pbytes_set_16 _ -> pbytes_set_16 - | Pbytes_set_32 _ -> pbytes_set_32 - | Pbytes_set_64 _ -> pbytes_set_64 - | Pbytes_set_128 _ -> pbytes_set_128 - | Pbigstring_load_16 _ -> pbigstring_load_16 - | Pbigstring_load_32 _ -> pbigstring_load_32 - | Pbigstring_load_64 _ -> pbigstring_load_64 - | Pbigstring_load_128 _ -> pbigstring_load_128 - | Pbigstring_set_16 _ -> pbigstring_set_16 - | Pbigstring_set_32 _ -> pbigstring_set_32 - | Pbigstring_set_64 _ -> pbigstring_set_64 - | Pbigstring_set_128 _ -> pbigstring_set_128 - | Pbswap16 -> pbswap16 - | Pbbswap _ -> pbbswap - | Pint_as_pointer _ -> pint_as_pointer - | Popaque _ -> popaque - | Pprobe_is_enabled _ -> pprobe_is_enabled - | Pobj_dup -> pobj_dup - | Pobj_magic _ -> pobj_magic - | Punbox_float -> punbox_float - | Pbox_float _ -> pbox_float - | Punbox_int _ -> punbox_int - | Pbox_int _ -> pbox_int - | Pmake_unboxed_product _ -> pmake_unboxed_product - | Punboxed_product_field _ -> punboxed_product_field - | Parray_of_iarray -> parray_of_iarray - | Parray_to_iarray -> parray_to_iarray - | Pget_header _ -> pget_header - | Patomic_cas -> patomic_cas - | Patomic_exchange -> patomic_exchange - | Patomic_fetch_add -> patomic_fetch_add - | Patomic_load _ -> patomic_load - | Prunstack -> prunstack - | Pperform -> pperform - | Presume -> presume - | Preperform -> preperform - | Pdls_get -> pdls_get - -let of_primitive_arg : Lambda.primitive -> string = function - | Pbytes_of_string -> pbytes_of_string_arg - | Pbytes_to_string -> pbytes_to_string_arg - | Pignore -> pignore_arg - | Pgetglobal _ -> pgetglobal_arg - | Psetglobal _ -> psetglobal_arg - | Pgetpredef _ -> pgetpredef_arg - | Pmakeblock _ -> pmakeblock_arg - | Pmakefloatblock _ -> pmakefloatblock_arg - | Pmakeufloatblock _ -> pmakeufloatblock_arg - | Pfield _ -> pfield_arg - | Pfield_computed _ -> pfield_computed_arg - | Psetfield _ -> psetfield_arg - | Psetfield_computed _ -> psetfield_computed_arg - | Pfloatfield _ -> pfloatfield_arg - | Psetfloatfield _ -> psetfloatfield_arg - | Pufloatfield _ -> pufloatfield_arg - | Psetufloatfield _ -> psetufloatfield_arg - | Pduprecord _ -> pduprecord_arg - | Pccall _ -> pccall_arg - | Praise _ -> praise_arg - | Psequand -> psequand_arg - | Psequor -> psequor_arg - | Pnot -> pnot_arg - | Pnegint -> pnegint_arg - | Paddint -> paddint_arg - | Psubint -> psubint_arg - | Pmulint -> pmulint_arg - | Pdivint _ -> pdivint_arg - | Pmodint _ -> pmodint_arg - | Pandint -> pandint_arg - | Porint -> porint_arg - | Pxorint -> pxorint_arg - | Plslint -> plslint_arg - | Plsrint -> plsrint_arg - | Pasrint -> pasrint_arg - | Pintcomp _ -> pintcomp_arg - | Pcompare_ints -> pcompare_ints_arg - | Pcompare_floats -> pcompare_floats_arg - | Pcompare_bints _ -> pcompare_bints_arg - | Poffsetint _ -> poffsetint_arg - | Poffsetref _ -> poffsetref_arg - | Pintoffloat -> pintoffloat_arg - | Pfloatofint _ -> pfloatofint_arg - | Pnegfloat _ -> pnegfloat_arg - | Pabsfloat _ -> pabsfloat_arg - | Paddfloat _ -> paddfloat_arg - | Psubfloat _ -> psubfloat_arg - | Pmulfloat _ -> pmulfloat_arg - | Pdivfloat _ -> pdivfloat_arg - | Pfloatcomp _ -> pfloatcomp_arg - | Punboxed_float_comp _ -> punboxed_float_comp_arg - | Pstringlength -> pstringlength_arg - | Pstringrefu -> pstringrefu_arg - | Pstringrefs -> pstringrefs_arg - | Pbyteslength -> pbyteslength_arg - | Pbytesrefu -> pbytesrefu_arg - | Pbytessetu -> pbytessetu_arg - | Pbytesrefs -> pbytesrefs_arg - | Pbytessets -> pbytessets_arg - | Parraylength _ -> parraylength_arg - | Pmakearray _ -> pmakearray_arg - | Pduparray _ -> pduparray_arg - | Parrayrefu _ -> parrayrefu_arg - | Parraysetu _ -> parraysetu_arg - | Parrayrefs _ -> parrayrefs_arg - | Parraysets _ -> parraysets_arg - | Pctconst _ -> pctconst_arg - | Pisint _ -> pisint_arg - | Pisout -> pisout_arg - | Pbintofint _ -> pbintofint_arg - | Pintofbint _ -> pintofbint_arg - | Pcvtbint _ -> pcvtbint_arg - | Pnegbint _ -> pnegbint_arg - | Paddbint _ -> paddbint_arg - | Psubbint _ -> psubbint_arg - | Pmulbint _ -> pmulbint_arg - | Pdivbint _ -> pdivbint_arg - | Pmodbint _ -> pmodbint_arg - | Pandbint _ -> pandbint_arg - | Porbint _ -> porbint_arg - | Pxorbint _ -> pxorbint_arg - | Plslbint _ -> plslbint_arg - | Plsrbint _ -> plsrbint_arg - | Pasrbint _ -> pasrbint_arg - | Pbintcomp _ -> pbintcomp_arg - | Pbigarrayref _ -> pbigarrayref_arg - | Pbigarrayset _ -> pbigarrayset_arg - | Pbigarraydim _ -> pbigarraydim_arg - | Pstring_load_16 _ -> pstring_load_16_arg - | Pstring_load_32 _ -> pstring_load_32_arg - | Pstring_load_64 _ -> pstring_load_64_arg - | Pstring_load_128 _ -> pstring_load_128_arg - | Pbytes_load_16 _ -> pbytes_load_16_arg - | Pbytes_load_32 _ -> pbytes_load_32_arg - | Pbytes_load_64 _ -> pbytes_load_64_arg - | Pbytes_load_128 _ -> pbytes_load_128_arg - | Pbytes_set_16 _ -> pbytes_set_16_arg - | Pbytes_set_32 _ -> pbytes_set_32_arg - | Pbytes_set_64 _ -> pbytes_set_64_arg - | Pbytes_set_128 _ -> pbytes_set_128_arg - | Pbigstring_load_16 _ -> pbigstring_load_16_arg - | Pbigstring_load_32 _ -> pbigstring_load_32_arg - | Pbigstring_load_64 _ -> pbigstring_load_64_arg - | Pbigstring_load_128 _ -> pbigstring_load_128_arg - | Pbigstring_set_16 _ -> pbigstring_set_16_arg - | Pbigstring_set_32 _ -> pbigstring_set_32_arg - | Pbigstring_set_64 _ -> pbigstring_set_64_arg - | Pbigstring_set_128 _ -> pbigstring_set_128_arg - | Pbswap16 -> pbswap16_arg - | Pbbswap _ -> pbbswap_arg - | Pint_as_pointer _ -> pint_as_pointer_arg - | Popaque _ -> popaque_arg - | Pprobe_is_enabled _ -> pprobe_is_enabled_arg - | Pobj_dup -> pobj_dup_arg - | Pobj_magic _ -> pobj_magic_arg - | Punbox_float -> punbox_float_arg - | Pbox_float _ -> pbox_float_arg - | Punbox_int _ -> punbox_int_arg - | Pbox_int _ -> pbox_int_arg - | Pmake_unboxed_product _ -> pmake_unboxed_product_arg - | Punboxed_product_field _ -> punboxed_product_field_arg - | Parray_of_iarray -> parray_of_iarray_arg - | Parray_to_iarray -> parray_to_iarray_arg - | Pget_header _ -> pget_header_arg - | Patomic_cas -> patomic_cas_arg - | Patomic_exchange -> patomic_exchange_arg - | Patomic_fetch_add -> patomic_fetch_add_arg - | Patomic_load _ -> patomic_load_arg - | Prunstack -> prunstack_arg - | Pperform -> pperform_arg - | Presume -> presume_arg - | Preperform -> preperform_arg - | Pdls_get -> pdls_get_arg diff --git a/middle_end/internal_variable_names.mli b/middle_end/internal_variable_names.mli deleted file mode 100644 index d2a80ac0c97..00000000000 --- a/middle_end/internal_variable_names.mli +++ /dev/null @@ -1,104 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fu Yong Quah, Jane Street Europe *) -(* *) -(* Copyright 2017 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"] - -type t = private string - -val apply_arg : t -val apply_funct : t -val block_symbol : t -val block_symbol_get : t -val block_symbol_get_field : t -val boxed_in_closure : t -val boxing_closure : t -val boxing_closure_field : t -val boxing_set_of_closures : t -val closure : t -val cond : t -val cond_sequor : t -val const_block : t -val const_bool : t -val const_boxed_int : t -val const_char : t -val const_false : t -val const_float : t -val const_int : t -val const_one : t -val const_ptr : t -val const_ptr_one : t -val const_ptr_zero : t -val const_sequand : t -val const_string : t -val const_true : t -val const_zero : t -val denominator : t -val division_by_zero : t -val dummy : t -val dup_func : t -val dup_set_of_closures : t -val const_float_array : t -val fake_effect_symbol : t -val for_from : t -val for_to : t -val from_closure : t -val full_apply : t -val get_symbol_field : t -val const_immstring : t -val const_int32 : t -val const_int64 : t -val ignore : t -val is_zero : t -val lifted_let_rec_block : t -val meth : t -val module_as_block : t -val const_nativeint : t -val new_value : t -val numerator : t -val obj : t -val offsetted : t -val partial_fun : t -val pgetglobal : t -val pointer : t -val predef_exn : t -val project_closure : t -val raise : t -val raise_arg : t -val read_mutable : t -val remove_unused_arguments : t -val result : t -val send_arg : t -val sequence : t -val set_of_closures : t -val staticraise_arg : t -val simplify_fv : t -val string_switch : t -val switch : t -val symbol : t -val symbol_field : t -val symbol_field_block : t -val symbol_field_closure : t -val the_dead_constant : t -val toplevel_substitution_named : t -val unbox_free_vars_of_closures : t -val unit : t -val zero : t - -val of_primitive : Lambda.primitive -> t - -val of_primitive_arg : Lambda.primitive -> t - -val anon_fn_with_loc : Lambda.scoped_location -> t -val probe_handler : t - diff --git a/middle_end/mangling.ml b/middle_end/mangling.ml deleted file mode 100644 index f93e19eff8e..00000000000 --- a/middle_end/mangling.ml +++ /dev/null @@ -1,228 +0,0 @@ -(* The MIT License - * - * Copyright (c) 2021--2022 Jane Street Group, LLC opensource@janestreet.com - * - * 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. - *) - -[@@@ocaml.warning "-69"] - -module String = Misc.Stdlib.String - -let escape_symbols part = - let buf = Buffer.create 16 in - let was_hex_last = ref false in - let handle_char = function - | ('A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_') as c -> - if !was_hex_last then Buffer.add_string buf "__"; - Buffer.add_char buf c; - was_hex_last := false - | c -> - Printf.bprintf buf "%sX%02x" - (if !was_hex_last then "_" else "__") - (Char.code c); - was_hex_last := true - in - String.iter handle_char part; - Buffer.contents buf - -type expression = - | String of string - | Dot of expression * string - -type cpp_name = - | Simple of string - | Scoped of cpp_name list - | Templated of string * template_arg list - -and template_arg = - | Cpp_name of cpp_name - | Expression of expression - -let mangle_cpp name = - let with_length s = - let s = escape_symbols s in - Printf.sprintf "%d%s" (String.length s) s - in - let rec mangle_expression = function - | String s -> with_length s - | Dot (e, name) -> - Printf.sprintf "dt%s%s" (mangle_expression e) (with_length name) - in - let rec mangle_name = function - | Simple s -> with_length s - | Scoped names -> - let s = List.map mangle_name names |> String.concat "" in - Printf.sprintf "N%sE" s - | Templated (str, parts) -> - let s = List.map mangle_arg parts |> String.concat "" in - Printf.sprintf "%sI%sE" (with_length str) s - and mangle_arg = function - | Cpp_name name -> mangle_name name - | Expression expression -> - Printf.sprintf "X%sE" (mangle_expression expression) - in - "_Z" ^ mangle_name name - -let file_template_arg file = - (* Take the base name only *) - let filename = Filename.basename file in - match String.split_on_char '.' filename with - | [] -> Misc.fatal_error "Empty split" - | hd :: tl -> - let expr = List.fold_left (fun e x -> Dot (e, x)) (String hd) tl in - Expression expr - -let name_op = function - | "+" -> "PLUS" - | "++" -> "PLUSPLUS" - | "+." -> "PLUSDOT" - | "+=" -> "PLUSEQ" - | "-" -> "MINUS" - | "-." -> "MINUSDOT" - | "*" -> "STAR" - | "%" -> "PERCENT" - | "=" -> "EQUAL" - | "<" -> "LESS" - | ">" -> "GREATER" - | "<>" -> "NOTEQUAL" - | "||" -> "BARBAR" - | "&" -> "AMPERSAND" - | "&&" -> "AMPERAMPER" - | ":=" -> "COLONEQUAL" - | "^" -> "CARET" - | "^^" -> "CARETCARET" - | "@" -> "AT" - | "<<" -> "LSHIFT" - | ">>" -> "RSHIFT" - | op -> op - -let build_location_info loc = - let loc = Debuginfo.Scoped_location.to_location loc in - let file, line, startchar = Location.get_pos_info loc.loc_start in - let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_bol in - let line_str = Printf.sprintf "ln_%d" line in - let info = [file_template_arg file; Cpp_name (Simple line_str)] in - if startchar >= 0 - then - let char_str = Printf.sprintf "ch_%d_to_%d" startchar endchar in - info @ [Cpp_name (Simple char_str)] - else info - -(* OCaml names can contain single quotes but need to be escaped for C++ - identifiers. *) -let convert_identifier str = - match String.split_on_char '\'' str with - | [] -> Misc.fatal_error "empty split" - | [s] -> Simple s - | parts -> - let s = String.concat "_Q" parts in - Templated (s, [Cpp_name (Simple "quoted")]) - -let convert_closure_id id loc = - if String.begins_with id ~prefix:"anon_fn[" - then - (* Keep the unique integer stamp *) - let _init, stamp = String.split_last_exn id ~split_on:'_' in - (* Put the location inside C++ template args *) - Templated ("anon_fn_" ^ stamp, build_location_info loc) - else - match id.[0] with - (* A regular identifier *) - | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' -> convert_identifier id - (* An operator *) - | _op -> - let op, stamp = String.split_last_exn id ~split_on:'_' in - Templated ("op_" ^ stamp, [Cpp_name (Simple (name_op op))]) - -let convert_scope scope = - let n = String.length scope in - (* anonymous function *) - if String.equal scope "(fun)" - then Templated ("anon_fn", []) (* operators *) - else if n > 2 && String.get scope 0 = '(' && String.get scope (n - 1) = ')' - then - let op = String.sub scope 1 (n - 2) in - Templated ("op", [Cpp_name (Simple (name_op op))]) - (* regular identifiers *) - else convert_identifier scope - -let list_of_scopes scopes = - (* Works for now since the only separators are '.' and '#' *) - let scope_str = Debuginfo.Scoped_location.string_of_scopes scopes in - String.split_on_chars scope_str ~split_on:['.'; '#'] - -let scope_matches_closure_id scope closure_id = - (* If the `id` is an anonymous function this corresponds to that, and, even if - not, then the function has likely been given a name via some aliasing (e.g. - `let f = fun x -> ...`) *) - String.equal scope "(fun)" - (* Normal case where closure id and scope match directly *) - || String.begins_with closure_id ~prefix:scope - || (* For operators, the scope is wrapped in parens *) - String.length scope >= 3 - && String.begins_with closure_id - ~prefix:(String.sub scope 1 (String.length scope - 2)) - -(* Returns a pair of the top-level module and the list of scopes that strictly - contain the closure id *) -let module_and_scopes ~unitname loc id = - match (loc : Debuginfo.Scoped_location.t) with - | Loc_known { loc = _; scopes } -> ( - let scopes = list_of_scopes scopes in - (* Remove last scope if it matches closure id *) - let scopes = - match List.rev scopes with - | [] -> Misc.fatal_errorf "No location - %s %s" unitname id - | last_scope :: rest when scope_matches_closure_id last_scope id -> - List.rev rest - | _ -> scopes - in - (* If the scope is now empty, use the unitname as the top-level module *) - match scopes with - | [] -> unitname, [] - | top_module :: sub_scopes -> top_module, sub_scopes) - | Loc_unknown -> unitname, [] - -let remove_prefix ~prefix str = - let n = String.length prefix in - if String.begins_with str ~prefix - then String.sub str n (String.length str - n) - else str - -let fun_symbol ~unitname ~loc ~id = - let unitname = remove_prefix ~prefix:"caml" unitname in - let top_level_module, sub_scopes = module_and_scopes ~unitname loc id in - let namespace_parts name = - String.split_on_string name ~split_on:"__" - |> List.map (fun part -> Simple part) - in - let parts = - List.concat - [ namespace_parts top_level_module; - List.map convert_scope sub_scopes; - [convert_closure_id id loc]; - (if String.equal top_level_module unitname - then [] - else - [ Templated - ("inlined_in", [Cpp_name (Scoped (namespace_parts unitname))]) ]) - ] - in - mangle_cpp (Scoped parts) diff --git a/middle_end/mangling.mli b/middle_end/mangling.mli deleted file mode 100644 index 6b2a677e1ed..00000000000 --- a/middle_end/mangling.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* The MIT License - * - * Copyright (c) 2021--2022 Jane Street Group, LLC opensource@janestreet.com - * - * 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. - *) - -val fun_symbol : - unitname:string -> loc:Debuginfo.Scoped_location.t -> id:string -> string diff --git a/middle_end/printclambda.ml b/middle_end/printclambda.ml deleted file mode 100644 index 792121fa830..00000000000 --- a/middle_end/printclambda.ml +++ /dev/null @@ -1,343 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - - -open Format -open Clambda - -module V = Backend_var -module VP = Backend_var.With_provenance - -let mutable_flag = function - | Lambda.Mutable-> "[mut]" - | Lambda.Immutable | Lambda.Immutable_unique -> "" - -let rec value_kind0 ppf kind = - let open Lambda in - match kind with - | Pgenval -> Format.pp_print_string ppf "" - | Pintval -> Format.pp_print_string ppf ":int" - | Pfloatval -> Format.pp_print_string ppf ":float" - | Parrayval Pgenarray -> Format.pp_print_string ppf ":genarray" - | Parrayval Pintarray -> Format.pp_print_string ppf ":intarray" - | Parrayval Pfloatarray -> Format.pp_print_string ppf ":floatarray" - | Parrayval Paddrarray -> Format.pp_print_string ppf ":addrarray" - | Pboxedintval Pnativeint -> Format.pp_print_string ppf ":nativeint" - | Pboxedintval Pint32 -> Format.pp_print_string ppf ":int32" - | Pboxedintval Pint64 -> Format.pp_print_string ppf ":int64" - | Pboxedvectorval (Pvec128 ty) -> - Format.fprintf ppf ":%s" (vec128_name ty) - | Pvariant { consts; non_consts } -> - Format.fprintf ppf "@[[(consts (%a))@ (non_consts (%a))]@]" - (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_int) - consts - (Format.pp_print_list ~pp_sep:Format.pp_print_space - (fun ppf (tag, fields) -> - fprintf ppf "@[[%d:@ %a]@]" tag - (Format.pp_print_list - ~pp_sep:(fun ppf () -> fprintf ppf ",@ ") - value_kind0) - fields)) - non_consts - -let value_kind kind = Format.asprintf "%a" value_kind0 kind -let layout (layout : Lambda.layout) = - match layout with - | Pvalue kind -> value_kind kind - | Ptop -> ":top" - | Pbottom -> ":bottom" - | Punboxed_float -> ":unboxed_float" - | Punboxed_int Pint32 -> ":unboxed_int32" - | Punboxed_int Pint64 -> ":unboxed_int64" - | Punboxed_int Pnativeint -> ":unboxed_nativeint" - | Punboxed_vector (Pvec128 ty) -> - Format.sprintf ":unboxed_%s" (Lambda.vec128_name ty) - | Punboxed_product layouts -> - Format.asprintf ":unboxed_product(%a)" - (Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ") - Printlambda.layout) layouts - -let rec structured_constant ppf = function - | Uconst_float x -> fprintf ppf "%F" x - | Uconst_int32 x -> fprintf ppf "%ldl" x - | Uconst_int64 x -> fprintf ppf "%LdL" x - | Uconst_nativeint x -> fprintf ppf "%ndn" x - | Uconst_vec128 {high; low} -> fprintf ppf "vec128[%016Lx:%016Lx]" high low - | Uconst_block (tag, l) -> - fprintf ppf "block(%i" tag; - List.iter (fun u -> fprintf ppf ",%a" uconstant u) l; - fprintf ppf ")" - | Uconst_float_array [] -> - fprintf ppf "floatarray()" - | Uconst_float_array (f1 :: fl) -> - fprintf ppf "floatarray(%F" f1; - List.iter (fun f -> fprintf ppf ",%F" f) fl; - fprintf ppf ")" - | Uconst_string s -> fprintf ppf "%S" s - | Uconst_closure(clos, sym, fv) -> - let funs ppf = - List.iter (fprintf ppf "@ %a" one_fun) in - let sconsts ppf scl = - List.iter (fun sc -> fprintf ppf "@ %a" uconstant sc) scl in - fprintf ppf "@[<2>(const_closure%a %s@ %a)@]" funs clos sym sconsts fv - -and one_fun ppf f = - let idents ppf = - let rec iter params layouts = - match params, layouts with - | [], [] -> () - | [param], [] -> - fprintf ppf "@ %a%a" - VP.print param Printlambda.layout Lambda.layout_function - | param :: params, layout :: layouts -> - fprintf ppf "@ %a%a" - VP.print param Printlambda.layout layout; - iter params layouts - | _ -> Misc.fatal_error "arity inconsistent with params" - in - iter f.params f.arity.params_layout - in - fprintf ppf "(fun@ %s%s@ %a@ %d@ @[<2>%t@]@ @[<2>%a@])" - f.label (layout f.arity.return_layout) Printlambda.check_attribute f.check - (List.length f.arity.params_layout) idents lam f.body - -and phantom_defining_expr ppf = function - | Uphantom_const const -> uconstant ppf const - | Uphantom_var var -> Ident.print ppf var - | Uphantom_offset_var { var; offset_in_words; } -> - Format.fprintf ppf "%a+(%d)" Backend_var.print var offset_in_words - | Uphantom_read_field { var; field; } -> - Format.fprintf ppf "%a[%d]" Backend_var.print var field - | Uphantom_read_symbol_field { sym; field; } -> - Format.fprintf ppf "%s[%d]" sym field - | Uphantom_block { tag; fields; } -> - Format.fprintf ppf "[%d: " tag; - List.iter (fun field -> - Format.fprintf ppf "%a; " Backend_var.print field) - fields; - Format.fprintf ppf "]" - -and phantom_defining_expr_opt ppf = function - | None -> Format.fprintf ppf "DEAD" - | Some expr -> phantom_defining_expr ppf expr - -and uconstant ppf = function - | Uconst_ref (s, Some c) -> - fprintf ppf "%S=%a" s structured_constant c - | Uconst_ref (s, None) -> fprintf ppf "%S"s - | Uconst_int i -> fprintf ppf "%i" i - -and apply_kind ppf : apply_kind -> unit = function - | (Rc_normal | Rc_nontail), Alloc_heap -> fprintf ppf "apply" - | Rc_close_at_apply, Alloc_heap -> fprintf ppf "apply[end_region]" - | (Rc_normal | Rc_nontail), Alloc_local -> fprintf ppf "apply[L]" - | Rc_close_at_apply, Alloc_local -> fprintf ppf "apply[end_region][L]" - -and lam ppf = function - | Uvar id -> - V.print ppf id - | Uconst c -> uconstant ppf c - | Udirect_apply(f, largs, probe, _, kind, _) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - let pr ppf (probe : Lambda.probe) = - match probe with - | None -> () - | Some {name} -> fprintf ppf " (probe %s)" name - in - fprintf ppf "@[<2>(%a*@ %s %a%a)@]" apply_kind kind f lams largs pr probe - | Ugeneric_apply(lfun, largs, _, _, kind, _) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(%a@ %a%a)@]" apply_kind kind lam lfun lams largs - | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> - let funs ppf = - List.iter (fprintf ppf "@ @[<2>%a@]" one_fun) in - let lams ppf = - List.iter (fprintf ppf "@ %a" lam) in - fprintf ppf "@[<2>(closure@ %a (%a) %a)@]" funs functions - lams not_scanned_slots lams scanned_slots - | Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i - | Ulet(mut, kind, id, arg, body) -> - let rec letbody ul = match ul with - | Ulet(mut, kind, id, arg, body) -> - fprintf ppf "@ @[<2>%a%s%s@ %a@]" - VP.print id - (mutable_flag mut) (layout kind) lam arg; - letbody body - | _ -> ul in - fprintf ppf "@[<2>(let@ @[(@[<2>%a%s%s@ %a@]" - VP.print id (mutable_flag mut) - (layout kind) lam arg; - let expr = letbody body in - fprintf ppf ")@]@ %a)@]" lam expr - | Uphantom_let (id, defining_expr, body) -> - let rec letbody ul = match ul with - | Uphantom_let (id, defining_expr, body) -> - fprintf ppf "@ @[<2>%a@ %a@]" - Backend_var.With_provenance.print id - phantom_defining_expr_opt defining_expr; - letbody body - | _ -> ul in - fprintf ppf "@[<2>(phantom_let@ @[(@[<2>%a@ %a@]" - Backend_var.With_provenance.print id - phantom_defining_expr_opt defining_expr; - let expr = letbody body in - fprintf ppf ")@]@ %a)@]" lam expr - | Uletrec(id_arg_list, body) -> - let bindings ppf id_arg_list = - let spc = ref false in - List.iter - (fun (id, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<2>%a@ %a@]" - VP.print id - lam l) - id_arg_list in - fprintf ppf - "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body - | Uprim(prim, largs, _) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(%a%a)@]" - Printclambda_primitives.primitive prim lams largs - | Uswitch(larg, sw, _dbg, _kind) -> - let print_case tag index i ppf = - for j = 0 to Array.length index - 1 do - if index.(j) = i then fprintf ppf "case %s %i:" tag j - done in - let print_cases tag index cases ppf = - for i = 0 to Array.length cases - 1 do - fprintf ppf "@ @[<2>%t@ %a@]" - (print_case tag index i) sequence cases.(i) - done in - let switch ppf sw = - print_cases "int" sw.us_index_consts sw.us_actions_consts ppf ; - print_cases "tag" sw.us_index_blocks sw.us_actions_blocks ppf in - fprintf ppf - "@[@[<2>(switch@ %a@ @]%a)@]" - lam larg switch sw - | Ustringswitch(larg,sw,d, _kind) -> - let switch ppf sw = - let spc = ref false in - List.iter - (fun (s,l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case \"%s\":@ %a@]" - (String.escaped s) lam l) - sw ; - begin match d with - | Some d -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam d - | None -> () - end in - fprintf ppf - "@[<1>(switch %a@ @[%a@])@]" - lam larg switch sw - | Ustaticfail (i, ls) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls; - | Ucatch(i, vars, lbody, lhandler, _kind) -> - fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" - lam lbody i - (fun ppf vars -> - List.iter - (fun (x, k) -> - fprintf ppf " %a%a" - VP.print x - Printlambda.layout k - ) - vars - ) - vars - lam lhandler - | Utrywith(lbody, param, lhandler, _kind) -> - fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" - lam lbody VP.print param lam lhandler - | Uifthenelse(lcond, lif, lelse, _kind) -> - fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse - | Usequence(l1, l2) -> - fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 - | Uwhile(lcond, lbody) -> - fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody - | Ufor(param, lo, hi, dir, body) -> - fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" - VP.print param lam lo - (match dir with Upto -> "to" | Downto -> "downto") - lam hi lam body - | Uassign(id, expr) -> - fprintf ppf "@[<2>(assign@ %a@ %a)@]" V.print id lam expr - | Usend (k, met, obj, largs, _, _, (pos,_) , _) -> - let form = - match pos with - | Rc_normal | Rc_nontail -> "send" - | Rc_close_at_apply -> "send[end_region]" - in - let args ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - let kind = - if k = Lambda.Self then "self" - else if k = Lambda.Cached then "cache" - else "" in - fprintf ppf "@[<2>(%s%s@ %a@ %a%a)@]" - form kind lam obj lam met args largs - | Uunreachable -> - fprintf ppf "unreachable" - | Uregion e -> - fprintf ppf "@[<2>(region@ %a)@]" lam e - | Uexclave e -> - fprintf ppf "@[<2>(exclave@ %a)@]" lam e - -and sequence ppf ulam = match ulam with - | Usequence(l1, l2) -> - fprintf ppf "%a@ %a" sequence l1 sequence l2 - | _ -> lam ppf ulam - -let clambda ppf ulam = - fprintf ppf "%a@." lam ulam - - -let rec approx ppf = function - Value_closure(_, fundesc, a) -> - Format.fprintf ppf "@[<2>function %s" - fundesc.fun_label; - let n = List.length fundesc.fun_arity.params_layout in - begin match fundesc.fun_arity.function_kind with - | Tupled -> Format.fprintf ppf "@ arity -%i" n - | Curried {nlocal=0} -> Format.fprintf ppf "@ arity %i" n - | Curried {nlocal=k} -> Format.fprintf ppf "@ arity %i(%i L)" n k - end; - if fundesc.fun_closed then begin - Format.fprintf ppf "@ (closed)" - end; - if fundesc.fun_inline <> None then begin - Format.fprintf ppf "@ (inline)" - end; - Format.fprintf ppf "@ -> @ %a@]" approx a - | Value_tuple (_,a) -> - let tuple ppf a = - for i = 0 to Array.length a - 1 do - if i > 0 then Format.fprintf ppf ";@ "; - Format.fprintf ppf "%i: %a" i approx a.(i) - done in - Format.fprintf ppf "@[(%a)@]" tuple a - | Value_unknown -> - Format.fprintf ppf "_" - | Value_const c -> - fprintf ppf "@[const(%a)@]" uconstant c - | Value_global_field (s, i) -> - fprintf ppf "@[global(%s,%i)@]" s i diff --git a/middle_end/printclambda.mli b/middle_end/printclambda.mli deleted file mode 100644 index 121667e2a40..00000000000 --- a/middle_end/printclambda.mli +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -open Clambda -open Format - -val clambda: formatter -> ulambda -> unit -val approx: formatter -> value_approximation -> unit -val structured_constant: formatter -> ustructured_constant -> unit - -val phantom_defining_expr_opt - : formatter - -> uphantom_defining_expr option - -> unit diff --git a/middle_end/printclambda_primitives.ml b/middle_end/printclambda_primitives.ml deleted file mode 100644 index 1952c12fbf0..00000000000 --- a/middle_end/printclambda_primitives.ml +++ /dev/null @@ -1,321 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - - -open Format - -let boxed_integer_name = function - | Lambda.Pnativeint -> "nativeint" - | Lambda.Pint32 -> "int32" - | Lambda.Pint64 -> "int64" - -let boxed_integer_mark name = function - | Lambda.Pnativeint -> Printf.sprintf "Nativeint.%s" name - | Lambda.Pint32 -> Printf.sprintf "Int32.%s" name - | Lambda.Pint64 -> Printf.sprintf "Int64.%s" name - -let alloc_kind = function - | Lambda.Alloc_heap -> "" - | Lambda.Alloc_local -> "[L]" - -let print_boxed_integer name ppf bi m = - fprintf ppf "%s%s" (boxed_integer_mark name bi) (alloc_kind m) - -let array_kind array_kind = - let open Lambda in - match array_kind with - | Pgenarray -> "gen" - | Paddrarray -> "addr" - | Pintarray -> "int" - | Pfloatarray -> "float" - -let pp_array_ref_kind ppf k = - let open Lambda in - let pp_mode ppf = function - | Alloc_heap -> () - | Alloc_local -> fprintf ppf "(local)" - in - match k with - | Pgenarray_ref mode -> fprintf ppf "gen%a" pp_mode mode - | Paddrarray_ref -> fprintf ppf "addr" - | Pintarray_ref -> fprintf ppf "int" - | Pfloatarray_ref mode -> fprintf ppf "float%a" pp_mode mode - -let pp_array_set_kind ppf k = - let open Lambda in - let pp_mode ppf = function - | Modify_heap -> () - | Modify_maybe_stack -> fprintf ppf "(local)" - in - match k with - | Pgenarray_set mode -> fprintf ppf "gen%a" pp_mode mode - | Paddrarray_set mode -> fprintf ppf "addr%a" pp_mode mode - | Pintarray_set -> fprintf ppf "int" - | Pfloatarray_set -> fprintf ppf "float" - -let access_size size = - let open Clambda_primitives in - match size with - | Sixteen -> "16" - | Thirty_two -> "32" - | Sixty_four -> "64" - | One_twenty_eight { aligned = false } -> "128u" - | One_twenty_eight { aligned = true } -> "128a" - -let access_safety safety = - let open Lambda in - match safety with - | Safe -> "" - | Unsafe -> "unsafe_" - -let primitive ppf (prim:Clambda_primitives.primitive) = - let open Lambda in - let open Clambda_primitives in - match prim with - | Pread_symbol sym -> - fprintf ppf "read_symbol %s" sym - | Pmakeblock(tag, mut, shape, mode) -> - let mode = match mode with - | Alloc_heap -> "" - | Alloc_local -> "local" - in - let mut = match mut with - | Immutable -> "block" - | Immutable_unique -> "block_unique" - | Mutable -> "mutable" - in - let name = "make" ^ mode ^ mut in - fprintf ppf "%s %i%a" name tag Printlambda.block_shape shape - | Pmakeufloatblock(mut, mode) -> - let mode = match mode with - | Alloc_heap -> "" - | Alloc_local -> "local" - in - let mut = match mut with - | Immutable -> "block" - | Immutable_unique -> "block_unique" - | Mutable -> "mutable" - in - let name = "make" ^ mode ^ "ufloat" ^ mut in - fprintf ppf "%s" name - | Pfield (n, layout, ptr, mut) -> - let instr = - match ptr, mut with - | Immediate, _ -> "field_int" - | Pointer, Mutable -> "field_mut" - | Pointer, Immutable -> "field_imm" - | Pointer, Immutable_unique -> "field_imm_unique" - in - fprintf ppf "%s%a %i" instr Printlambda.layout layout n - | Pfield_computed -> fprintf ppf "field_computed" - | Psetfield(n, ptr, init) -> - let instr = - match ptr with - | Pointer -> "ptr" - | Immediate -> "imm" - in - let init = - match init with - | Heap_initialization -> "(heap-init)" - | Root_initialization -> "(root-init)" - | Assignment Modify_heap -> "" - | Assignment Modify_maybe_stack -> "(maybe-stack)" - in - fprintf ppf "setfield_%s%s %i" instr init n - | Psetfield_computed (ptr, init) -> - let instr = - match ptr with - | Pointer -> "ptr" - | Immediate -> "imm" - in - let init = - match init with - | Heap_initialization -> "(heap-init)" - | Root_initialization -> "(root-init)" - | Assignment Modify_heap -> "" - | Assignment Modify_maybe_stack -> "(maybe-stack)" - in - fprintf ppf "setfield_%s%s_computed" instr init - | Pfloatfield (n, Alloc_heap) -> fprintf ppf "floatfield %i" n - | Pfloatfield (n, Alloc_local) -> fprintf ppf "floatfieldlocal %i" n - | Pufloatfield n -> fprintf ppf "ufloatfield %i" n - | Psetfloatfield (n, init) -> - let init = - match init with - | Heap_initialization -> "(heap-init)" - | Root_initialization -> "(root-init)" - | Assignment Modify_heap -> "" - | Assignment Modify_maybe_stack -> "(maybe-stack)" - in - fprintf ppf "setfloatfield%s %i" init n - | Psetufloatfield (n, init) -> - let init = - match init with - | Heap_initialization -> "(heap-init)" - | Root_initialization -> "(root-init)" - | Assignment Modify_heap -> "" - | Assignment Modify_maybe_stack -> "(maybe-stack)" - in - fprintf ppf "setufloatfield%s %i" init n - | Pduprecord (rep, size) -> - fprintf ppf "duprecord %a %i" Printlambda.record_rep rep size - | Prunstack -> fprintf ppf "runstack" - | Pperform -> fprintf ppf "perform" - | Presume -> fprintf ppf "resume" - | Preperform -> fprintf ppf "reperform" - | Pccall p -> fprintf ppf "%s" p.Primitive.prim_name - | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) - | Psequand -> fprintf ppf "&&" - | Psequor -> fprintf ppf "||" - | Pnot -> fprintf ppf "not" - | Pnegint -> fprintf ppf "~" - | Paddint -> fprintf ppf "+" - | Psubint -> fprintf ppf "-" - | Pmulint -> fprintf ppf "*" - | Pdivint Safe -> fprintf ppf "/" - | Pdivint Unsafe -> fprintf ppf "/u" - | Pmodint Safe -> fprintf ppf "mod" - | Pmodint Unsafe -> fprintf ppf "mod_unsafe" - | Pandint -> fprintf ppf "and" - | Porint -> fprintf ppf "or" - | Pxorint -> fprintf ppf "xor" - | Plslint -> fprintf ppf "lsl" - | Plsrint -> fprintf ppf "lsr" - | Pasrint -> fprintf ppf "asr" - | Pintcomp(cmp) -> Printlambda.integer_comparison ppf cmp - | Pcompare_ints -> fprintf ppf "compare_ints" - | Pcompare_floats -> fprintf ppf "compare_floats" - | Pcompare_bints bi -> fprintf ppf "compare_bints %s" (boxed_integer_name bi) - | Poffsetint n -> fprintf ppf "%i+" n - | Poffsetref n -> fprintf ppf "+:=%i"n - | Pintoffloat -> fprintf ppf "int_of_float" - | Pfloatofint m -> fprintf ppf "float_of_int%s" (alloc_kind m) - | Pnegfloat m -> fprintf ppf "~.%s" (alloc_kind m) - | Pabsfloat m -> fprintf ppf "abs.%s" (alloc_kind m) - | Paddfloat m -> fprintf ppf "+.%s" (alloc_kind m) - | Psubfloat m -> fprintf ppf "-.%s" (alloc_kind m) - | Pmulfloat m -> fprintf ppf "*.%s" (alloc_kind m) - | Pdivfloat m -> fprintf ppf "/.%s" (alloc_kind m) - | Pfloatcomp(cmp) -> Printlambda.float_comparison ppf cmp - | Punboxed_float_comp(cmp) -> - fprintf ppf "%a (unboxed)" Printlambda.float_comparison cmp - | Pstringlength -> fprintf ppf "string.length" - | Pstringrefu -> fprintf ppf "string.unsafe_get" - | Pstringrefs -> fprintf ppf "string.get" - | Pbyteslength -> fprintf ppf "bytes.length" - | Pbytesrefu -> fprintf ppf "bytes.unsafe_get" - | Pbytessetu -> fprintf ppf "bytes.unsafe_set" - | Pbytesrefs -> fprintf ppf "bytes.get" - | Pbytessets -> fprintf ppf "bytes.set" - - | Parraylength k -> fprintf ppf "array.length[%s]" (array_kind k) - | Pmakearray (k, mut, mode) -> - let mode = match mode with Alloc_local -> "local" | Alloc_heap -> "" in - let mut = match mut with - | Mutable -> "" - | Immutable -> "_imm" - | Immutable_unique -> "_unique" - in - fprintf ppf "make%sarray%s[%s]" mut mode (array_kind k) - | Pduparray (k, Mutable) -> fprintf ppf "duparray[%s]" (array_kind k) - | Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k) - | Pduparray (k, Immutable_unique) -> - fprintf ppf "duparray_unique[%s]" (array_kind k) - | Parrayrefu rk -> fprintf ppf "array.unsafe_get[%a]" pp_array_ref_kind rk - | Parraysetu sk -> fprintf ppf "array.unsafe_set[%a]" pp_array_set_kind sk - | Parrayrefs rk -> fprintf ppf "array.get[%a]" pp_array_ref_kind rk - | Parraysets sk -> fprintf ppf "array.set[%a]" pp_array_set_kind sk - | Pisint -> fprintf ppf "isint" - | Pisout -> fprintf ppf "isout" - | Pbintofint (bi,m) -> print_boxed_integer "of_int" ppf bi m - | Pintofbint bi -> print_boxed_integer "to_int" ppf bi alloc_heap - | Pcvtbint (bi1, bi2, m) -> - fprintf ppf "%s_of_%s%s" (boxed_integer_name bi2) (boxed_integer_name bi1) - (alloc_kind m) - | Pnegbint (bi,m) -> print_boxed_integer "neg" ppf bi m - | Paddbint (bi,m) -> print_boxed_integer "add" ppf bi m - | Psubbint (bi,m) -> print_boxed_integer "sub" ppf bi m - | Pmulbint (bi,m) -> print_boxed_integer "mul" ppf bi m - | Pdivbint { size = bi; is_safe = Safe; mode } -> - print_boxed_integer "div" ppf bi mode - | Pdivbint { size = bi; is_safe = Unsafe; mode } -> - print_boxed_integer "div_unsafe" ppf bi mode - | Pmodbint { size = bi; is_safe = Safe; mode } -> - print_boxed_integer "mod" ppf bi mode - | Pmodbint { size = bi; is_safe = Unsafe; mode } -> - print_boxed_integer "mod_unsafe" ppf bi mode - | Pandbint (bi,m) -> print_boxed_integer "and" ppf bi m - | Porbint (bi,m) -> print_boxed_integer "or" ppf bi m - | Pxorbint (bi,m) -> print_boxed_integer "xor" ppf bi m - | Plslbint (bi,m) -> print_boxed_integer "lsl" ppf bi m - | Plsrbint (bi,m) -> print_boxed_integer "lsr" ppf bi m - | Pasrbint (bi,m) -> print_boxed_integer "asr" ppf bi m - | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi alloc_heap - | Pbintcomp(bi, Cne) -> print_boxed_integer "!=" ppf bi alloc_heap - | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi alloc_heap - | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi alloc_heap - | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi alloc_heap - | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi alloc_heap - | Pbigarrayref(unsafe, _n, kind, layout) -> - Printlambda.print_bigarray "get" unsafe kind ppf layout - | Pbigarrayset(unsafe, _n, kind, layout) -> - Printlambda.print_bigarray "set" unsafe kind ppf layout - | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n - | Pstring_load(size, safety, mode) -> - fprintf ppf "string.%sget%s%s" (access_safety safety) (access_size size) - (alloc_kind mode) - | Pbytes_load(size, safety, mode) -> - fprintf ppf "bytes.%sget%s%s" (access_safety safety) (access_size size) - (alloc_kind mode) - | Pbytes_set(size, safety) -> - fprintf ppf "bytes.%sset%s" (access_safety safety) (access_size size) - | Pbigstring_load(size, safety, mode) -> - fprintf ppf "bigarray.array1.%sget%s%s" - (access_safety safety) (access_size size) (alloc_kind mode) - | Pbigstring_set(size, safety) -> - fprintf ppf "bigarray.array1.%sset%s" - (access_safety safety) (access_size size) - | Pbswap16 -> fprintf ppf "bswap16" - | Pbbswap(bi,m) -> print_boxed_integer "bswap" ppf bi m - | Pint_as_pointer m -> fprintf ppf "int_as_pointer.%s" (alloc_kind m) - | Patomic_load {immediate_or_pointer} -> - (match immediate_or_pointer with - | Immediate -> fprintf ppf "atomic_load_imm" - | Pointer -> fprintf ppf "atomic_load_ptr") - | Patomic_exchange -> fprintf ppf "atomic_exchange" - | Patomic_cas -> fprintf ppf "atomic_cas" - | Patomic_fetch_add -> fprintf ppf "atomic_fetch_add" - | Popaque -> fprintf ppf "opaque" - | Pprobe_is_enabled {name} -> fprintf ppf "probe_is_enabled[%s]" name - | Pbox_float m -> fprintf ppf "box_float.%s" (alloc_kind m) - | Punbox_float -> fprintf ppf "unbox_float" - | Pbox_int (bi, m) -> - fprintf ppf "box_%s.%s" (boxed_integer_name bi) (alloc_kind m) - | Punbox_int bi -> fprintf ppf "unbox_%s" (boxed_integer_name bi) - | Pmake_unboxed_product layouts -> - fprintf ppf "make_unboxed_product(@[%a@])" - (Format.pp_print_list - ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ") - Printlambda.layout) - layouts - | Punboxed_product_field (field, layouts) -> - fprintf ppf "unboxed_product_field(@[%a@]) %i" - (Format.pp_print_list - ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ") - Printlambda.layout) - layouts - field - | Pget_header m -> fprintf ppf "get_header.%s" (alloc_kind m) - | Pdls_get -> fprintf ppf "dls_get" diff --git a/middle_end/printclambda_primitives.mli b/middle_end/printclambda_primitives.mli deleted file mode 100644 index 07db5a1ce6e..00000000000 --- a/middle_end/printclambda_primitives.mli +++ /dev/null @@ -1,18 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -open Format - -val primitive: formatter -> Clambda_primitives.primitive -> unit diff --git a/middle_end/semantics_of_primitives.ml b/middle_end/semantics_of_primitives.ml deleted file mode 100644 index 42a9665bed6..00000000000 --- a/middle_end/semantics_of_primitives.ml +++ /dev/null @@ -1,309 +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"] - -type effects = No_effects | Only_generative_effects | Arbitrary_effects -type coeffects = No_coeffects | Has_coeffects - -let coeffects_of : Lambda.alloc_mode -> coeffects = function - | Alloc_heap -> - No_coeffects - | Alloc_local -> - (* Ensure that local allocations are not reordered wrt. regions *) - Has_coeffects - -let for_primitive (prim : Clambda_primitives.primitive) = - match prim with - | Pmakeblock (_, _, _, m) - | Pmakeufloatblock (_, m) - | Pmakearray (_, Mutable, m) -> Only_generative_effects, coeffects_of m - | Pmakearray (_, (Immutable | Immutable_unique), m) -> - No_effects, coeffects_of m - | Pduparray (_, (Immutable | Immutable_unique)) -> - No_effects, No_coeffects (* Pduparray (_, Immutable) is allowed only on - immutable arrays. *) - | Pduparray (_, Mutable) | Pduprecord _ -> - Only_generative_effects, Has_coeffects - | Pccall { prim_name = - ( "caml_format_float" | "caml_format_int" | "caml_int32_format" - | "caml_nativeint_format" | "caml_int64_format" ) } -> - No_effects, No_coeffects - | Pccall { prim_effects; prim_coeffects } -> - let effects = - match prim_effects with - | No_effects -> No_effects - | Only_generative_effects -> Only_generative_effects - | Arbitrary_effects -> Arbitrary_effects - in - let coeffects = - match prim_coeffects with - | No_coeffects -> No_coeffects - | Has_coeffects -> Has_coeffects - in - effects, coeffects - | Pprobe_is_enabled _ -> No_effects, Has_coeffects - | Praise _ -> Arbitrary_effects, No_coeffects - | Prunstack | Pperform | Presume | Preperform -> - Arbitrary_effects, Has_coeffects - | Pnot - | Pnegint - | Paddint - | Psubint - | Pmulint - | Pandint - | Porint - | Pxorint - | Plslint - | Plsrint - | Pasrint - | Pintcomp _ -> No_effects, No_coeffects - | Pcompare_ints | Pcompare_floats | Pcompare_bints _ - -> No_effects, No_coeffects - | Pdivbint { is_safe = Unsafe } - | Pmodbint { is_safe = Unsafe } - | Pdivint Unsafe - | Pmodint Unsafe -> - No_effects, No_coeffects (* Will not raise [Division_by_zero]. *) - | Pdivbint { is_safe = Safe } - | Pmodbint { is_safe = Safe } - | Pdivint Safe - | Pmodint Safe -> - Arbitrary_effects, No_coeffects - | Poffsetint _ -> No_effects, No_coeffects - | Poffsetref _ -> Arbitrary_effects, Has_coeffects - | Punbox_float | Punbox_int _ - | Pmake_unboxed_product _ - | Punboxed_product_field _ - | Pintoffloat - | Pfloatcomp _ - | Punboxed_float_comp _ -> No_effects, No_coeffects - | Pbox_float m | Pbox_int (_, m) - | Pfloatofint m - | Pnegfloat m - | Pabsfloat m - | Paddfloat m - | Psubfloat m - | Pmulfloat m - | Pdivfloat m -> No_effects, coeffects_of m - | Pstringlength | Pbyteslength - | Parraylength _ -> No_effects, No_coeffects - | Pisint - | Pisout - | Pintofbint _ - | Pbintcomp _ -> No_effects, No_coeffects - | Pbintofint (_,m) - | Pcvtbint (_,_,m) - | Pnegbint (_,m) - | Paddbint (_,m) - | Psubbint (_,m) - | Pmulbint (_,m) - | Pandbint (_,m) - | Porbint (_,m) - | Pxorbint (_,m) - | Plslbint (_,m) - | Plsrbint (_,m) - | Pasrbint (_,m) -> No_effects, coeffects_of m - | Pbigarraydim _ -> - No_effects, Has_coeffects (* Some people resize bigarrays in place. *) - | Pread_symbol _ - | Pfield _ - | Pfield_computed - | Pfloatfield _ - | Pufloatfield _ - | Parrayrefu _ - | Pstringrefu - | Pbytesrefu - | Pstring_load (_, Unsafe, _) - | Pbytes_load (_, Unsafe, _) - | Pbigarrayref (true, _, _, _) - | Pbigstring_load (_, Unsafe, _) -> - No_effects, Has_coeffects - | Parrayrefs _ - | Pstringrefs - | Pbytesrefs - | Pstring_load (_, Safe, _) - | Pbytes_load (_, Safe, _) - | Pbigarrayref (false, _, _, _) - | Pbigstring_load (_, Safe, _) -> - (* May trigger a bounds check exception. *) - Arbitrary_effects, Has_coeffects - | Psetfield _ - | Psetfield_computed _ - | Psetfloatfield _ - | Psetufloatfield _ - | Patomic_load _ - | Patomic_exchange - | Patomic_cas - | Patomic_fetch_add - | Parraysetu _ - | Parraysets _ - | Pbytessetu - | Pbytessets - | Pbytes_set _ - | Pbigarrayset _ - | Pbigstring_set _ -> - (* Whether or not some of these are "unsafe" is irrelevant; they always - have an effect. *) - Arbitrary_effects, No_coeffects - | Pbswap16 -> No_effects, No_coeffects - | Pbbswap (_,m) -> No_effects, coeffects_of m - | Pint_as_pointer m -> No_effects, coeffects_of m - | Popaque -> Arbitrary_effects, Has_coeffects - | Psequand - | Psequor -> - (* Removed by [Closure_conversion] in the flambda pipeline. *) - No_effects, No_coeffects - | Pget_header _ -> No_effects, No_coeffects - | Pdls_get -> - (* only read *) - No_effects, No_coeffects - -type return_type = - | Float - | Other - -let return_type_of_primitive (prim:Clambda_primitives.primitive) = - match prim with - | Pfloatofint _ - | Pnegfloat _ - | Pabsfloat _ - | Paddfloat _ - | Psubfloat _ - | Pmulfloat _ - | Pdivfloat _ - | Pfloatfield _ - | Parrayrefu (Pfloatarray_ref _) - | Parrayrefs (Pfloatarray_ref _) -> - Float - | _ -> - Other - -let is_local_alloc = function - | Lambda.Alloc_local -> true - | Lambda.Alloc_heap -> false - -let may_locally_allocate (prim:Clambda_primitives.primitive) : bool = - match prim with - | Pmakeblock (_, _, _, m) - | Pmakeufloatblock (_, m) - | Pmakearray (_, _, m) -> is_local_alloc m - | Pduparray (_, _) - | Pduprecord (_,_) -> false - | Pccall { prim_name = - ( "caml_format_float" | "caml_format_int" | "caml_int32_format" - | "caml_nativeint_format" | "caml_int64_format" ) } -> false - | Pccall _ -> - (* TODO: Track which C calls may locally allocate more precisely *) - true - | Praise _ -> false - | Pnot - | Pnegint - | Paddint - | Psubint - | Pmulint - | Pandint - | Pdivint _ - | Pmodint _ - | Porint - | Pxorint - | Plslint - | Plsrint - | Pasrint - | Pintcomp _ -> false - | Pcompare_ints | Pcompare_floats | Pcompare_bints _ - -> false - | Poffsetint _ -> false - | Poffsetref _ -> false - | Punbox_float | Punbox_int _ - | Pmake_unboxed_product _ - | Punboxed_product_field _ - | Pintoffloat - | Pfloatcomp _ - | Punboxed_float_comp _ -> false - | Pbox_float m | Pbox_int (_, m) - | Pfloatofint m - | Pnegfloat m - | Pabsfloat m - | Paddfloat m - | Psubfloat m - | Pmulfloat m - | Pdivfloat m -> is_local_alloc m - | Pstringlength | Pbyteslength - | Parraylength _ -> false - | Pisint - | Pisout - | Pintofbint _ - | Pbintcomp _ -> false - | Pdivbint { mode = m } - | Pmodbint { mode = m } - | Pbintofint (_,m) - | Pcvtbint (_,_,m) - | Pnegbint (_,m) - | Paddbint (_,m) - | Psubbint (_,m) - | Pmulbint (_,m) - | Pandbint (_,m) - | Porbint (_,m) - | Pxorbint (_,m) - | Plslbint (_,m) - | Plsrbint (_,m) - | Pasrbint (_,m) -> is_local_alloc m - | Pbigarraydim _ -> false - | Pread_symbol _ - | Pfield _ - | Pfield_computed - | Parrayrefu _ - | Pstringrefu - | Pbytesrefu - | Pstring_load (_, Unsafe, _) - | Pbytes_load (_, Unsafe, _) - | Pbigarrayref (true, _, _, _) - | Pbigstring_load (_, Unsafe, _) -> - false - | Pfloatfield (_, m) -> is_local_alloc m - | Pufloatfield _ -> false - | Pstring_load (_, Safe, m) - | Pbytes_load (_, Safe, m) - | Pbigstring_load (_, Safe, m) -> is_local_alloc m - | Parrayrefs _ - | Pstringrefs - | Pbytesrefs - | Pbigarrayref (false, _, _, _) -> false - | Psetfield _ - | Psetfield_computed _ - | Psetfloatfield _ - | Psetufloatfield _ - | Parraysetu _ - | Parraysets _ - | Pbytessetu - | Pbytessets - | Pbytes_set _ - | Pbigarrayset _ - | Pbigstring_set _ -> - false - | Pbswap16 -> false - | Pbbswap (_,m) -> is_local_alloc m - | Pint_as_pointer m -> is_local_alloc m - | Popaque -> false - | Psequand - | Psequor -> - false - | Pprobe_is_enabled _ -> false - | Pget_header m -> is_local_alloc m - | Prunstack | Pperform | Presume | Preperform -> true - | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Pdls_get - | Patomic_load _ -> false diff --git a/middle_end/semantics_of_primitives.mli b/middle_end/semantics_of_primitives.mli deleted file mode 100644 index d898cd6f31e..00000000000 --- a/middle_end/semantics_of_primitives.mli +++ /dev/null @@ -1,71 +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"] - -(** Description of the semantics of primitives, to be used for optimization - purposes. - - "No effects" means that the primitive does not change the observable state - of the world. For example, it must not write to any mutable storage, - call arbitrary external functions or change control flow (e.g. by raising - an exception). Note that allocation is not "No effects" (see below). - - It is assumed in the compiler that applications of primitives with no - effects, whose results are not used, may be eliminated. It is further - assumed that applications of primitives with no effects may be - duplicated (and thus possibly executed more than once). - - (Exceptions arising from allocation points, for example "out of memory" or - exceptions propagated from finalizers or signal handlers, are treated as - "effects out of the ether" and thus ignored for our determination here - of effectfulness. The same goes for floating point operations that may - cause hardware traps on some platforms.) - - "Only generative effects" means that a primitive does not change the - observable state of the world save for possibly affecting the state of - the garbage collector by performing an allocation. Applications of - primitives that only have generative effects and whose results are unused - may be eliminated by the compiler. However, unlike "No effects" - primitives, such applications will never be eligible for duplication. - - "Arbitrary effects" covers all other primitives. - - "No coeffects" means that the primitive does not observe the effects (in - the sense described above) of other expressions. For example, it must not - read from any mutable storage or call arbitrary external functions. - - It is assumed in the compiler that, subject to data dependencies, - expressions with neither effects nor coeffects may be reordered with - respect to other expressions. -*) - -type effects = No_effects | Only_generative_effects | Arbitrary_effects -type coeffects = No_coeffects | Has_coeffects - -(** Describe the semantics of a primitive. This does not take into account of - the (non-)(co)effectfulness of the arguments in a primitive application. - To determine whether such an application is (co)effectful, the arguments - must also be analysed. *) -val for_primitive: Clambda_primitives.primitive -> effects * coeffects - -type return_type = - | Float - | Other - -val return_type_of_primitive: Clambda_primitives.primitive -> return_type - -val may_locally_allocate : Clambda_primitives.primitive -> bool diff --git a/middle_end/symbol_utils.ml b/middle_end/symbol_utils.ml deleted file mode 100644 index 081591eb3b8..00000000000 --- a/middle_end/symbol_utils.ml +++ /dev/null @@ -1,49 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2021 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-9-30-40-41-42"] - -module CU = Compilation_unit - -let for_fun_ident ~compilation_unit loc id = - let compilation_unit = - match compilation_unit with - | None -> CU.get_current_exn () - | Some cu -> cu - in - if Config.with_cpp_mangling then - (* CR lmaurer: Properly integrate [Compilation_unit.t] into [Mangling] *) - let unitname = CU.full_path_as_string compilation_unit in - let linkage_name = - Mangling.fun_symbol ~unitname ~loc ~id:(Ident.unique_name id) - |> Linkage_name.of_string - in - Symbol.unsafe_create compilation_unit linkage_name - else - Symbol.for_local_ident id - -module Flambda = struct - let for_variable var = - Symbol.for_name (Variable.get_compilation_unit var) (Variable.unique_name var) - - let for_closure closure_id = - Symbol.for_name (Closure_id.get_compilation_unit closure_id) - (Closure_id.unique_name closure_id ^ "_closure") - - let for_code_of_closure closure_id = - Symbol.for_name (Closure_id.get_compilation_unit closure_id) - (Closure_id.unique_name closure_id) -end diff --git a/middle_end/symbol_utils.mli b/middle_end/symbol_utils.mli deleted file mode 100644 index 711576a3a05..00000000000 --- a/middle_end/symbol_utils.mli +++ /dev/null @@ -1,29 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2021 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"] - -val for_fun_ident - : compilation_unit:Compilation_unit.t option - -> Debuginfo.Scoped_location.t - -> Ident.t - -> Symbol.t - -module Flambda : sig - val for_variable : Variable.t -> Symbol.t - val for_closure : Closure_id.t -> Symbol.t - val for_code_of_closure : Closure_id.t -> Symbol.t -end diff --git a/middle_end/variable.ml b/middle_end/variable.ml deleted file mode 100644 index 4b401dcc9bb..00000000000 --- a/middle_end/variable.ml +++ /dev/null @@ -1,128 +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-66"] -open! Int_replace_polymorphic_compare - -type t = { - compilation_unit : Compilation_unit.t; - name : string; - name_stamp : int; - (** [name_stamp]s are unique within any given compilation unit. *) - debug_info : Debuginfo.t option; -} - -include 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 = - if t1 == t2 then true - else - t1.name_stamp = t2.name_stamp - && Compilation_unit.equal t1.compilation_unit t2.compilation_unit - - let output chan t = - output_string chan t.name; - output_string chan "_"; - output_string chan (Int.to_string t.name_stamp) - - let hash t = t.name_stamp lxor (Compilation_unit.hash t.compilation_unit) - - let print ppf t = - 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 -end) - -let previous_name_stamp = ref (-1) - -let create_with_name_string ?current_compilation_unit ?debug_info name = - let compilation_unit = - match current_compilation_unit with - | Some compilation_unit -> compilation_unit - | None -> Compilation_unit.get_current_exn () - in - let name_stamp = - incr previous_name_stamp; - !previous_name_stamp - in - { compilation_unit; - name; - name_stamp; - debug_info; - } - -let create ?current_compilation_unit ?debug_info name = - let name = (name : Internal_variable_names.t :> string) in - create_with_name_string ?current_compilation_unit ?debug_info name - -let create_with_same_name_as_ident ?debug_info ident = - create_with_name_string ?debug_info (Ident.name ident) - -let rename ?current_compilation_unit ?debug_info t = - let debug_info = - match debug_info with - | Some _ -> debug_info - | None -> t.debug_info - in - create_with_name_string ?current_compilation_unit ?debug_info t.name - -let in_compilation_unit t cu = - Compilation_unit.equal cu t.compilation_unit - -let get_compilation_unit t = t.compilation_unit - -let debug_info t = t.debug_info - -let name t = t.name - -let unique_name t = - t.name ^ "_" ^ (Int.to_string t.name_stamp) - -let print_list ppf ts = - List.iter (fun t -> Format.fprintf ppf "@ %a" print t) ts - -let debug_when_stamp_matches t ~stamp ~f = - if t.name_stamp = stamp then f () - -let print_opt ppf = function - | None -> Format.fprintf ppf "" - | Some t -> print ppf t - -type pair = t * t -module Pair = Identifiable.Make (Identifiable.Pair (T) (T)) - -let compare_lists l1 l2 = - Misc.Stdlib.List.compare compare l1 l2 - -let output_full chan t = - Compilation_unit.output chan t.compilation_unit; - output_string chan "."; - output chan t diff --git a/middle_end/variable.mli b/middle_end/variable.mli deleted file mode 100644 index 83dd9062753..00000000000 --- a/middle_end/variable.mli +++ /dev/null @@ -1,68 +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"] - -(** [Variable.t] is the equivalent of a non-persistent [Ident.t] in - the [Flambda] tree. It wraps an [Ident.t] together with its source - [compilation_unit]. As such, it is unique within a whole program, - not just one compilation unit. - - Introducing a new type helps in tracing the source of identifiers - when debugging the inliner. It also avoids Ident renaming when - importing cmx files. -*) - -include Identifiable.S - -(** [debug_info] should be set for variables representing functions *) -val create - : ?current_compilation_unit:Compilation_unit.t - -> ?debug_info:Debuginfo.t - -> Internal_variable_names.t - -> t -val create_with_same_name_as_ident : ?debug_info:Debuginfo.t -> Ident.t -> t - -val rename - : ?current_compilation_unit:Compilation_unit.t - -> ?debug_info:Debuginfo.t - -> t - -> t - -val in_compilation_unit : t -> Compilation_unit.t -> bool - -val name : t -> string - -val unique_name : t -> string - -val get_compilation_unit : t -> Compilation_unit.t - -val debug_info : t -> Debuginfo.t option - -val print_list : Format.formatter -> t list -> unit -val print_opt : Format.formatter -> t option -> unit - -(** If the given variable has the given stamp, call the user-supplied - function. For debugging purposes only. *) -val debug_when_stamp_matches : t -> stamp:int -> f:(unit -> unit) -> unit - -type pair = t * t -module Pair : Identifiable.S with type t := pair - -val compare_lists : t list -> t list -> int - -val output_full : out_channel -> t -> unit -(** Unlike [output], [output_full] includes the compilation unit. *) diff --git a/native_toplevel/opttoploop.ml b/native_toplevel/opttoploop.ml index c159b3d0125..8554f7fc038 100644 --- a/native_toplevel/opttoploop.ml +++ b/native_toplevel/opttoploop.ml @@ -26,8 +26,6 @@ open Ast_helper module Genprintval = Genprintval_native -let any_flambda = Config.flambda || Config.flambda2 - type res = Ok of Obj.t | Err of string type evaluation_outcome = Result of Obj.t | Exception of exn @@ -125,9 +123,7 @@ let close_phrase lam = ) (free_variables lam) lam let toplevel_value id = - let glob, pos = - if any_flambda then toplevel_value id else Translmod.nat_toplevel_name id - in + let glob, pos = toplevel_value id in (Obj.magic (global_symbol glob)).(pos) (* Return the value referred to by a path *) @@ -253,24 +249,6 @@ let run_hooks hook = List.iter (fun f -> f hook) !hooks let phrase_seqid = ref 0 let phrase_name = ref "TOP" -(* CR-soon trefis for mshinwell: copy/pasted from Optmain. Should it be shared - or? - mshinwell: It should be shared, but after 4.03. *) -module Backend = struct - (* See backend_intf.mli. *) - - let really_import_approx = Import_approx.really_import_approx - let import_symbol = Import_approx.import_symbol - - let size_int = Arch.size_int - let big_endian = Arch.big_endian - - let max_sensible_number_of_arguments = - (* The "-1" is to allow for a potential closure environment parameter. *) - Proc.max_arguments_for_tailcalls - 1 -end -let backend = (module Backend : Backend_intf.S) - let default_load ppf (program : Lambda.program) = let dll = if !Clflags.keep_asm_file then !phrase_name ^ ext_dll @@ -278,14 +256,7 @@ let default_load ppf (program : Lambda.program) = in let filename = Filename.chop_extension dll in let pipeline : Asmgen.pipeline = - if Config.flambda2 then - Direct_to_cmm (Flambda2.lambda_to_cmm ~keep_symbol_tables:true) - else - let middle_end = - if Config.flambda then Flambda_middle_end.lambda_to_clambda - else Closure_middle_end.lambda_to_clambda - in - Via_clambda { middle_end; backend } + Direct_to_cmm (Flambda2.lambda_to_cmm ~keep_symbol_tables:true) in Asmgen.compile_implementation (module Unix : Compiler_owee.Unix_intf.S) @@ -443,17 +414,13 @@ let execute_phrase print_outcome ppf phr = | _ -> str, sg', false in let compilation_unit, res, required_globals, size = - if any_flambda then - let { Lambda.compilation_unit; main_module_block_size = size; - required_globals; code = res } = - Translmod.transl_implementation compilation_unit (str, coercion) - ~style:Plain_block - in - remember compilation_unit sg'; - compilation_unit, close_phrase res, required_globals, size - else - let size, res = Translmod.transl_store_phrases compilation_unit str in - compilation_unit, res, Compilation_unit.Set.empty, size + let { Lambda.compilation_unit; main_module_block_size = size; + required_globals; code = res } = + Translmod.transl_implementation compilation_unit (str, coercion) + ~style:Plain_block + in + remember compilation_unit sg'; + compilation_unit, close_phrase res, required_globals, size in Warnings.check_fatal (); begin try @@ -465,12 +432,8 @@ let execute_phrase print_outcome ppf phr = let out_phr = match res with | Result _ -> - if any_flambda then - (* CR-someday trefis: *) - Env.register_import_as_opaque - (Compilation_unit.name compilation_unit) - else - Compilenv.record_global_approx_toplevel (); + Env.register_import_as_opaque + (Compilation_unit.name compilation_unit); if print_outcome then Printtyp.wrap_printing_env ~error:false oldenv (fun () -> match str.str_items with diff --git a/ocaml/testsuite/tests/float-unboxing/float_subst_boxed_number.ml b/ocaml/testsuite/tests/float-unboxing/float_subst_boxed_number.ml index ec278a5ab35..c1e6c8c4302 100644 --- a/ocaml/testsuite/tests/float-unboxing/float_subst_boxed_number.ml +++ b/ocaml/testsuite/tests/float-unboxing/float_subst_boxed_number.ml @@ -2,10 +2,14 @@ include config flags = "-w -55" ocamlc_flags = "config.cmo" - ocamlopt_flags = "-inline 20 config.cmx" + ocamlopt_flags = "config.cmx" * native *) +(* CR-someday mshinwell: enable this for classic mode *) + +[@@@ocaml.flambda_o3] + let eliminate_intermediate_float_record () = let r = ref 0. in for n = 1 to 1000 do diff --git a/ocaml/testsuite/tests/statmemprof/callstacks.flat-float-array.bytecode.reference b/ocaml/testsuite/tests/statmemprof/callstacks.flat-float-array.bytecode.reference new file mode 100644 index 00000000000..046d1cf2a10 --- /dev/null +++ b/ocaml/testsuite/tests/statmemprof/callstacks.flat-float-array.bytecode.reference @@ -0,0 +1,74 @@ +----------- +Raised by primitive operation at Callstacks.alloc_list_literal in file "callstacks.ml", line 27, characters 30-53 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 +----------- +Raised by primitive operation at Callstacks.alloc_pair in file "callstacks.ml", line 30, characters 30-76 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 +----------- +Raised by primitive operation at Callstacks.alloc_record in file "callstacks.ml", line 35, characters 12-66 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 +----------- +Raised by primitive operation at Callstacks.alloc_some in file "callstacks.ml", line 38, characters 30-60 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 +----------- +Raised by primitive operation at Callstacks.alloc_array_literal in file "callstacks.ml", line 41, characters 30-55 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 +----------- +Raised by primitive operation at Callstacks.alloc_float_array_literal in file "callstacks.ml", line 45, characters 12-62 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 +----------- +Raised by primitive operation at Callstacks.do_alloc_unknown_array_literal in file "callstacks.ml", line 48, characters 22-27 +Called from Callstacks.alloc_unknown_array_literal in file "callstacks.ml", line 50, characters 30-65 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 +----------- +Raised by primitive operation at Callstacks.alloc_small_array in file "callstacks.ml", line 53, characters 30-69 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 +----------- +Raised by primitive operation at Callstacks.alloc_large_array in file "callstacks.ml", line 56, characters 30-73 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 +----------- +Raised by primitive operation at Callstacks.alloc_closure.(fun) in file "callstacks.ml", line 60, characters 30-43 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 +----------- +Raised by primitive operation at Callstacks.get0 in file "callstacks.ml", line 63, characters 28-33 +Called from Callstacks.getfloatfield in file "callstacks.ml", line 65, characters 30-47 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 +----------- +Raised by primitive operation at Stdlib__Marshal.from_bytes in file "marshal.ml", line 67, characters 9-35 +Called from Callstacks.alloc_unmarshal in file "callstacks.ml", line 71, characters 12-87 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 +----------- +Raised by primitive operation at Callstacks.alloc_ref in file "callstacks.ml", line 74, characters 30-59 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 +----------- +Raised by primitive operation at Callstacks.prod_floats in file "callstacks.ml", line 77, characters 37-43 +Called from Callstacks.alloc_boxedfloat in file "callstacks.ml", line 79, characters 30-49 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 diff --git a/ocaml/testsuite/tests/statmemprof/callstacks.flat-float-array.reference b/ocaml/testsuite/tests/statmemprof/callstacks.flat-float-array.reference index c2f7fd6e029..abf4916640f 100644 --- a/ocaml/testsuite/tests/statmemprof/callstacks.flat-float-array.reference +++ b/ocaml/testsuite/tests/statmemprof/callstacks.flat-float-array.reference @@ -1,74 +1,75 @@ ----------- -Raised by primitive operation at Callstacks.alloc_list_literal in file "callstacks.ml", line 20, characters 30-53 -Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 +Raised by primitive operation at Callstacks.alloc_list_literal in file "callstacks.ml", line 27, characters 30-53 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 ----------- -Raised by primitive operation at Callstacks.alloc_pair in file "callstacks.ml", line 23, characters 30-76 -Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 +Raised by primitive operation at Callstacks.alloc_pair in file "callstacks.ml", line 30, characters 30-76 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 ----------- -Raised by primitive operation at Callstacks.alloc_record in file "callstacks.ml", line 28, characters 12-66 -Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 +Raised by primitive operation at Callstacks.alloc_record in file "callstacks.ml", line 35, characters 12-66 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 ----------- -Raised by primitive operation at Callstacks.alloc_some in file "callstacks.ml", line 31, characters 30-60 -Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 +Raised by primitive operation at Callstacks.alloc_some in file "callstacks.ml", line 38, characters 30-60 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 ----------- -Raised by primitive operation at Callstacks.alloc_array_literal in file "callstacks.ml", line 34, characters 30-55 -Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 +Raised by primitive operation at Callstacks.alloc_array_literal in file "callstacks.ml", line 41, characters 30-55 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 ----------- -Raised by primitive operation at Callstacks.alloc_float_array_literal in file "callstacks.ml", line 38, characters 12-62 -Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 +Raised by primitive operation at Callstacks.alloc_float_array_literal in file "callstacks.ml", line 45, characters 12-62 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 ----------- -Raised by primitive operation at Callstacks.do_alloc_unknown_array_literal in file "callstacks.ml", line 41, characters 22-27 -Called from Callstacks.alloc_unknown_array_literal in file "callstacks.ml", line 43, characters 30-65 -Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 +Raised by primitive operation at Callstacks.do_alloc_unknown_array_literal in file "callstacks.ml", line 48, characters 22-27 +Called from Callstacks.alloc_unknown_array_literal in file "callstacks.ml", line 50, characters 30-65 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 ----------- -Raised by primitive operation at Callstacks.alloc_small_array in file "callstacks.ml", line 46, characters 30-69 -Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 +Raised by primitive operation at Callstacks.alloc_small_array in file "callstacks.ml", line 53, characters 30-69 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 ----------- -Raised by primitive operation at Callstacks.alloc_large_array in file "callstacks.ml", line 49, characters 30-73 -Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 +Raised by primitive operation at Callstacks.alloc_large_array in file "callstacks.ml", line 56, characters 30-73 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 ----------- -Raised by primitive operation at Callstacks.alloc_closure.(fun) in file "callstacks.ml", line 53, characters 30-43 -Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 +Raised by primitive operation at Callstacks.alloc_closure.(fun) in file "callstacks.ml", line 60, characters 30-43 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 ----------- -Raised by primitive operation at Callstacks.get0 in file "callstacks.ml", line 56, characters 28-33 -Called from Callstacks.getfloatfield in file "callstacks.ml", line 58, characters 30-47 -Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 +Raised by primitive operation at Callstacks.get0 in file "callstacks.ml", line 63, characters 28-33 +Called from Callstacks.getfloatfield in file "callstacks.ml", line 65, characters 30-47 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 ----------- -Raised by primitive operation at Stdlib__Marshal.from_bytes in file "marshal.ml", line 67, characters 9-35 -Called from Callstacks.alloc_unmarshal in file "callstacks.ml", line 64, characters 12-87 -Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 +Raised by primitive operation at Stdlib__Marshal.from_bytes in file "marshal.ml" (inlined), line 67, characters 9-35 +Called from Stdlib__Marshal.from_string in file "marshal.ml", line 73, characters 2-46 +Called from Callstacks.alloc_unmarshal in file "callstacks.ml", line 71, characters 12-87 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 ----------- -Raised by primitive operation at Callstacks.alloc_ref in file "callstacks.ml", line 67, characters 30-59 -Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 +Raised by primitive operation at Callstacks.alloc_ref in file "callstacks.ml", line 74, characters 30-59 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 ----------- -Raised by primitive operation at Callstacks.prod_floats in file "callstacks.ml", line 70, characters 37-43 -Called from Callstacks.alloc_boxedfloat in file "callstacks.ml", line 72, characters 30-49 -Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 +Raised by primitive operation at Callstacks.prod_floats in file "callstacks.ml", line 77, characters 37-43 +Called from Callstacks.alloc_boxedfloat in file "callstacks.ml", line 79, characters 30-49 +Called from Callstacks.test in file "callstacks.ml", line 101, characters 2-10 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 108, characters 2-27 diff --git a/ocaml/testsuite/tests/statmemprof/callstacks.ml b/ocaml/testsuite/tests/statmemprof/callstacks.ml index 3e63a778565..13b517e3e64 100644 --- a/ocaml/testsuite/tests/statmemprof/callstacks.ml +++ b/ocaml/testsuite/tests/statmemprof/callstacks.ml @@ -4,14 +4,21 @@ * flat-float-array reference = "${test_source_directory}/callstacks.flat-float-array.reference" ** runtime4 - *** native - *** bytecode + *** flambda2 + **** native + + * flat-float-array + reference = "${test_source_directory}/callstacks.flat-float-array.bytecode.reference" + ** runtime4 + *** flambda2 + **** bytecode * no-flat-float-array reference = "${test_source_directory}/callstacks.no-flat-float-array.reference" ** runtime4 - *** native - *** bytecode + *** flambda2 + **** native + **** bytecode *) open Gc.Memprof diff --git a/ocaml/testsuite/tests/statmemprof/comballoc.byte.reference b/ocaml/testsuite/tests/statmemprof/comballoc.byte.reference index 2682ecfe055..d0f2153fca7 100644 --- a/ocaml/testsuite/tests/statmemprof/comballoc.byte.reference +++ b/ocaml/testsuite/tests/statmemprof/comballoc.byte.reference @@ -1,49 +1,49 @@ 2: 0.42 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 2-19 -Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 18, characters 2-19 +Called from Comballoc.test in file "comballoc.ml", line 43, characters 25-48 Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 +Called from Comballoc in file "comballoc.ml", line 73, characters 2-35 3: 0.42 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 6-18 -Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 18, characters 6-18 +Called from Comballoc.test in file "comballoc.ml", line 43, characters 25-48 Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 +Called from Comballoc in file "comballoc.ml", line 73, characters 2-35 4: 0.42 true -Raised by primitive operation at Comballoc.f4 in file "comballoc.ml", line 12, characters 11-20 -Called from Comballoc.f in file "comballoc.ml", line 15, characters 13-17 -Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Raised by primitive operation at Comballoc.f4 in file "comballoc.ml", line 15, characters 11-20 +Called from Comballoc.f in file "comballoc.ml", line 18, characters 13-17 +Called from Comballoc.test in file "comballoc.ml", line 43, characters 25-48 Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 +Called from Comballoc in file "comballoc.ml", line 73, characters 2-35 2: 0.01 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 2-19 -Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 18, characters 2-19 +Called from Comballoc.test in file "comballoc.ml", line 43, characters 25-48 Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 +Called from Comballoc in file "comballoc.ml", line 73, characters 2-35 3: 0.01 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 6-18 -Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 18, characters 6-18 +Called from Comballoc.test in file "comballoc.ml", line 43, characters 25-48 Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 +Called from Comballoc in file "comballoc.ml", line 73, characters 2-35 4: 0.01 true -Raised by primitive operation at Comballoc.f4 in file "comballoc.ml", line 12, characters 11-20 -Called from Comballoc.f in file "comballoc.ml", line 15, characters 13-17 -Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Raised by primitive operation at Comballoc.f4 in file "comballoc.ml", line 15, characters 11-20 +Called from Comballoc.f in file "comballoc.ml", line 18, characters 13-17 +Called from Comballoc.test in file "comballoc.ml", line 43, characters 25-48 Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 +Called from Comballoc in file "comballoc.ml", line 73, characters 2-35 2: 0.83 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 2-19 -Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 18, characters 2-19 +Called from Comballoc.test in file "comballoc.ml", line 43, characters 25-48 Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 +Called from Comballoc in file "comballoc.ml", line 73, characters 2-35 3: 0.83 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 6-18 -Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 18, characters 6-18 +Called from Comballoc.test in file "comballoc.ml", line 43, characters 25-48 Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 +Called from Comballoc in file "comballoc.ml", line 73, characters 2-35 4: 0.83 true -Raised by primitive operation at Comballoc.f4 in file "comballoc.ml", line 12, characters 11-20 -Called from Comballoc.f in file "comballoc.ml", line 15, characters 13-17 -Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Raised by primitive operation at Comballoc.f4 in file "comballoc.ml", line 15, characters 11-20 +Called from Comballoc.f in file "comballoc.ml", line 18, characters 13-17 +Called from Comballoc.test in file "comballoc.ml", line 43, characters 25-48 Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 +Called from Comballoc in file "comballoc.ml", line 73, characters 2-35 OK diff --git a/ocaml/testsuite/tests/statmemprof/comballoc.ml b/ocaml/testsuite/tests/statmemprof/comballoc.ml index df17426e0b2..1136c7cea61 100644 --- a/ocaml/testsuite/tests/statmemprof/comballoc.ml +++ b/ocaml/testsuite/tests/statmemprof/comballoc.ml @@ -1,12 +1,15 @@ (* TEST flags = "-g" * runtime4 - ** bytecode + ** flambda2 + *** bytecode reference = "${test_source_directory}/comballoc.byte.reference" - ** native + *** native reference = "${test_source_directory}/comballoc.opt.reference" *) +[@@@ocaml.flambda_o3] + open Gc.Memprof let f4 n = (n,n,n,n) diff --git a/ocaml/testsuite/tests/statmemprof/comballoc.opt.reference b/ocaml/testsuite/tests/statmemprof/comballoc.opt.reference index bc7ae01daed..bbda011d0cf 100644 --- a/ocaml/testsuite/tests/statmemprof/comballoc.opt.reference +++ b/ocaml/testsuite/tests/statmemprof/comballoc.opt.reference @@ -1,49 +1,49 @@ 2: 0.42 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 2-19 -Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 18, characters 2-19 +Called from Comballoc.test in file "comballoc.ml", line 43, characters 25-48 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 73, characters 2-35 3: 0.42 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 6-18 -Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 18, characters 6-18 +Called from Comballoc.test in file "comballoc.ml", line 43, characters 25-48 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 73, characters 2-35 4: 0.42 true -Raised by primitive operation at Comballoc.f4 in file "comballoc.ml" (inlined), line 12, characters 11-20 -Called from Comballoc.f in file "comballoc.ml", line 15, characters 13-17 -Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 +Raised by primitive operation at Comballoc.f4 in file "comballoc.ml" (inlined), line 15, characters 11-20 +Called from Comballoc.f in file "comballoc.ml", line 18, characters 13-17 +Called from Comballoc.test in file "comballoc.ml", line 43, characters 25-48 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 73, characters 2-35 2: 0.01 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 2-19 -Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 18, characters 2-19 +Called from Comballoc.test in file "comballoc.ml", line 43, characters 25-48 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 73, characters 2-35 3: 0.01 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 6-18 -Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 18, characters 6-18 +Called from Comballoc.test in file "comballoc.ml", line 43, characters 25-48 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 73, characters 2-35 4: 0.01 true -Raised by primitive operation at Comballoc.f4 in file "comballoc.ml" (inlined), line 12, characters 11-20 -Called from Comballoc.f in file "comballoc.ml", line 15, characters 13-17 -Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 +Raised by primitive operation at Comballoc.f4 in file "comballoc.ml" (inlined), line 15, characters 11-20 +Called from Comballoc.f in file "comballoc.ml", line 18, characters 13-17 +Called from Comballoc.test in file "comballoc.ml", line 43, characters 25-48 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 73, characters 2-35 2: 0.83 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 2-19 -Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 18, characters 2-19 +Called from Comballoc.test in file "comballoc.ml", line 43, characters 25-48 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 73, characters 2-35 3: 0.83 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 6-18 -Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 18, characters 6-18 +Called from Comballoc.test in file "comballoc.ml", line 43, characters 25-48 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 73, characters 2-35 4: 0.83 true -Raised by primitive operation at Comballoc.f4 in file "comballoc.ml" (inlined), line 12, characters 11-20 -Called from Comballoc.f in file "comballoc.ml", line 15, characters 13-17 -Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 +Raised by primitive operation at Comballoc.f4 in file "comballoc.ml" (inlined), line 15, characters 11-20 +Called from Comballoc.f in file "comballoc.ml", line 18, characters 13-17 +Called from Comballoc.test in file "comballoc.ml", line 43, characters 25-48 +Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 73, characters 2-35 OK diff --git a/ocaml/testsuite/tests/warnings/w55.flambda.reference b/ocaml/testsuite/tests/warnings/w55.flambda.reference index 7206a8f218a..0dd30e1442c 100644 --- a/ocaml/testsuite/tests/warnings/w55.flambda.reference +++ b/ocaml/testsuite/tests/warnings/w55.flambda.reference @@ -1,14 +1,11 @@ -File "w55.ml", line 33, characters 10-26: -33 | let h x = (j [@inlined]) x +File "w55.ml", line 35, characters 10-26: +35 | let h x = (j [@inlined]) x ^^^^^^^^^^^^^^^^ Warning 55 [inlining-impossible]: Cannot inline: [@inlined] attributes may not be used on partial applications -File "w55.ml", line 39, characters 12-30: -39 | let b x y = (a [@inlined]) x y - ^^^^^^^^^^^^^^^^^^ -Warning 55 [inlining-impossible]: Cannot inline: [@inlined] attribute was not used on this function application (the optimizer did not know what function was being applied) - -File "w55.ml", line 29, characters 10-27: -29 | let i x = (!r [@inlined]) x +File "w55.ml", line 31, characters 10-27: +31 | let i x = (!r [@inlined]) x ^^^^^^^^^^^^^^^^^ -Warning 55 [inlining-impossible]: Cannot inline: [@inlined] attribute was not used on this function application (the optimizer did not know what function was being applied) +Warning 55 [inlining-impossible]: Cannot inline: + the optimizer did not know what function was being applied + (the full inlining stack was: w55.ml:31,10--27) diff --git a/ocaml/testsuite/tests/warnings/w55.ml b/ocaml/testsuite/tests/warnings/w55.ml index d597d466878..3e2d0513378 100644 --- a/ocaml/testsuite/tests/warnings/w55.ml +++ b/ocaml/testsuite/tests/warnings/w55.ml @@ -20,6 +20,8 @@ compiler_reference = "${test_source_directory}/w55.flambda.reference" *) +[@@@ocaml.flambda_o3] + let f = (fun x -> x + 1) [@inline never] let g x = (f [@inlined]) x diff --git a/ocaml/testsuite/tests/warnings/w55.native.reference b/ocaml/testsuite/tests/warnings/w55.native.reference index 63f7fd7a91b..49a11637d9a 100644 --- a/ocaml/testsuite/tests/warnings/w55.native.reference +++ b/ocaml/testsuite/tests/warnings/w55.native.reference @@ -1,29 +1,29 @@ -File "w55.ml", line 25, characters 10-26: -25 | let g x = (f [@inlined]) x +File "w55.ml", line 27, characters 10-26: +27 | let g x = (f [@inlined]) x ^^^^^^^^^^^^^^^^ Warning 55 [inlining-impossible]: Cannot inline: Function information unavailable -File "w55.ml", line 29, characters 10-27: -29 | let i x = (!r [@inlined]) x +File "w55.ml", line 31, characters 10-27: +31 | let i x = (!r [@inlined]) x ^^^^^^^^^^^^^^^^^ Warning 55 [inlining-impossible]: Cannot inline: Unknown function -File "w55.ml", line 33, characters 10-26: -33 | let h x = (j [@inlined]) x +File "w55.ml", line 35, characters 10-26: +35 | let h x = (j [@inlined]) x ^^^^^^^^^^^^^^^^ Warning 55 [inlining-impossible]: Cannot inline: Partial application -File "w55.ml", line 39, characters 12-30: -39 | let b x y = (a [@inlined]) x y +File "w55.ml", line 41, characters 12-30: +41 | let b x y = (a [@inlined]) x y ^^^^^^^^^^^^^^^^^^ Warning 55 [inlining-impossible]: Cannot inline: Over-application -File "w55.ml", line 39, characters 12-30: -39 | let b x y = (a [@inlined]) x y +File "w55.ml", line 41, characters 12-30: +41 | let b x y = (a [@inlined]) x y ^^^^^^^^^^^^^^^^^^ Warning 55 [inlining-impossible]: Cannot inline: Function information unavailable -File "w55.ml", line 42, characters 10-26: -42 | let d x = (c [@inlined]) x +File "w55.ml", line 44, characters 10-26: +44 | let d x = (c [@inlined]) x ^^^^^^^^^^^^^^^^ Warning 55 [inlining-impossible]: Cannot inline: Function information unavailable diff --git a/ocaml/testsuite/tests/warnings/w59.flambda.reference b/ocaml/testsuite/tests/warnings/w59.flambda.reference deleted file mode 100644 index 04bf8782b91..00000000000 --- a/ocaml/testsuite/tests/warnings/w59.flambda.reference +++ /dev/null @@ -1,34 +0,0 @@ -File "w59.ml", line 52, characters 2-39: -52 | set_field (Obj.repr o) 0 (Obj.repr 3); - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Warning 59 [flambda-assignment-to-non-mutable-value]: A potential assignment to a non-mutable value was detected -in this source file. Such assignments may generate incorrect code -when using Flambda. - -File "w59.ml", line 53, characters 2-39: -53 | set_field (Obj.repr p) 0 (Obj.repr 3); - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Warning 59 [flambda-assignment-to-non-mutable-value]: A potential assignment to a non-mutable value was detected -in this source file. Such assignments may generate incorrect code -when using Flambda. - -File "w59.ml", line 54, characters 2-39: -54 | set_field (Obj.repr q) 0 (Obj.repr 3); - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Warning 59 [flambda-assignment-to-non-mutable-value]: A potential assignment to a non-mutable value was detected -in this source file. Such assignments may generate incorrect code -when using Flambda. - -File "w59.ml", line 55, characters 2-39: -55 | set_field (Obj.repr r) 0 (Obj.repr 3) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Warning 59 [flambda-assignment-to-non-mutable-value]: A potential assignment to a non-mutable value was detected -in this source file. Such assignments may generate incorrect code -when using Flambda. - -File "w59.ml", line 62, characters 2-7: -62 | set o - ^^^^^ -Warning 59 [flambda-assignment-to-non-mutable-value]: A potential assignment to a non-mutable value was detected -in this source file. Such assignments may generate incorrect code -when using Flambda. diff --git a/ocaml/testsuite/tests/warnings/w59.ml b/ocaml/testsuite/tests/warnings/w59.ml deleted file mode 100644 index 0ad01218c1f..00000000000 --- a/ocaml/testsuite/tests/warnings/w59.ml +++ /dev/null @@ -1,71 +0,0 @@ -(* TEST - -flags = "-w +A-70" -compile_only = "true" - -* setup-ocamlc.byte-build-env -** ocamlc.byte -*** check-ocamlc.byte-output - -* no-flambda -** setup-ocamlopt.byte-build-env -*** ocamlopt.byte -**** check-ocamlopt.byte-output - -* flambda -compiler_reference = "${test_source_directory}/w59.flambda.reference" -flags = "-w +A-70 -dflambda-invariants" -** setup-ocamlopt.byte-build-env -*** ocamlopt.byte -**** check-ocamlopt.byte-output - -*) - -(* Check that the warning 59 (assignment to immutable value) does not - trigger on those examples *) -let a = Lazy.force (lazy "a") -let b = Lazy.force (lazy 1) -let c = Lazy.force (lazy 3.14) -let d = Lazy.force (lazy 'a') -let e = Lazy.force (lazy (fun x -> x+1)) -let rec f (x:int) : int = g x and g x = f x -let h = Lazy.force (lazy f) -let i = Lazy.force (lazy g) -let j = Lazy.force (lazy 1L) -let k = Lazy.force (lazy (1,2)) -let l = Lazy.force (lazy [|3.14|]) -let m = Lazy.force (lazy (Sys.opaque_identity 3.14)) -let n = Lazy.force (lazy None) - -(* Check that obviously wrong code is reported *) -let o = (1,2) -let p = fun x -> x -let q = 3.14 -let r = 1 - -(* %obj_set_field is OK here for Flambda 2 because we never use - it on an array. We can't use Obj.field since that function - contains a [Sys.opaque_identity]. *) -external set_field : Obj.t -> int -> Obj.t -> unit = "%obj_set_field" - -let () = - set_field (Obj.repr o) 0 (Obj.repr 3); - set_field (Obj.repr p) 0 (Obj.repr 3); - set_field (Obj.repr q) 0 (Obj.repr 3); - set_field (Obj.repr r) 0 (Obj.repr 3) - -let set v = - set_field (Obj.repr v) 0 (Obj.repr 3) - [@@inline] - -let () = - set o - -(* Sys.opaque_identity hides all information and shouldn't warn *) - -let opaque = Sys.opaque_identity (1,2) -let set_opaque = - set_field - (Obj.repr opaque) - 0 - (Obj.repr 3) diff --git a/ocaml/testsuite/tests/warnings/w68.compilers.reference b/ocaml/testsuite/tests/warnings/w68.compilers.reference index e46c213fc03..8f34f8b8304 100644 --- a/ocaml/testsuite/tests/warnings/w68.compilers.reference +++ b/ocaml/testsuite/tests/warnings/w68.compilers.reference @@ -1,18 +1,18 @@ -File "w68.ml", line 34, characters 33-43: -34 | let dont_warn_with_partial_match None x = x +File "w68.ml", line 36, characters 33-43: +36 | let dont_warn_with_partial_match None x = x ^^^^^^^^^^ Warning 8 [partial-match]: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: Some _ -File "w68.ml", line 14, characters 10-13: -14 | let alloc {a} b = a + b +File "w68.ml", line 16, characters 10-13: +16 | let alloc {a} b = a + b ^^^ Warning 68 [match-on-mutable-state-prevent-uncurry]: This pattern depends on mutable state. It prevents the remaining arguments from being uncurried, which will cause additional closure allocations. -File "w68.ml", line 39, characters 25-28: -39 | let do_warn_when_enabled {a} b = a + b +File "w68.ml", line 41, characters 25-28: +41 | let do_warn_when_enabled {a} b = a + b ^^^ Warning 68 [match-on-mutable-state-prevent-uncurry]: This pattern depends on mutable state. It prevents the remaining arguments from being uncurried, which will cause additional closure allocations. diff --git a/ocaml/testsuite/tests/warnings/w68.ml b/ocaml/testsuite/tests/warnings/w68.ml index 71ca09516bd..0d8e8386eb0 100644 --- a/ocaml/testsuite/tests/warnings/w68.ml +++ b/ocaml/testsuite/tests/warnings/w68.ml @@ -9,6 +9,8 @@ flags = "-w +A-70" ***** check-program-output *) +[@@@ocaml.flambda_oclassic] + type a = { mutable a : int } let alloc {a} b = a + b diff --git a/testsuite/flambda2-test-list b/testsuite/flambda2-test-list index 738abb9e91d..250471c4871 100644 --- a/testsuite/flambda2-test-list +++ b/testsuite/flambda2-test-list @@ -1,6 +1,2 @@ # excluded test | status | reason for not running / failure # ------------------------------------------------------------------------------------------------ - tests/asmcomp FAIL - tests/float-unboxing FAIL (FIXME) 'float_subst_boxed_number.ml' see flambdatest/mlexamples/float_unboxing.ml for a simplified error example. Should be fixed with unboxing in to_cmm - tests/statmemprof FAIL Stack traces differ - tests/warnings FAIL 'w55.ml' (@inline attribute), 'w59.ml' (missing warnings when using Obj functions) diff --git a/tools/flambda_backend_objinfo.ml b/tools/flambda_backend_objinfo.ml index 1e6a52d03b5..0965290b85c 100644 --- a/tools/flambda_backend_objinfo.ml +++ b/tools/flambda_backend_objinfo.ml @@ -193,28 +193,6 @@ let print_cmx_infos (uir, sections, crc) = (fun f -> Array.iter f uir.uir_imports_cmx); begin match uir.uir_export_info with - | Clambda_raw approx -> - if not !no_approx - then begin - printf "Clambda approximation:\n"; - Format.fprintf Format.std_formatter " %a@." Printclambda.approx approx - end - else Format.printf "Clambda unit@." - | Flambda1_raw export -> - if (not !no_approx) || not !no_code - then printf "Flambda export information:\n" - else printf "Flambda unit\n"; - if not !no_approx - then begin - Compilation_unit.set_current (Some uir.uir_unit); - let root_symbols = - List.map Symbol.for_compilation_unit uir.uir_defines - in - Format.printf "approximations@ %a@.@." Export_info.print_approx - (export, root_symbols) - end; - if not !no_code - then Format.printf "functions@ %a@.@." Export_info.print_functions export | Flambda2_raw None -> printf "Flambda 2 unit (with no export information)\n" | Flambda2_raw (Some cmx) ->