Move some code from Asmgen to the middle end directory etc. (#2288)

Followup to (#2281)
master
Mark Shinwell 2019-05-10 15:11:22 +02:00 committed by Pierre Chambart
parent 12cfc54013
commit 6cbdfad125
25 changed files with 422 additions and 281 deletions

79
.depend
View File

@ -1916,9 +1916,7 @@ asmcomp/arch.cmx : \
utils/config.cmx \ utils/config.cmx \
utils/clflags.cmx utils/clflags.cmx
asmcomp/asmgen.cmo : \ asmcomp/asmgen.cmo : \
middle_end/flambda/un_anf.cmi \
lambda/translmod.cmi \ lambda/translmod.cmi \
middle_end/symbol.cmi \
asmcomp/split.cmi \ asmcomp/split.cmi \
asmcomp/spill.cmi \ asmcomp/spill.cmi \
asmcomp/selection.cmi \ asmcomp/selection.cmi \
@ -1930,22 +1928,17 @@ asmcomp/asmgen.cmo : \
asmcomp/printmach.cmi \ asmcomp/printmach.cmi \
asmcomp/printlinear.cmi \ asmcomp/printlinear.cmi \
asmcomp/printcmm.cmi \ asmcomp/printcmm.cmi \
middle_end/printclambda.cmi \
typing/primitive.cmi \ typing/primitive.cmi \
typing/path.cmi \
utils/misc.cmi \ utils/misc.cmi \
asmcomp/mach.cmi \ asmcomp/mach.cmi \
parsing/location.cmi \ parsing/location.cmi \
asmcomp/liveness.cmi \ asmcomp/liveness.cmi \
asmcomp/linscan.cmi \ asmcomp/linscan.cmi \
middle_end/linkage_name.cmi \
asmcomp/linearize.cmi \ asmcomp/linearize.cmi \
lambda/lambda.cmi \ lambda/lambda.cmi \
asmcomp/interval.cmi \ asmcomp/interval.cmi \
asmcomp/interf.cmi \ asmcomp/interf.cmi \
typing/ident.cmi \ typing/ident.cmi \
middle_end/flambda/flambda_to_clambda.cmi \
middle_end/flambda/flambda.cmi \
asmcomp/emitaux.cmi \ asmcomp/emitaux.cmi \
asmcomp/emit.cmi \ asmcomp/emit.cmi \
asmcomp/deadcode.cmi \ asmcomp/deadcode.cmi \
@ -1955,17 +1948,14 @@ asmcomp/asmgen.cmo : \
asmcomp/coloring.cmi \ asmcomp/coloring.cmi \
asmcomp/cmmgen.cmi \ asmcomp/cmmgen.cmi \
asmcomp/cmm.cmi \ asmcomp/cmm.cmi \
middle_end/closure/closure.cmi \
utils/clflags.cmi \ utils/clflags.cmi \
middle_end/clambda.cmi \ middle_end/clambda.cmi \
asmcomp/CSE.cmo \ asmcomp/CSE.cmo \
middle_end/flambda/build_export_info.cmi \ middle_end/backend_intf.cmi \
asmcomp/debug/available_regs.cmi \ asmcomp/debug/available_regs.cmi \
asmcomp/asmgen.cmi asmcomp/asmgen.cmi
asmcomp/asmgen.cmx : \ asmcomp/asmgen.cmx : \
middle_end/flambda/un_anf.cmx \
lambda/translmod.cmx \ lambda/translmod.cmx \
middle_end/symbol.cmx \
asmcomp/split.cmx \ asmcomp/split.cmx \
asmcomp/spill.cmx \ asmcomp/spill.cmx \
asmcomp/selection.cmx \ asmcomp/selection.cmx \
@ -1977,22 +1967,17 @@ asmcomp/asmgen.cmx : \
asmcomp/printmach.cmx \ asmcomp/printmach.cmx \
asmcomp/printlinear.cmx \ asmcomp/printlinear.cmx \
asmcomp/printcmm.cmx \ asmcomp/printcmm.cmx \
middle_end/printclambda.cmx \
typing/primitive.cmx \ typing/primitive.cmx \
typing/path.cmx \
utils/misc.cmx \ utils/misc.cmx \
asmcomp/mach.cmx \ asmcomp/mach.cmx \
parsing/location.cmx \ parsing/location.cmx \
asmcomp/liveness.cmx \ asmcomp/liveness.cmx \
asmcomp/linscan.cmx \ asmcomp/linscan.cmx \
middle_end/linkage_name.cmx \
asmcomp/linearize.cmx \ asmcomp/linearize.cmx \
lambda/lambda.cmx \ lambda/lambda.cmx \
asmcomp/interval.cmx \ asmcomp/interval.cmx \
asmcomp/interf.cmx \ asmcomp/interf.cmx \
typing/ident.cmx \ typing/ident.cmx \
middle_end/flambda/flambda_to_clambda.cmx \
middle_end/flambda/flambda.cmx \
asmcomp/emitaux.cmx \ asmcomp/emitaux.cmx \
asmcomp/emit.cmx \ asmcomp/emit.cmx \
asmcomp/deadcode.cmx \ asmcomp/deadcode.cmx \
@ -2002,18 +1987,16 @@ asmcomp/asmgen.cmx : \
asmcomp/coloring.cmx \ asmcomp/coloring.cmx \
asmcomp/cmmgen.cmx \ asmcomp/cmmgen.cmx \
asmcomp/cmm.cmx \ asmcomp/cmm.cmx \
middle_end/closure/closure.cmx \
utils/clflags.cmx \ utils/clflags.cmx \
middle_end/clambda.cmx \ middle_end/clambda.cmx \
asmcomp/CSE.cmx \ asmcomp/CSE.cmx \
middle_end/flambda/build_export_info.cmx \ middle_end/backend_intf.cmi \
asmcomp/debug/available_regs.cmx \ asmcomp/debug/available_regs.cmx \
asmcomp/asmgen.cmi asmcomp/asmgen.cmi
asmcomp/asmgen.cmi : \ asmcomp/asmgen.cmi : \
lambda/lambda.cmi \ lambda/lambda.cmi \
typing/ident.cmi \
middle_end/flambda/flambda.cmi \
asmcomp/cmm.cmi \ asmcomp/cmm.cmi \
middle_end/clambda.cmi \
middle_end/backend_intf.cmi middle_end/backend_intf.cmi
asmcomp/asmlibrarian.cmo : \ asmcomp/asmlibrarian.cmo : \
utils/misc.cmi \ utils/misc.cmi \
@ -2098,6 +2081,7 @@ asmcomp/asmpackager.cmo : \
middle_end/compilenv.cmi \ middle_end/compilenv.cmi \
middle_end/compilation_unit.cmi \ middle_end/compilation_unit.cmi \
file_formats/cmx_format.cmi \ file_formats/cmx_format.cmi \
middle_end/closure/closure_middle_end.cmi \
utils/clflags.cmi \ utils/clflags.cmi \
utils/ccomp.cmi \ utils/ccomp.cmi \
asmcomp/asmlink.cmi \ asmcomp/asmlink.cmi \
@ -2120,6 +2104,7 @@ asmcomp/asmpackager.cmx : \
middle_end/compilenv.cmx \ middle_end/compilenv.cmx \
middle_end/compilation_unit.cmx \ middle_end/compilation_unit.cmx \
file_formats/cmx_format.cmi \ file_formats/cmx_format.cmi \
middle_end/closure/closure_middle_end.cmx \
utils/clflags.cmx \ utils/clflags.cmx \
utils/ccomp.cmx \ utils/ccomp.cmx \
asmcomp/asmlink.cmx \ asmcomp/asmlink.cmx \
@ -3548,6 +3533,30 @@ middle_end/closure/closure.cmi : \
lambda/lambda.cmi \ lambda/lambda.cmi \
middle_end/clambda.cmi \ middle_end/clambda.cmi \
middle_end/backend_intf.cmi middle_end/backend_intf.cmi
middle_end/closure/closure_middle_end.cmo : \
middle_end/printclambda.cmi \
typing/path.cmi \
lambda/lambda.cmi \
typing/ident.cmi \
middle_end/compilenv.cmi \
middle_end/closure/closure.cmi \
utils/clflags.cmi \
middle_end/clambda.cmi \
middle_end/closure/closure_middle_end.cmi
middle_end/closure/closure_middle_end.cmx : \
middle_end/printclambda.cmx \
typing/path.cmx \
lambda/lambda.cmx \
typing/ident.cmx \
middle_end/compilenv.cmx \
middle_end/closure/closure.cmx \
utils/clflags.cmx \
middle_end/clambda.cmx \
middle_end/closure/closure_middle_end.cmi
middle_end/closure/closure_middle_end.cmi : \
lambda/lambda.cmi \
middle_end/clambda.cmi \
middle_end/backend_intf.cmi
middle_end/flambda/alias_analysis.cmo : \ middle_end/flambda/alias_analysis.cmo : \
middle_end/variable.cmi \ middle_end/variable.cmi \
middle_end/flambda/base_types/var_within_closure.cmi \ middle_end/flambda/base_types/var_within_closure.cmi \
@ -4071,65 +4080,81 @@ middle_end/flambda/flambda_iterators.cmi : \
middle_end/flambda/flambda_middle_end.cmo : \ middle_end/flambda/flambda_middle_end.cmo : \
utils/warnings.cmi \ utils/warnings.cmi \
middle_end/variable.cmi \ middle_end/variable.cmi \
middle_end/flambda/un_anf.cmi \
middle_end/symbol.cmi \ middle_end/symbol.cmi \
middle_end/flambda/share_constants.cmi \ middle_end/flambda/share_constants.cmi \
middle_end/flambda/remove_unused_program_constructs.cmi \ middle_end/flambda/remove_unused_program_constructs.cmi \
middle_end/flambda/remove_unused_closure_vars.cmi \ middle_end/flambda/remove_unused_closure_vars.cmi \
middle_end/flambda/ref_to_variables.cmi \ middle_end/flambda/ref_to_variables.cmi \
utils/profile.cmi \ utils/profile.cmi \
middle_end/printclambda.cmi \
utils/misc.cmi \ utils/misc.cmi \
parsing/location.cmi \ parsing/location.cmi \
middle_end/linkage_name.cmi \
middle_end/flambda/lift_let_to_initialize_symbol.cmi \ middle_end/flambda/lift_let_to_initialize_symbol.cmi \
middle_end/flambda/lift_constants.cmi \ middle_end/flambda/lift_constants.cmi \
middle_end/flambda/lift_code.cmi \ middle_end/flambda/lift_code.cmi \
lambda/lambda.cmi \
utils/int_replace_polymorphic_compare.cmi \ utils/int_replace_polymorphic_compare.cmi \
middle_end/flambda/inlining_cost.cmi \ middle_end/flambda/inlining_cost.cmi \
middle_end/flambda/inline_and_simplify.cmi \ middle_end/flambda/inline_and_simplify.cmi \
middle_end/flambda/initialize_symbol_to_let_symbol.cmi \ middle_end/flambda/initialize_symbol_to_let_symbol.cmi \
middle_end/flambda/flambda_to_clambda.cmi \
middle_end/flambda/flambda_iterators.cmi \ middle_end/flambda/flambda_iterators.cmi \
middle_end/flambda/flambda_invariants.cmi \ middle_end/flambda/flambda_invariants.cmi \
middle_end/flambda/flambda.cmi \ middle_end/flambda/flambda.cmi \
lambda/debuginfo.cmi \ lambda/debuginfo.cmi \
middle_end/compilenv.cmi \
middle_end/flambda/base_types/closure_id.cmi \ middle_end/flambda/base_types/closure_id.cmi \
middle_end/flambda/closure_conversion.cmi \ middle_end/flambda/closure_conversion.cmi \
utils/clflags.cmi \ utils/clflags.cmi \
middle_end/clambda.cmi \
middle_end/flambda/build_export_info.cmi \
middle_end/backend_intf.cmi \ middle_end/backend_intf.cmi \
middle_end/flambda/flambda_middle_end.cmi middle_end/flambda/flambda_middle_end.cmi
middle_end/flambda/flambda_middle_end.cmx : \ middle_end/flambda/flambda_middle_end.cmx : \
utils/warnings.cmx \ utils/warnings.cmx \
middle_end/variable.cmx \ middle_end/variable.cmx \
middle_end/flambda/un_anf.cmx \
middle_end/symbol.cmx \ middle_end/symbol.cmx \
middle_end/flambda/share_constants.cmx \ middle_end/flambda/share_constants.cmx \
middle_end/flambda/remove_unused_program_constructs.cmx \ middle_end/flambda/remove_unused_program_constructs.cmx \
middle_end/flambda/remove_unused_closure_vars.cmx \ middle_end/flambda/remove_unused_closure_vars.cmx \
middle_end/flambda/ref_to_variables.cmx \ middle_end/flambda/ref_to_variables.cmx \
utils/profile.cmx \ utils/profile.cmx \
middle_end/printclambda.cmx \
utils/misc.cmx \ utils/misc.cmx \
parsing/location.cmx \ parsing/location.cmx \
middle_end/linkage_name.cmx \
middle_end/flambda/lift_let_to_initialize_symbol.cmx \ middle_end/flambda/lift_let_to_initialize_symbol.cmx \
middle_end/flambda/lift_constants.cmx \ middle_end/flambda/lift_constants.cmx \
middle_end/flambda/lift_code.cmx \ middle_end/flambda/lift_code.cmx \
lambda/lambda.cmx \
utils/int_replace_polymorphic_compare.cmx \ utils/int_replace_polymorphic_compare.cmx \
middle_end/flambda/inlining_cost.cmx \ middle_end/flambda/inlining_cost.cmx \
middle_end/flambda/inline_and_simplify.cmx \ middle_end/flambda/inline_and_simplify.cmx \
middle_end/flambda/initialize_symbol_to_let_symbol.cmx \ middle_end/flambda/initialize_symbol_to_let_symbol.cmx \
middle_end/flambda/flambda_to_clambda.cmx \
middle_end/flambda/flambda_iterators.cmx \ middle_end/flambda/flambda_iterators.cmx \
middle_end/flambda/flambda_invariants.cmx \ middle_end/flambda/flambda_invariants.cmx \
middle_end/flambda/flambda.cmx \ middle_end/flambda/flambda.cmx \
lambda/debuginfo.cmx \ lambda/debuginfo.cmx \
middle_end/compilenv.cmx \
middle_end/flambda/base_types/closure_id.cmx \ middle_end/flambda/base_types/closure_id.cmx \
middle_end/flambda/closure_conversion.cmx \ middle_end/flambda/closure_conversion.cmx \
utils/clflags.cmx \ utils/clflags.cmx \
middle_end/clambda.cmx \
middle_end/flambda/build_export_info.cmx \
middle_end/backend_intf.cmi \ middle_end/backend_intf.cmi \
middle_end/flambda/flambda_middle_end.cmi middle_end/flambda/flambda_middle_end.cmi
middle_end/flambda/flambda_middle_end.cmi : \ middle_end/flambda/flambda_middle_end.cmi : \
lambda/lambda.cmi \ lambda/lambda.cmi \
typing/ident.cmi \ middle_end/clambda.cmi \
middle_end/flambda/flambda.cmi \
middle_end/backend_intf.cmi middle_end/backend_intf.cmi
middle_end/flambda/flambda_to_clambda.cmo : \ middle_end/flambda/flambda_to_clambda.cmo : \
middle_end/variable.cmi \ middle_end/variable.cmi \
middle_end/flambda/base_types/var_within_closure.cmi \ middle_end/flambda/base_types/var_within_closure.cmi \
middle_end/flambda/un_anf.cmi \
middle_end/flambda/base_types/tag.cmi \ middle_end/flambda/base_types/tag.cmi \
middle_end/symbol.cmi \ middle_end/symbol.cmi \
middle_end/flambda/base_types/static_exception.cmi \ middle_end/flambda/base_types/static_exception.cmi \
@ -4148,6 +4173,7 @@ middle_end/flambda/flambda_to_clambda.cmo : \
middle_end/flambda/export_info.cmi \ middle_end/flambda/export_info.cmi \
lambda/debuginfo.cmi \ lambda/debuginfo.cmi \
middle_end/compilenv.cmi \ middle_end/compilenv.cmi \
middle_end/compilation_unit.cmi \
middle_end/flambda/closure_offsets.cmi \ middle_end/flambda/closure_offsets.cmi \
middle_end/flambda/base_types/closure_id.cmi \ middle_end/flambda/base_types/closure_id.cmi \
utils/clflags.cmi \ utils/clflags.cmi \
@ -4158,6 +4184,7 @@ middle_end/flambda/flambda_to_clambda.cmo : \
middle_end/flambda/flambda_to_clambda.cmx : \ middle_end/flambda/flambda_to_clambda.cmx : \
middle_end/variable.cmx \ middle_end/variable.cmx \
middle_end/flambda/base_types/var_within_closure.cmx \ middle_end/flambda/base_types/var_within_closure.cmx \
middle_end/flambda/un_anf.cmx \
middle_end/flambda/base_types/tag.cmx \ middle_end/flambda/base_types/tag.cmx \
middle_end/symbol.cmx \ middle_end/symbol.cmx \
middle_end/flambda/base_types/static_exception.cmx \ middle_end/flambda/base_types/static_exception.cmx \
@ -4176,6 +4203,7 @@ middle_end/flambda/flambda_to_clambda.cmx : \
middle_end/flambda/export_info.cmx \ middle_end/flambda/export_info.cmx \
lambda/debuginfo.cmx \ lambda/debuginfo.cmx \
middle_end/compilenv.cmx \ middle_end/compilenv.cmx \
middle_end/compilation_unit.cmx \
middle_end/flambda/closure_offsets.cmx \ middle_end/flambda/closure_offsets.cmx \
middle_end/flambda/base_types/closure_id.cmx \ middle_end/flambda/base_types/closure_id.cmx \
utils/clflags.cmx \ utils/clflags.cmx \
@ -5154,6 +5182,7 @@ middle_end/flambda/traverse_for_exported_symbols.cmi : \
middle_end/flambda/base_types/export_id.cmi \ middle_end/flambda/base_types/export_id.cmi \
middle_end/flambda/base_types/closure_id.cmi middle_end/flambda/base_types/closure_id.cmi
middle_end/flambda/un_anf.cmo : \ middle_end/flambda/un_anf.cmo : \
middle_end/symbol.cmi \
middle_end/semantics_of_primitives.cmi \ middle_end/semantics_of_primitives.cmi \
middle_end/printclambda.cmi \ middle_end/printclambda.cmi \
utils/misc.cmi \ utils/misc.cmi \
@ -5166,6 +5195,7 @@ middle_end/flambda/un_anf.cmo : \
parsing/asttypes.cmi \ parsing/asttypes.cmi \
middle_end/flambda/un_anf.cmi middle_end/flambda/un_anf.cmi
middle_end/flambda/un_anf.cmx : \ middle_end/flambda/un_anf.cmx : \
middle_end/symbol.cmx \
middle_end/semantics_of_primitives.cmx \ middle_end/semantics_of_primitives.cmx \
middle_end/printclambda.cmx \ middle_end/printclambda.cmx \
utils/misc.cmx \ utils/misc.cmx \
@ -5178,6 +5208,7 @@ middle_end/flambda/un_anf.cmx : \
parsing/asttypes.cmi \ parsing/asttypes.cmi \
middle_end/flambda/un_anf.cmi middle_end/flambda/un_anf.cmi
middle_end/flambda/un_anf.cmi : \ middle_end/flambda/un_anf.cmi : \
middle_end/symbol.cmi \
middle_end/clambda.cmi middle_end/clambda.cmi
middle_end/flambda/unbox_closures.cmo : \ middle_end/flambda/unbox_closures.cmo : \
middle_end/variable.cmi \ middle_end/variable.cmi \
@ -5695,6 +5726,7 @@ driver/optcompile.cmo : \
utils/config.cmi \ utils/config.cmi \
middle_end/compilenv.cmi \ middle_end/compilenv.cmi \
driver/compile_common.cmi \ driver/compile_common.cmi \
middle_end/closure/closure_middle_end.cmi \
utils/clflags.cmi \ utils/clflags.cmi \
asmcomp/asmgen.cmi \ asmcomp/asmgen.cmi \
driver/optcompile.cmi driver/optcompile.cmi
@ -5709,6 +5741,7 @@ driver/optcompile.cmx : \
utils/config.cmx \ utils/config.cmx \
middle_end/compilenv.cmx \ middle_end/compilenv.cmx \
driver/compile_common.cmx \ driver/compile_common.cmx \
middle_end/closure/closure_middle_end.cmx \
utils/clflags.cmx \ utils/clflags.cmx \
asmcomp/asmgen.cmx \ asmcomp/asmgen.cmx \
driver/optcompile.cmi driver/optcompile.cmi
@ -5912,6 +5945,7 @@ toplevel/opttoploop.cmo : \
driver/compmisc.cmi \ driver/compmisc.cmi \
middle_end/compilenv.cmi \ middle_end/compilenv.cmi \
driver/compenv.cmi \ driver/compenv.cmi \
middle_end/closure/closure_middle_end.cmi \
utils/clflags.cmi \ utils/clflags.cmi \
typing/btype.cmi \ typing/btype.cmi \
middle_end/backend_intf.cmi \ middle_end/backend_intf.cmi \
@ -5958,6 +5992,7 @@ toplevel/opttoploop.cmx : \
driver/compmisc.cmx \ driver/compmisc.cmx \
middle_end/compilenv.cmx \ middle_end/compilenv.cmx \
driver/compenv.cmx \ driver/compenv.cmx \
middle_end/closure/closure_middle_end.cmx \
utils/clflags.cmx \ utils/clflags.cmx \
typing/btype.cmx \ typing/btype.cmx \
middle_end/backend_intf.cmi \ middle_end/backend_intf.cmi \

View File

@ -146,7 +146,7 @@ OCaml 4.09.0
(Mark Shinwell, review by Vincent Laviron) (Mark Shinwell, review by Vincent Laviron)
- #2281: Move some middle-end files around - #2281: Move some middle-end files around
(Mark Shinwell) (Mark Shinwell, review by Pierre Chambart and Vincent Laviron)
- #2283: Add [is_prefix] and [find_and_chop_longest_common_prefix] to - #2283: Add [is_prefix] and [find_and_chop_longest_common_prefix] to
[Misc.Stdlib.List] [Misc.Stdlib.List]
@ -159,6 +159,10 @@ OCaml 4.09.0
- #2286: Functorise [Consistbl] - #2286: Functorise [Consistbl]
(Mark Shinwell, review by Gabriel Radanne) (Mark Shinwell, review by Gabriel Radanne)
- #2288: Move middle end code from [Asmgen] to [Clambda_middle_end] and
[Flambda_middle_end]. Run [Un_anf] from the middle end, not [Cmmgen].
(Mark Shinwell, review by Pierre Chambart)
- #2291: Add [Compute_ranges] pass - #2291: Add [Compute_ranges] pass
(Mark Shinwell, review by Vincent Laviron) (Mark Shinwell, review by Vincent Laviron)

View File

@ -189,7 +189,8 @@ ASMCOMP=\
# the native code compiler is not present for some particular target. # the native code compiler is not present for some particular target.
MIDDLE_END_CLOSURE=\ MIDDLE_END_CLOSURE=\
middle_end/closure/closure.cmo middle_end/closure/closure.cmo \
middle_end/closure/closure_middle_end.cmo
# Owing to dependencies through [Compilenv], which would be # Owing to dependencies through [Compilenv], which would be
# difficult to remove, some of the lower parts of Flambda (anything that is # difficult to remove, some of the lower parts of Flambda (anything that is

View File

@ -39,41 +39,6 @@ let pass_dump_linear_if ppf flag message phrase =
if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase; if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase;
phrase phrase
let flambda_raw_clambda_dump_if ppf
({ Flambda_to_clambda. expr = ulambda; preallocated_blocks = _;
structured_constants; exported = _; } as input) =
if !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 !dump_cmm then Format.fprintf ppf "@.cmm:@.";
input
type clambda_and_constants =
Clambda.ulambda *
Clambda.preallocated_block list *
Clambda.preallocated_constant list
let raw_clambda_dump_if ppf
((ulambda, _, structured_constants):clambda_and_constants) =
if !dump_rawclambda || !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 !dump_cmm then Format.fprintf ppf "@.cmm:@."
let rec regalloc ~ppf_dump round fd = let rec regalloc ~ppf_dump round fd =
if round > 50 then if round > 50 then
fatal_error(fd.Mach.fun_name ^ fatal_error(fd.Mach.fun_name ^
@ -102,7 +67,6 @@ let (++) x f = f x
let compile_fundecl ~ppf_dump fd_cmm = let compile_fundecl ~ppf_dump fd_cmm =
Proc.init (); Proc.init ();
Cmmgen.reset ();
Reg.reset(); Reg.reset();
fd_cmm fd_cmm
++ Profile.record ~accumulate:true "selection" Selection.fundecl ++ Profile.record ~accumulate:true "selection" Selection.fundecl
@ -145,8 +109,7 @@ let compile_genfuns ~ppf_dump f =
| _ -> ()) | _ -> ())
(Cmmgen.generic_functions true [Compilenv.current_unit_infos ()]) (Cmmgen.generic_functions true [Compilenv.current_unit_infos ()])
let compile_unit _output_prefix asm_filename keep_asm let compile_unit asm_filename keep_asm obj_filename gen =
obj_filename gen =
let create_asm = keep_asm || not !Emitaux.binary_backend_available in let create_asm = keep_asm || not !Emitaux.binary_backend_available in
Emitaux.create_asm_file := create_asm; Emitaux.create_asm_file := create_asm;
Misc.try_finally Misc.try_finally
@ -167,109 +130,49 @@ let compile_unit _output_prefix asm_filename keep_asm
if create_asm && not keep_asm then remove_file asm_filename if create_asm && not keep_asm then remove_file asm_filename
) )
let set_export_info (ulambda, prealloc, structured_constants, export) =
Compilenv.set_export_info export;
(ulambda, prealloc, structured_constants)
let end_gen_implementation ?toplevel ~ppf_dump let end_gen_implementation ?toplevel ~ppf_dump
(clambda:clambda_and_constants) = (clambda : Clambda.with_constants) =
Emit.begin_assembly (); Emit.begin_assembly ();
clambda clambda
++ Profile.record "cmm" (Cmmgen.compunit ~ppf_dump) ++ Profile.record "cmm" Cmmgen.compunit
++ Profile.record "compile_phrases" (List.iter (compile_phrase ~ppf_dump)) ++ Profile.record "compile_phrases" (List.iter (compile_phrase ~ppf_dump))
++ (fun () -> ()); ++ (fun () -> ());
(match toplevel with None -> () | Some f -> compile_genfuns ~ppf_dump f); (match toplevel with None -> () | Some f -> compile_genfuns ~ppf_dump f);
(* We add explicit references to external primitive symbols. This (* We add explicit references to external primitive symbols. This
is to ensure that the object files that define these symbols, is to ensure that the object files that define these symbols,
when part of a C library, won't be discarded by the linker. when part of a C library, won't be discarded by the linker.
This is important if a module that uses such a symbol is later This is important if a module that uses such a symbol is later
dynlinked. *) dynlinked. *)
compile_phrase ~ppf_dump compile_phrase ~ppf_dump
(Cmmgen.reference_symbols (Cmmgen.reference_symbols
(List.filter (fun s -> s <> "" && s.[0] <> '%') (List.filter_map (fun prim ->
(List.map Primitive.native_name !Translmod.primitive_declarations)) if not (Primitive.native_name_is_external prim) then None
); else Some (Primitive.native_name prim))
!Translmod.primitive_declarations));
Emit.end_assembly () Emit.end_assembly ()
let flambda_gen_implementation ?toplevel ~backend ~ppf_dump type middle_end =
(program:Flambda.program) = backend:(module Backend_intf.S)
let export = Build_export_info.build_transient ~backend program in -> filename:string
let (clambda, preallocated, constants) = -> prefixname:string
Profile.record_call "backend" (fun () -> -> ppf_dump:Format.formatter
(program, export) -> Lambda.program
++ Flambda_to_clambda.convert -> Clambda.with_constants
++ flambda_raw_clambda_dump_if ppf_dump
++ (fun { Flambda_to_clambda. expr; preallocated_blocks;
structured_constants; exported; } ->
(* "init_code" following the name used in
[Cmmgen.compunit_and_constants]. *)
Un_anf.apply ~ppf_dump expr ~what:"init_code", preallocated_blocks,
structured_constants, exported)
++ set_export_info)
in
let constants =
List.map (fun (symbol, definition) ->
{ Clambda.symbol = Linkage_name.to_string (Symbol.label symbol);
exported = true;
definition;
provenance = None;
})
(Symbol.Map.bindings constants)
in
end_gen_implementation ?toplevel ~ppf_dump
(clambda, preallocated, constants)
let lambda_gen_implementation ?toplevel ~backend ~ppf_dump let compile_implementation ?toplevel ~backend ~filename ~prefixname ~middle_end
(lambda:Lambda.program) = ~ppf_dump (program : Lambda.program) =
let clambda =
Closure.intro ~backend ~size:lambda.main_module_block_size lambda.code
in
let provenance : Clambda.usymbol_provenance =
{ original_idents = [];
module_path =
Path.Pident (Ident.create_persistent (Compilenv.current_unit_name ()));
}
in
let preallocated_block =
Clambda.{
symbol = Compilenv.make_symbol None;
exported = true;
tag = 0;
fields = List.init lambda.main_module_block_size (fun _ -> None);
provenance = Some provenance;
}
in
let clambda_and_constants =
clambda, [preallocated_block], Compilenv.structured_constants ()
in
Compilenv.clear_structured_constants ();
raw_clambda_dump_if ppf_dump clambda_and_constants;
end_gen_implementation ?toplevel ~ppf_dump clambda_and_constants
let compile_implementation_gen ?toplevel prefixname
~required_globals ~ppf_dump gen_implementation program =
let asmfile = let asmfile =
if !keep_asm_file || !Emitaux.binary_backend_available if !keep_asm_file || !Emitaux.binary_backend_available
then prefixname ^ ext_asm then prefixname ^ ext_asm
else Filename.temp_file "camlasm" ext_asm else Filename.temp_file "camlasm" ext_asm
in in
compile_unit prefixname asmfile !keep_asm_file compile_unit asmfile !keep_asm_file (prefixname ^ ext_obj)
(prefixname ^ ext_obj) (fun () -> (fun () ->
Ident.Set.iter Compilenv.require_global required_globals; Ident.Set.iter Compilenv.require_global program.required_globals;
gen_implementation ?toplevel ~ppf_dump program) let clambda_with_constants =
middle_end ~backend ~filename ~prefixname ~ppf_dump program
let compile_implementation_clambda ?toplevel prefixname in
~backend ~ppf_dump (program:Lambda.program) = end_gen_implementation ?toplevel ~ppf_dump clambda_with_constants)
compile_implementation_gen ?toplevel prefixname
~required_globals:program.Lambda.required_globals
~ppf_dump (lambda_gen_implementation ~backend) program
let compile_implementation_flambda ?toplevel prefixname
~required_globals ~backend ~ppf_dump (program:Flambda.program) =
compile_implementation_gen ?toplevel prefixname
~required_globals ~ppf_dump (flambda_gen_implementation ~backend) program
(* Error report *) (* Error report *)

View File

@ -13,20 +13,27 @@
(* *) (* *)
(**************************************************************************) (**************************************************************************)
(* From lambda to assembly code *) (** From Lambda to assembly code *)
val compile_implementation_flambda : (** The type of converters from Lambda to Clambda. *)
?toplevel:(string -> bool) -> type middle_end =
string -> backend:(module Backend_intf.S)
required_globals:Ident.Set.t -> -> filename:string
backend:(module Backend_intf.S) -> -> prefixname:string
ppf_dump:Format.formatter -> Flambda.program -> unit -> ppf_dump:Format.formatter
-> Lambda.program
-> Clambda.with_constants
val compile_implementation_clambda : (** Compile an implementation from Lambda using the given middle end. *)
?toplevel:(string -> bool) -> val compile_implementation
string -> : ?toplevel:(string -> bool)
backend:(module Backend_intf.S) -> -> backend:(module Backend_intf.S)
ppf_dump:Format.formatter -> Lambda.program -> unit -> filename:string
-> prefixname:string
-> middle_end:middle_end
-> ppf_dump:Format.formatter
-> Lambda.program
-> unit
val compile_phrase : val compile_phrase :
ppf_dump:Format.formatter -> Cmm.phrase -> unit ppf_dump:Format.formatter -> Cmm.phrase -> unit
@ -37,6 +44,5 @@ val report_error: Format.formatter -> error -> unit
val compile_unit: val compile_unit:
string(*prefixname*) ->
string(*asm file*) -> bool(*keep asm*) -> string(*asm file*) -> bool(*keep asm*) ->
string(*obj file*) -> (unit -> unit) -> unit string(*obj file*) -> (unit -> unit) -> unit

View File

@ -287,7 +287,7 @@ let link_shared ~ppf_dump objfiles output_name =
then output_name ^ ".startup" ^ ext_asm then output_name ^ ".startup" ^ ext_asm
else Filename.temp_file "camlstartup" ext_asm in else Filename.temp_file "camlstartup" ext_asm in
let startup_obj = output_name ^ ".startup" ^ ext_obj in let startup_obj = output_name ^ ".startup" ^ ext_obj in
Asmgen.compile_unit output_name Asmgen.compile_unit
startup !Clflags.keep_startup_file startup_obj startup !Clflags.keep_startup_file startup_obj
(fun () -> (fun () ->
make_shared_startup_file ~ppf_dump make_shared_startup_file ~ppf_dump
@ -352,7 +352,7 @@ let link ~ppf_dump objfiles output_name =
then output_name ^ ".startup" ^ ext_asm then output_name ^ ".startup" ^ ext_asm
else Filename.temp_file "camlstartup" ext_asm in else Filename.temp_file "camlstartup" ext_asm in
let startup_obj = Filename.temp_file "camlstartup" ext_obj in let startup_obj = Filename.temp_file "camlstartup" ext_obj in
Asmgen.compile_unit output_name Asmgen.compile_unit
startup !Clflags.keep_startup_file startup_obj startup !Clflags.keep_startup_file startup_obj
(fun () -> make_startup_file ~ppf_dump units_tolink ~crc_interfaces); (fun () -> make_startup_file ~ppf_dump units_tolink ~crc_interfaces);
Misc.try_finally Misc.try_finally

View File

@ -99,27 +99,42 @@ let make_package_object ~ppf_dump members targetobj targetname coercion
members in members in
let module_ident = Ident.create_persistent targetname in let module_ident = Ident.create_persistent targetname in
let prefixname = Filename.remove_extension objtemp in let prefixname = Filename.remove_extension objtemp in
if Config.flambda then begin let required_globals = Ident.Set.empty in
let size, lam = Translmod.transl_package_flambda components coercion in let program, middle_end =
let flam = if Config.flambda then
Flambda_middle_end.middle_end ~ppf_dump let main_module_block_size, code =
~prefixname Translmod.transl_package_flambda components coercion
~backend in
~size let program =
~filename:targetname { Lambda.
~module_ident code;
~module_initializer:lam main_module_block_size;
in module_ident;
Asmgen.compile_implementation_flambda required_globals;
prefixname ~backend ~required_globals:Ident.Set.empty ~ppf_dump flam; }
end else begin in
let main_module_block_size, code = program, Flambda_middle_end.lambda_to_clambda
Translmod.transl_store_package else
components (Ident.create_persistent targetname) coercion in let main_module_block_size, code =
Asmgen.compile_implementation_clambda Translmod.transl_store_package components
prefixname ~backend ~ppf_dump { Lambda.code; main_module_block_size; (Ident.create_persistent targetname) coercion
module_ident; required_globals = Ident.Set.empty } in
end; let program =
{ Lambda.
code;
main_module_block_size;
module_ident;
required_globals;
}
in
program, Closure_middle_end.lambda_to_clambda
in
Asmgen.compile_implementation ~backend
~filename:targetname
~prefixname
~middle_end
~ppf_dump
program;
let objfiles = let objfiles =
List.map List.map
(fun m -> Filename.remove_extension m.pm_file ^ Config.ext_obj) (fun m -> Filename.remove_extension m.pm_file ^ Config.ext_obj)
@ -130,6 +145,7 @@ let make_package_object ~ppf_dump members targetobj targetname coercion
remove_file objtemp; remove_file objtemp;
if not ok then raise(Error Linking_error) if not ok then raise(Error Linking_error)
) )
(* Make the .cmx file for the package *) (* Make the .cmx file for the package *)
let get_export_info ui = let get_export_info ui =

View File

@ -3225,13 +3225,8 @@ and transl_letrec env bindings cont =
(* Translate a function definition *) (* Translate a function definition *)
let transl_function ~ppf_dump f = let transl_function f =
let body = let body = f.body in
if Config.flambda then
Un_anf.apply ~ppf_dump f.body ~what:f.label
else
f.body
in
let cmm_body = let cmm_body =
let env = create_env ~environment_param:f.env in let env = create_env ~environment_param:f.env in
if !Clflags.afl_instrument then if !Clflags.afl_instrument then
@ -3252,17 +3247,17 @@ let transl_function ~ppf_dump f =
(* Translate all function definitions *) (* Translate all function definitions *)
let rec transl_all_functions ~ppf_dump already_translated cont = let rec transl_all_functions already_translated cont =
match Cmmgen_state.next_function () with match Cmmgen_state.next_function () with
| None -> cont, already_translated | None -> cont, already_translated
| Some f -> | Some f ->
let sym = f.label in let sym = f.label in
if String.Set.mem sym already_translated then if String.Set.mem sym already_translated then
transl_all_functions ~ppf_dump already_translated cont transl_all_functions already_translated cont
else begin else begin
transl_all_functions ~ppf_dump transl_all_functions
(String.Set.add sym already_translated) (String.Set.add sym already_translated)
((f.dbg, transl_function ~ppf_dump f) :: cont) ((f.dbg, transl_function f) :: cont)
end end
(* Emit constant closures *) (* Emit constant closures *)
@ -3349,16 +3344,16 @@ let emit_cmm_data_items_for_constants cont =
c := (Cdata cmm) :: !c c := (Cdata cmm) :: !c
| Const_table (global, elems) -> | Const_table (global, elems) ->
c := (Cdata (emit_constant_table (symbol, global) elems)) :: !c) c := (Cdata (emit_constant_table (symbol, global) elems)) :: !c)
(Cmmgen_state.constants ()); (Cmmgen_state.get_and_clear_constants ());
Cdata (Cmmgen_state.data_items ()) :: !c Cdata (Cmmgen_state.get_and_clear_data_items ()) :: !c
let transl_all_functions ~ppf_dump cont = let transl_all_functions cont =
let rec aux already_translated cont translated_functions = let rec aux already_translated cont translated_functions =
if Cmmgen_state.no_more_functions () if Cmmgen_state.no_more_functions ()
then cont, translated_functions then cont, translated_functions
else else
let translated_functions, already_translated = let translated_functions, already_translated =
transl_all_functions ~ppf_dump already_translated translated_functions transl_all_functions already_translated translated_functions
in in
aux already_translated cont translated_functions aux already_translated cont translated_functions
in in
@ -3422,7 +3417,8 @@ let emit_preallocated_blocks preallocated_blocks cont =
(* Translate a compilation unit *) (* Translate a compilation unit *)
let compunit ~ppf_dump (ulam, preallocated_blocks, constants) = let compunit (ulam, preallocated_blocks, constants) =
assert (Cmmgen_state.no_more_functions ());
let dbg = Debuginfo.none in let dbg = Debuginfo.none in
let init_code = let init_code =
if !Clflags.afl_instrument then if !Clflags.afl_instrument then
@ -3444,7 +3440,7 @@ let compunit ~ppf_dump (ulam, preallocated_blocks, constants) =
else [ Reduce_code_size ]; else [ Reduce_code_size ];
fun_dbg = Debuginfo.none }] in fun_dbg = Debuginfo.none }] in
let c2 = transl_clambda_constants constants c1 in let c2 = transl_clambda_constants constants c1 in
let c3 = transl_all_functions ~ppf_dump c2 in let c3 = transl_all_functions c2 in
let c4 = emit_preallocated_blocks preallocated_blocks c3 in let c4 = emit_preallocated_blocks preallocated_blocks c3 in
emit_cmm_data_items_for_constants c4 emit_cmm_data_items_for_constants c4
@ -3943,6 +3939,3 @@ let plugin_header units =
} in } in
global_data "caml_plugin_header" global_data "caml_plugin_header"
{ dynu_magic = Config.cmxs_magic_number; dynu_units = List.map mk units } { dynu_magic = Config.cmxs_magic_number; dynu_units = List.map mk units }
let reset () =
Cmmgen_state.reset ()

View File

@ -15,9 +15,8 @@
(* Translation from closed lambda to C-- *) (* Translation from closed lambda to C-- *)
val compunit: val compunit
ppf_dump:Format.formatter : Clambda.ulambda
-> Clambda.ulambda
* Clambda.preallocated_block list * Clambda.preallocated_block list
* Clambda.preallocated_constant list * Clambda.preallocated_constant list
-> Cmm.phrase list -> Cmm.phrase list
@ -38,5 +37,3 @@ val code_segment_table: string list -> Cmm.phrase
val predef_exception: int -> string -> Cmm.phrase val predef_exception: int -> string -> Cmm.phrase
val plugin_header: (Cmx_format.unit_infos * Digest.t) list -> Cmm.phrase val plugin_header: (Cmx_format.unit_infos * Digest.t) list -> Cmm.phrase
val black_block_header: (*tag:*)int -> (*size:*)int -> nativeint val black_block_header: (*tag:*)int -> (*size:*)int -> nativeint
val reset : unit -> unit

View File

@ -39,11 +39,6 @@ let empty = {
let state = empty let state = empty
let reset () =
state.constants <- S.Map.empty;
state.data_items <- [];
Queue.clear state.functions
let add_constant sym cst = let add_constant sym cst =
state.constants <- S.Map.add sym cst state.constants state.constants <- S.Map.add sym cst state.constants
@ -53,9 +48,15 @@ let add_data_items items =
let add_function func = let add_function func =
Queue.add func state.functions Queue.add func state.functions
let constants () = state.constants let get_and_clear_constants () =
let constants = state.constants in
state.constants <- S.Map.empty;
constants
let data_items () = List.concat (List.rev state.data_items) let get_and_clear_data_items () =
let data_items = List.concat (List.rev state.data_items) in
state.data_items <- [];
data_items
let next_function () = let next_function () =
match Queue.take state.functions with match Queue.take state.functions with

View File

@ -19,8 +19,6 @@
[@@@ocaml.warning "+a-4-30-40-41-42"] [@@@ocaml.warning "+a-4-30-40-41-42"]
val reset : unit -> unit
type is_global = Global | Local type is_global = Global | Local
type constant = type constant =
@ -33,9 +31,9 @@ val add_data_items : Cmm.data_item list -> unit
val add_function : Clambda.ufunction -> unit val add_function : Clambda.ufunction -> unit
val constants : unit -> constant Misc.Stdlib.String.Map.t val get_and_clear_constants : unit -> constant Misc.Stdlib.String.Map.t
val data_items : unit -> Cmm.data_item list val get_and_clear_data_items : unit -> Cmm.data_item list
val next_function : unit -> Clambda.ufunction option val next_function : unit -> Clambda.ufunction option

View File

@ -48,17 +48,22 @@ let flambda i backend typed =
|>> print_if i.ppf_dump Clflags.dump_rawlambda Printlambda.lambda |>> print_if i.ppf_dump Clflags.dump_rawlambda Printlambda.lambda
|>> Simplif.simplify_lambda |>> Simplif.simplify_lambda
|>> print_if i.ppf_dump Clflags.dump_lambda Printlambda.lambda |>> print_if i.ppf_dump Clflags.dump_lambda Printlambda.lambda
|> (fun ((module_ident, size), lam) -> |> (fun ((module_ident, main_module_block_size), code) ->
Flambda_middle_end.middle_end let program : Lambda.program =
~ppf_dump:i.ppf_dump { Lambda.
~prefixname:i.output_prefix module_ident;
~size main_module_block_size;
~filename:i.source_file required_globals;
~module_ident code;
}
in
Asmgen.compile_implementation
~backend ~backend
~module_initializer:lam) ~filename:i.source_file
|> Asmgen.compile_implementation_flambda ~prefixname:i.output_prefix
i.output_prefix ~required_globals ~backend ~ppf_dump:i.ppf_dump; ~middle_end:Flambda_middle_end.lambda_to_clambda
~ppf_dump:i.ppf_dump
program);
Compilenv.save_unit_info (cmx i)) Compilenv.save_unit_info (cmx i))
let clambda i backend typed = let clambda i backend typed =
@ -72,8 +77,12 @@ let clambda i backend typed =
let code = Simplif.simplify_lambda program.Lambda.code in let code = Simplif.simplify_lambda program.Lambda.code in
{ program with Lambda.code } { program with Lambda.code }
|> print_if i.ppf_dump Clflags.dump_lambda Printlambda.program |> print_if i.ppf_dump Clflags.dump_lambda Printlambda.program
|> Asmgen.compile_implementation_clambda |> Asmgen.compile_implementation
i.output_prefix ~backend ~ppf_dump:i.ppf_dump; ~backend
~filename:i.source_file
~prefixname:i.output_prefix
~middle_end:Closure_middle_end.lambda_to_clambda
~ppf_dump:i.ppf_dump;
Compilenv.save_unit_info (cmx i)) Compilenv.save_unit_info (cmx i))
let implementation ~backend ~source_file ~output_prefix = let implementation ~backend ~source_file ~output_prefix =

View File

@ -136,6 +136,9 @@ type preallocated_constant = {
provenance : usymbol_provenance option; provenance : usymbol_provenance option;
} }
type with_constants =
ulambda * preallocated_block list * preallocated_constant list
(* Comparison functions for constants. We must not use Stdlib.compare (* Comparison functions for constants. We must not use Stdlib.compare
because it compares "0.0" and "-0.0" equal. (PR#6442) *) because it compares "0.0" and "-0.0" equal. (PR#6442) *)

View File

@ -151,3 +151,6 @@ type preallocated_constant = {
definition : ustructured_constant; definition : ustructured_constant;
provenance : usymbol_provenance option; provenance : usymbol_provenance option;
} }
type with_constants =
ulambda * preallocated_block list * preallocated_constant list

View File

@ -0,0 +1,58 @@
(**************************************************************************)
(* *)
(* 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 =
{ original_idents = [];
module_path =
Path.Pident (Ident.create_persistent (Compilenv.current_unit_name ()));
}
in
let preallocated_block =
Clambda.{
symbol = Compilenv.make_symbol None;
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
raw_clambda_dump_if ppf_dump clambda_and_constants;
clambda_and_constants

View File

@ -0,0 +1,22 @@
(**************************************************************************)
(* *)
(* 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

View File

@ -6,7 +6,7 @@
(* Mark Shinwell and Leo White, Jane Street Europe *) (* Mark Shinwell and Leo White, Jane Street Europe *)
(* *) (* *)
(* Copyright 2013--2016 OCamlPro SAS *) (* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *) (* Copyright 2014--2019 Jane Street Group LLC *)
(* *) (* *)
(* All rights reserved. This file is distributed under the terms of *) (* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *) (* the GNU Lesser General Public License version 2.1, with the *)
@ -14,7 +14,7 @@
(* *) (* *)
(**************************************************************************) (**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] [@@@ocaml.warning "+a-4-30-40-41-42-66"]
open! Int_replace_polymorphic_compare open! Int_replace_polymorphic_compare
let _dump_function_sizes flam ~backend = let _dump_function_sizes flam ~backend =
@ -31,11 +31,8 @@ let _dump_function_sizes flam ~backend =
| None -> assert false) | None -> assert false)
set_of_closures.function_decls.funs) set_of_closures.function_decls.funs)
let middle_end ~ppf_dump ~prefixname ~backend let lambda_to_flambda ~ppf_dump ~prefixname ~backend ~size ~filename
~size ~module_ident ~module_initializer =
~filename
~module_ident
~module_initializer =
Profile.record_call "flambda" (fun () -> Profile.record_call "flambda" (fun () ->
let previous_warning_reporter = !Location.warning_reporter in let previous_warning_reporter = !Location.warning_reporter in
let module WarningSet = let module WarningSet =
@ -198,3 +195,54 @@ let middle_end ~ppf_dump ~prefixname ~backend
(* dump_function_sizes flam ~backend; *) (* dump_function_sizes flam ~backend; *)
flam)) flam))
) )
let flambda_raw_clambda_dump_if ppf
({ Flambda_to_clambda. expr = ulambda; preallocated_blocks = _;
structured_constants; exported = _; } as input) =
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
~module_ident:program.module_ident
~module_initializer:program.code
in
let export = Build_export_info.build_transient ~backend 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:(Compilenv.current_unit_symbol ())
~ppf_dump expr
in
clambda, preallocated_blocks, structured_constants))
in
let constants =
List.map (fun (symbol, definition) ->
{ Clambda.symbol = Linkage_name.to_string (Symbol.label symbol);
exported = true;
definition;
provenance = None;
})
(Symbol.Map.bindings constants)
in
clambda, preallocated_blocks, constants

View File

@ -16,14 +16,12 @@
[@@@ocaml.warning "+a-4-9-30-40-41-42"] [@@@ocaml.warning "+a-4-9-30-40-41-42"]
(* Translate Lambda code to Flambda code and then optimize it. *) (** Translate Lambda code to Flambda code, optimize it, and produce Clambda. *)
val middle_end val lambda_to_clambda
: ppf_dump:Format.formatter : backend:(module Backend_intf.S)
-> prefixname:string
-> backend:(module Backend_intf.S)
-> size:int
-> filename:string -> filename:string
-> module_ident:Ident.t -> prefixname:string
-> module_initializer:Lambda.lambda -> ppf_dump:Format.formatter
-> Flambda.program -> Lambda.program
-> Clambda.with_constants

View File

@ -31,6 +31,9 @@ type t = {
Set_of_closures_id.t for_one_or_more_units; Set_of_closures_id.t for_one_or_more_units;
imported_units : imported_units :
Simple_value_approx.function_declarations for_one_or_more_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 get_fun_offset t closure_id =
@ -70,7 +73,7 @@ let is_function_constant t closure_id =
(* Instrumentation of closure and field accesses to try to catch compiler (* Instrumentation of closure and field accesses to try to catch compiler
bugs. *) bugs. *)
let check_closure ulam named : Clambda.ulambda = let check_closure t ulam named : Clambda.ulambda =
if not !Clflags.clambda_checks then ulam if not !Clflags.clambda_checks then ulam
else else
let desc = let desc =
@ -78,14 +81,19 @@ let check_closure ulam named : Clambda.ulambda =
~arity:2 ~alloc:false ~arity:2 ~alloc:false
in in
let str = Format.asprintf "%a" Flambda.print_named named in let str = Format.asprintf "%a" Flambda.print_named named in
let str_const = let sym = Compilenv.new_const_symbol () in
Compilenv.new_structured_constant (Uconst_string str) ~shared:true let sym' =
Symbol.of_global_linkage (Compilation_unit.get_current_exn ())
(Linkage_name.create sym)
in in
t.constants_for_instrumentation <-
Symbol.Map.add sym' (Clambda.Uconst_string str)
t.constants_for_instrumentation;
Uprim (Pccall desc, Uprim (Pccall desc,
[ulam; Clambda.Uconst (Uconst_ref (str_const, None))], [ulam; Clambda.Uconst (Uconst_ref (sym, None))],
Debuginfo.none) Debuginfo.none)
let check_field ulam pos named_opt : Clambda.ulambda = let check_field t ulam pos named_opt : Clambda.ulambda =
if not !Clflags.clambda_checks then ulam if not !Clflags.clambda_checks then ulam
else else
let desc = let desc =
@ -97,11 +105,16 @@ let check_field ulam pos named_opt : Clambda.ulambda =
| None -> "<none>" | None -> "<none>"
| Some named -> Format.asprintf "%a" Flambda.print_named named | Some named -> Format.asprintf "%a" Flambda.print_named named
in in
let str_const = let sym = Compilenv.new_const_symbol () in
Compilenv.new_structured_constant (Uconst_string str) ~shared:true let sym' =
Symbol.of_global_linkage (Compilation_unit.get_current_exn ())
(Linkage_name.create sym)
in in
t.constants_for_instrumentation <-
Symbol.Map.add sym' (Clambda.Uconst_string str)
t.constants_for_instrumentation;
Uprim (Pccall desc, [ulam; Clambda.Uconst (Uconst_int pos); Uprim (Pccall desc, [ulam; Clambda.Uconst (Uconst_int pos);
Clambda.Uconst (Uconst_ref (str_const, None))], Clambda.Uconst (Uconst_ref (sym, None))],
Debuginfo.none) Debuginfo.none)
module Env : sig module Env : sig
@ -258,7 +271,7 @@ let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda =
to_clambda_direct_apply t func args direct_func dbg env to_clambda_direct_apply t func args direct_func dbg env
| Apply { func; args; kind = Indirect; dbg = dbg } -> | Apply { func; args; kind = Indirect; dbg = dbg } ->
let callee = subst_var env func in let callee = subst_var env func in
Ugeneric_apply (check_closure callee (Flambda.Expr (Var func)), Ugeneric_apply (check_closure t callee (Flambda.Expr (Var func)),
subst_vars env args, dbg) subst_vars env args, dbg)
| Switch (arg, sw) -> | Switch (arg, sw) ->
let aux () : Clambda.ulambda = let aux () : Clambda.ulambda =
@ -368,15 +381,15 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda =
a [Uoffset] construction in the event that the offset is zero, otherwise a [Uoffset] construction in the event that the offset is zero, otherwise
we might break pattern matches in Cmmgen (in particular for the we might break pattern matches in Cmmgen (in particular for the
compilation of "let rec"). *) compilation of "let rec"). *)
check_closure ( check_closure t (
build_uoffset build_uoffset
(check_closure (subst_var env set_of_closures) (check_closure t (subst_var env set_of_closures)
(Flambda.Expr (Var set_of_closures))) (Flambda.Expr (Var set_of_closures)))
(get_fun_offset t closure_id)) (get_fun_offset t closure_id))
named named
| Move_within_set_of_closures { closure; start_from; move_to } -> | Move_within_set_of_closures { closure; start_from; move_to } ->
check_closure (build_uoffset check_closure t (build_uoffset
(check_closure (subst_var env closure) (check_closure t (subst_var env closure)
(Flambda.Expr (Var closure))) (Flambda.Expr (Var closure)))
((get_fun_offset t move_to) - (get_fun_offset t start_from))) ((get_fun_offset t move_to) - (get_fun_offset t start_from)))
named named
@ -386,13 +399,14 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda =
let var_offset = get_fv_offset t var in let var_offset = get_fv_offset t var in
let pos = var_offset - fun_offset in let pos = var_offset - fun_offset in
Uprim (Pfield pos, Uprim (Pfield pos,
[check_field (check_closure ulam (Expr (Var closure))) pos (Some named)], [check_field t (check_closure t ulam (Expr (Var closure)))
pos (Some named)],
Debuginfo.none) Debuginfo.none)
| Prim (Pfield index, [block], dbg) -> | Prim (Pfield index, [block], dbg) ->
Uprim (Pfield index, [check_field (subst_var env block) index None], dbg) Uprim (Pfield index, [check_field t (subst_var env block) index None], dbg)
| Prim (Psetfield (index, maybe_ptr, init), [block; new_value], dbg) -> | Prim (Psetfield (index, maybe_ptr, init), [block; new_value], dbg) ->
Uprim (Psetfield (index, maybe_ptr, init), [ Uprim (Psetfield (index, maybe_ptr, init), [
check_field (subst_var env block) index None; check_field t (subst_var env block) index None;
subst_var env new_value; subst_var env new_value;
], dbg) ], dbg)
| Prim (Popaque, args, dbg) -> | Prim (Popaque, args, dbg) ->
@ -569,11 +583,15 @@ and to_clambda_closed_set_of_closures t env symbol
env, id :: params) env, id :: params)
function_decl.params (env, []) function_decl.params (env, [])
in in
let body =
Un_anf.apply ~ppf_dump:t.ppf_dump ~what:symbol
(to_clambda t env_body function_decl.body)
in
{ label = Compilenv.function_label (Closure_id.wrap id); { label = Compilenv.function_label (Closure_id.wrap id);
arity = Flambda_utils.function_arity function_decl; arity = Flambda_utils.function_arity function_decl;
params = List.map (fun var -> VP.create var, Lambda.Pgenval) params; params = List.map (fun var -> VP.create var, Lambda.Pgenval) params;
return = Lambda.Pgenval; return = Lambda.Pgenval;
body = to_clambda t env_body function_decl.body; body;
dbg = function_decl.dbg; dbg = function_decl.dbg;
env = None; env = None;
} }
@ -698,7 +716,7 @@ type result = {
exported : Export_info.t; exported : Export_info.t;
} }
let convert (program, exported_transient) : result = let convert ~ppf_dump (program, exported_transient) : result =
let current_unit = let current_unit =
let closures = let closures =
Closure_id.Map.keys (Flambda_utils.make_closure_map program) Closure_id.Map.keys (Flambda_utils.make_closure_map program)
@ -733,10 +751,20 @@ let convert (program, exported_transient) : result =
closures; closures;
} }
in in
let t = { current_unit; imported_units; } in let t =
{ current_unit;
imported_units;
constants_for_instrumentation = Symbol.Map.empty;
ppf_dump;
}
in
let expr, structured_constants, preallocated_blocks = let expr, structured_constants, preallocated_blocks =
to_clambda_program t Env.empty Symbol.Map.empty program to_clambda_program t Env.empty Symbol.Map.empty program
in in
let structured_constants =
Symbol.Map.disjoint_union structured_constants
t.constants_for_instrumentation
in
let exported = let exported =
Export_info.t_of_transient exported_transient Export_info.t_of_transient exported_transient
~program ~program

View File

@ -35,4 +35,7 @@ type result = {
For direct calls, the hidden closure parameter is added. Switch For direct calls, the hidden closure parameter is added. Switch
tables are also built. tables are also built.
*) *)
val convert : Flambda.program * Export_info.transient -> result val convert
: ppf_dump:Format.formatter
-> Flambda.program * Export_info.transient
-> result

View File

@ -799,7 +799,7 @@ and un_anf_list var_info env clams : Clambda.ulambda list =
and un_anf_array var_info env clams : Clambda.ulambda array = and un_anf_array var_info env clams : Clambda.ulambda array =
Array.map (un_anf var_info env) clams Array.map (un_anf var_info env) clams
let apply ~ppf_dump clam ~what = let apply ~what ~ppf_dump clam =
let var_info = make_var_info clam in let var_info = make_var_info clam in
let let_bound_vars_that_can_be_moved = let let_bound_vars_that_can_be_moved =
let_bound_vars_that_can_be_moved var_info clam let_bound_vars_that_can_be_moved var_info clam
@ -812,6 +812,8 @@ let apply ~ppf_dump clam ~what =
let clam = un_anf var_info V.Map.empty clam in let clam = un_anf var_info V.Map.empty clam in
if !Clflags.dump_clambda then begin if !Clflags.dump_clambda then begin
Format.fprintf ppf_dump Format.fprintf ppf_dump
"@.un-anf (%s):@ %a@." what Printclambda.clambda clam "@.un-anf (%a):@ %a@."
Symbol.print what
Printclambda.clambda clam
end; end;
clam clam

View File

@ -17,7 +17,7 @@
(** Expand ANF-like constructs so that pattern matches in [Cmmgen] will (** Expand ANF-like constructs so that pattern matches in [Cmmgen] will
work correctly. *) work correctly. *)
val apply val apply
: ppf_dump:Format.formatter : what:Symbol.t
-> ppf_dump:Format.formatter
-> Clambda.ulambda -> Clambda.ulambda
-> what:string
-> Clambda.ulambda -> Clambda.ulambda

View File

@ -248,19 +248,24 @@ let load_lambda ppf ~module_ident ~required_globals lam size =
if !Clflags.keep_asm_file then !phrase_name ^ ext_dll if !Clflags.keep_asm_file then !phrase_name ^ ext_dll
else Filename.temp_file ("caml" ^ !phrase_name) ext_dll else Filename.temp_file ("caml" ^ !phrase_name) ext_dll
in in
let fn = Filename.chop_extension dll in let filename = Filename.chop_extension dll in
if not Config.flambda then let program =
Asmgen.compile_implementation_clambda { Lambda.
~toplevel:need_symbol fn ~backend ~ppf_dump:ppf code = slam;
{ Lambda.code=slam ; main_module_block_size=size; main_module_block_size = size;
module_ident; required_globals } module_ident;
else required_globals;
Asmgen.compile_implementation_flambda }
~required_globals ~backend ~toplevel:need_symbol fn ~ppf_dump:ppf in
(Flambda_middle_end.middle_end ~ppf_dump:ppf ~prefixname:"" ~backend ~size let middle_end =
~module_ident ~module_initializer:slam ~filename:"toplevel"); if Config.flambda then Flambda_middle_end.lambda_to_clambda
Asmlink.call_linker_shared [fn ^ ext_obj] dll; else Closure_middle_end.lambda_to_clambda
Sys.remove (fn ^ ext_obj); in
Asmgen.compile_implementation ~toplevel:need_symbol
~backend ~filename ~prefixname:""
~middle_end ~ppf_dump:ppf program;
Asmlink.call_linker_shared [filename ^ ext_obj] dll;
Sys.remove (filename ^ ext_obj);
let dll = let dll =
if Filename.is_implicit dll if Filename.is_implicit dll

View File

@ -200,6 +200,9 @@ let native_name p =
let byte_name p = let byte_name p =
p.prim_name p.prim_name
let native_name_is_external p =
p.prim_native_name <> "" && p.prim_native_name.[0] <> '%'
let report_error ppf err = let report_error ppf err =
match err with match err with
| Old_style_float_with_native_repr_attribute -> | Old_style_float_with_native_repr_attribute ->

View File

@ -63,6 +63,11 @@ val print
val native_name: description -> string val native_name: description -> string
val byte_name: description -> string val byte_name: description -> string
(** [native_name_is_externa] returns [true] iff the [native_name] for the
given primitive identifies that the primitive is not implemented in the
compiler itself. *)
val native_name_is_external : description -> bool
type error = type error =
| Old_style_float_with_native_repr_attribute | Old_style_float_with_native_repr_attribute
| Old_style_noalloc_with_noalloc_attribute | Old_style_noalloc_with_noalloc_attribute