Move some middle-end files around (#2281)
* Various file moves in the middle end: this is the first stage of improving separation between the middle end and backend. * Creation of file_formats/ directory (with associated file moves) to hold the definitions of compilation artifact formats. * Creation of lambda/ directory (with associated file moves) to hold Lambda language definition files, transformation passes and construction passes from Typedtree. * Disable (hopefully temporarily) dynlink, debugger and ocamldoc for the dune build.master
Mark Shinwell
GitHub
parent
36d299b4aa
commit
72ea849d2a
3
Changes
3
Changes
|
|
@ -73,6 +73,9 @@ Working version
|
|||
- #2280: Don't make more Clambda constants after starting Cmmgen
|
||||
(Mark Shinwell, review by Vincent Laviron)
|
||||
|
||||
- #2281: Move some middle-end files around
|
||||
(Mark Shinwell)
|
||||
|
||||
- #2283: Add [is_prefix] and [find_and_chop_longest_common_prefix] to
|
||||
[Misc.Stdlib.List]
|
||||
(Mark Shinwell, review by Alain Frisch and Stephen Dolan)
|
||||
|
|
|
|||
268
Makefile
268
Makefile
|
|
@ -46,8 +46,10 @@ include stdlib/StdlibModules
|
|||
CAMLC=$(BOOT_OCAMLC) -g -nostdlib -I boot -use-prims runtime/primitives
|
||||
CAMLOPT=$(CAMLRUN) ./ocamlopt -g -nostdlib -I stdlib -I otherlibs/dynlink
|
||||
ARCHES=amd64 i386 arm arm64 power s390x
|
||||
INCLUDES=-I utils -I parsing -I typing -I bytecomp -I middle_end \
|
||||
-I middle_end/base_types -I asmcomp -I asmcomp/debug \
|
||||
INCLUDES=-I utils -I parsing -I typing -I bytecomp -I file_formats \
|
||||
-I lambda -I middle_end -I middle_end/closure \
|
||||
-I middle_end/flambda -I middle_end/flambda/base_types \
|
||||
-I asmcomp -I asmcomp/debug \
|
||||
-I driver -I toplevel
|
||||
|
||||
COMPFLAGS=-strict-sequence -principal -absname -w +a-4-9-41-42-44-45-48-66 \
|
||||
|
|
@ -76,7 +78,8 @@ UTILS=utils/config.cmo utils/build_path_prefix_map.cmo utils/misc.cmo \
|
|||
utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
|
||||
utils/consistbl.cmo \
|
||||
utils/strongly_connected_components.cmo \
|
||||
utils/targetint.cmo
|
||||
utils/targetint.cmo \
|
||||
utils/int_replace_polymorphic_compare.cmo
|
||||
|
||||
PARSING=parsing/location.cmo parsing/longident.cmo \
|
||||
parsing/docstrings.cmo parsing/syntaxerr.cmo \
|
||||
|
|
@ -91,14 +94,13 @@ TYPING=typing/ident.cmo typing/path.cmo \
|
|||
typing/primitive.cmo typing/types.cmo \
|
||||
typing/btype.cmo typing/oprint.cmo \
|
||||
typing/subst.cmo typing/predef.cmo \
|
||||
typing/datarepr.cmo typing/cmi_format.cmo \
|
||||
typing/persistent_env.cmo \
|
||||
typing/env.cmo \
|
||||
typing/datarepr.cmo file_formats/cmi_format.cmo \
|
||||
typing/persistent_env.cmo typing/env.cmo \
|
||||
typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \
|
||||
typing/printtyp.cmo typing/includeclass.cmo \
|
||||
typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \
|
||||
typing/tast_iterator.cmo typing/tast_mapper.cmo \
|
||||
typing/cmt_format.cmo typing/untypeast.cmo \
|
||||
file_formats/cmt_format.cmo typing/untypeast.cmo \
|
||||
typing/includemod.cmo typing/typetexp.cmo typing/printpat.cmo \
|
||||
typing/parmatch.cmo typing/stypes.cmo \
|
||||
typing/typedecl_properties.cmo typing/typedecl_variance.cmo \
|
||||
|
|
@ -107,12 +109,15 @@ TYPING=typing/ident.cmo typing/path.cmo \
|
|||
typing/rec_check.cmo typing/typecore.cmo typing/typeclass.cmo \
|
||||
typing/typemod.cmo
|
||||
|
||||
COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
|
||||
bytecomp/switch.cmo bytecomp/matching.cmo \
|
||||
bytecomp/translobj.cmo bytecomp/translattribute.cmo \
|
||||
bytecomp/translprim.cmo bytecomp/translcore.cmo \
|
||||
bytecomp/translclass.cmo bytecomp/translmod.cmo \
|
||||
bytecomp/simplif.cmo bytecomp/runtimedef.cmo \
|
||||
LAMBDA=lambda/debuginfo.cmo \
|
||||
lambda/lambda.cmo lambda/printlambda.cmo \
|
||||
lambda/switch.cmo lambda/matching.cmo \
|
||||
lambda/translobj.cmo lambda/translattribute.cmo \
|
||||
lambda/translprim.cmo lambda/translcore.cmo \
|
||||
lambda/translclass.cmo lambda/translmod.cmo \
|
||||
lambda/simplif.cmo lambda/runtimedef.cmo
|
||||
|
||||
COMP=\
|
||||
bytecomp/meta.cmo bytecomp/opcodes.cmo \
|
||||
bytecomp/bytesections.cmo bytecomp/dll.cmo \
|
||||
bytecomp/symtable.cmo \
|
||||
|
|
@ -121,8 +126,7 @@ COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
|
|||
driver/makedepend.cmo \
|
||||
driver/compile_common.cmo
|
||||
|
||||
|
||||
COMMON=$(UTILS) $(PARSING) $(TYPING) $(COMP)
|
||||
COMMON=$(UTILS) $(PARSING) $(TYPING) $(LAMBDA) $(COMP)
|
||||
|
||||
BYTECOMP=bytecomp/instruct.cmo bytecomp/bytegen.cmo \
|
||||
bytecomp/printinstr.cmo bytecomp/emitcode.cmo \
|
||||
|
|
@ -150,22 +154,10 @@ endif
|
|||
ASMCOMP=\
|
||||
$(ARCH_SPECIFIC_ASMCOMP) \
|
||||
asmcomp/arch.cmo \
|
||||
asmcomp/backend_var.cmo \
|
||||
asmcomp/cmm.cmo asmcomp/printcmm.cmo \
|
||||
asmcomp/reg.cmo asmcomp/debug/reg_with_debug_info.cmo \
|
||||
asmcomp/debug/reg_availability_set.cmo \
|
||||
asmcomp/mach.cmo asmcomp/proc.cmo \
|
||||
asmcomp/clambda.cmo asmcomp/printclambda.cmo \
|
||||
asmcomp/export_info.cmo \
|
||||
asmcomp/export_info_for_pack.cmo \
|
||||
asmcomp/compilenv.cmo \
|
||||
asmcomp/closure.cmo \
|
||||
asmcomp/traverse_for_exported_symbols.cmo \
|
||||
asmcomp/build_export_info.cmo \
|
||||
asmcomp/closure_offsets.cmo \
|
||||
asmcomp/flambda_to_clambda.cmo \
|
||||
asmcomp/import_approx.cmo \
|
||||
asmcomp/un_anf.cmo \
|
||||
asmcomp/afl_instrument.cmo \
|
||||
asmcomp/strmatch.cmo \
|
||||
asmcomp/cmmgen_state.cmo \
|
||||
|
|
@ -192,72 +184,96 @@ ASMCOMP=\
|
|||
asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo \
|
||||
driver/opterrors.cmo driver/optcompile.cmo
|
||||
|
||||
# Files under middle_end/ are not to reference files under asmcomp/.
|
||||
# This ensures that the middle end can be linked (e.g. for objinfo) even when
|
||||
# the native code compiler is not present for some particular target.
|
||||
|
||||
MIDDLE_END_CLOSURE=\
|
||||
middle_end/closure/closure.cmo
|
||||
|
||||
# Owing to dependencies through [Compilenv], which would be
|
||||
# difficult to remove, some of the lower parts of Flambda (anything that is
|
||||
# saved in a .cmx file) have to be included in the [MIDDLE_END] stanza, below.
|
||||
MIDDLE_END_FLAMBDA=\
|
||||
middle_end/flambda/import_approx.cmo \
|
||||
middle_end/flambda/lift_code.cmo \
|
||||
middle_end/flambda/closure_conversion_aux.cmo \
|
||||
middle_end/flambda/closure_conversion.cmo \
|
||||
middle_end/flambda/initialize_symbol_to_let_symbol.cmo \
|
||||
middle_end/flambda/lift_let_to_initialize_symbol.cmo \
|
||||
middle_end/flambda/find_recursive_functions.cmo \
|
||||
middle_end/flambda/invariant_params.cmo \
|
||||
middle_end/flambda/inconstant_idents.cmo \
|
||||
middle_end/flambda/alias_analysis.cmo \
|
||||
middle_end/flambda/lift_constants.cmo \
|
||||
middle_end/flambda/share_constants.cmo \
|
||||
middle_end/flambda/simplify_common.cmo \
|
||||
middle_end/flambda/remove_unused_arguments.cmo \
|
||||
middle_end/flambda/remove_unused_closure_vars.cmo \
|
||||
middle_end/flambda/remove_unused_program_constructs.cmo \
|
||||
middle_end/flambda/simplify_boxed_integer_ops.cmo \
|
||||
middle_end/flambda/simplify_primitives.cmo \
|
||||
middle_end/flambda/inlining_stats_types.cmo \
|
||||
middle_end/flambda/inlining_stats.cmo \
|
||||
middle_end/flambda/inline_and_simplify_aux.cmo \
|
||||
middle_end/flambda/remove_free_vars_equal_to_args.cmo \
|
||||
middle_end/flambda/extract_projections.cmo \
|
||||
middle_end/flambda/augment_specialised_args.cmo \
|
||||
middle_end/flambda/unbox_free_vars_of_closures.cmo \
|
||||
middle_end/flambda/unbox_specialised_args.cmo \
|
||||
middle_end/flambda/unbox_closures.cmo \
|
||||
middle_end/flambda/inlining_transforms.cmo \
|
||||
middle_end/flambda/inlining_decision.cmo \
|
||||
middle_end/flambda/inline_and_simplify.cmo \
|
||||
middle_end/flambda/ref_to_variables.cmo \
|
||||
middle_end/flambda/flambda_invariants.cmo \
|
||||
middle_end/flambda/traverse_for_exported_symbols.cmo \
|
||||
middle_end/flambda/build_export_info.cmo \
|
||||
middle_end/flambda/closure_offsets.cmo \
|
||||
middle_end/flambda/un_anf.cmo \
|
||||
middle_end/flambda/flambda_to_clambda.cmo \
|
||||
middle_end/flambda/flambda_middle_end.cmo
|
||||
|
||||
MIDDLE_END=\
|
||||
middle_end/int_replace_polymorphic_compare.cmo \
|
||||
middle_end/debuginfo.cmo \
|
||||
asmcomp/clambda_primitives.cmo \
|
||||
asmcomp/semantics_of_primitives.cmo \
|
||||
asmcomp/convert_primitives.cmo \
|
||||
asmcomp/printclambda_primitives.cmo \
|
||||
middle_end/base_types/tag.cmo \
|
||||
middle_end/base_types/linkage_name.cmo \
|
||||
middle_end/base_types/compilation_unit.cmo \
|
||||
middle_end/internal_variable_names.cmo \
|
||||
middle_end/base_types/variable.cmo \
|
||||
middle_end/base_types/mutable_variable.cmo \
|
||||
middle_end/base_types/id_types.cmo \
|
||||
middle_end/base_types/set_of_closures_id.cmo \
|
||||
middle_end/base_types/set_of_closures_origin.cmo \
|
||||
middle_end/base_types/closure_element.cmo \
|
||||
middle_end/base_types/closure_id.cmo \
|
||||
middle_end/base_types/closure_origin.cmo \
|
||||
middle_end/base_types/var_within_closure.cmo \
|
||||
middle_end/base_types/static_exception.cmo \
|
||||
middle_end/base_types/export_id.cmo \
|
||||
middle_end/base_types/symbol.cmo \
|
||||
middle_end/pass_wrapper.cmo \
|
||||
middle_end/allocated_const.cmo \
|
||||
middle_end/parameter.cmo \
|
||||
middle_end/projection.cmo \
|
||||
middle_end/flambda.cmo \
|
||||
middle_end/flambda_iterators.cmo \
|
||||
middle_end/flambda_utils.cmo \
|
||||
middle_end/inlining_cost.cmo \
|
||||
middle_end/effect_analysis.cmo \
|
||||
middle_end/freshening.cmo \
|
||||
middle_end/simple_value_approx.cmo \
|
||||
middle_end/lift_code.cmo \
|
||||
middle_end/closure_conversion_aux.cmo \
|
||||
middle_end/closure_conversion.cmo \
|
||||
middle_end/initialize_symbol_to_let_symbol.cmo \
|
||||
middle_end/lift_let_to_initialize_symbol.cmo \
|
||||
middle_end/find_recursive_functions.cmo \
|
||||
middle_end/invariant_params.cmo \
|
||||
middle_end/inconstant_idents.cmo \
|
||||
middle_end/alias_analysis.cmo \
|
||||
middle_end/lift_constants.cmo \
|
||||
middle_end/share_constants.cmo \
|
||||
middle_end/simplify_common.cmo \
|
||||
middle_end/remove_unused_arguments.cmo \
|
||||
middle_end/remove_unused_closure_vars.cmo \
|
||||
middle_end/remove_unused_program_constructs.cmo \
|
||||
middle_end/simplify_boxed_integer_ops.cmo \
|
||||
middle_end/simplify_primitives.cmo \
|
||||
middle_end/inlining_stats_types.cmo \
|
||||
middle_end/inlining_stats.cmo \
|
||||
middle_end/inline_and_simplify_aux.cmo \
|
||||
middle_end/remove_free_vars_equal_to_args.cmo \
|
||||
middle_end/extract_projections.cmo \
|
||||
middle_end/augment_specialised_args.cmo \
|
||||
middle_end/unbox_free_vars_of_closures.cmo \
|
||||
middle_end/unbox_specialised_args.cmo \
|
||||
middle_end/unbox_closures.cmo \
|
||||
middle_end/inlining_transforms.cmo \
|
||||
middle_end/inlining_decision.cmo \
|
||||
middle_end/inline_and_simplify.cmo \
|
||||
middle_end/ref_to_variables.cmo \
|
||||
middle_end/flambda_invariants.cmo \
|
||||
middle_end/middle_end.cmo
|
||||
middle_end/linkage_name.cmo \
|
||||
middle_end/compilation_unit.cmo \
|
||||
middle_end/variable.cmo \
|
||||
middle_end/flambda/base_types/closure_element.cmo \
|
||||
middle_end/flambda/base_types/closure_id.cmo \
|
||||
middle_end/symbol.cmo \
|
||||
middle_end/backend_var.cmo \
|
||||
middle_end/clambda_primitives.cmo \
|
||||
middle_end/printclambda_primitives.cmo \
|
||||
middle_end/clambda.cmo \
|
||||
middle_end/printclambda.cmo \
|
||||
middle_end/semantics_of_primitives.cmo \
|
||||
middle_end/convert_primitives.cmo \
|
||||
middle_end/flambda/base_types/id_types.cmo \
|
||||
middle_end/flambda/base_types/export_id.cmo \
|
||||
middle_end/flambda/base_types/tag.cmo \
|
||||
middle_end/flambda/base_types/mutable_variable.cmo \
|
||||
middle_end/flambda/base_types/set_of_closures_id.cmo \
|
||||
middle_end/flambda/base_types/set_of_closures_origin.cmo \
|
||||
middle_end/flambda/base_types/closure_origin.cmo \
|
||||
middle_end/flambda/base_types/var_within_closure.cmo \
|
||||
middle_end/flambda/base_types/static_exception.cmo \
|
||||
middle_end/flambda/pass_wrapper.cmo \
|
||||
middle_end/flambda/allocated_const.cmo \
|
||||
middle_end/flambda/parameter.cmo \
|
||||
middle_end/flambda/projection.cmo \
|
||||
middle_end/flambda/flambda.cmo \
|
||||
middle_end/flambda/flambda_iterators.cmo \
|
||||
middle_end/flambda/flambda_utils.cmo \
|
||||
middle_end/flambda/freshening.cmo \
|
||||
middle_end/flambda/effect_analysis.cmo \
|
||||
middle_end/flambda/inlining_cost.cmo \
|
||||
middle_end/flambda/simple_value_approx.cmo \
|
||||
middle_end/flambda/export_info.cmo \
|
||||
middle_end/flambda/export_info_for_pack.cmo \
|
||||
middle_end/compilenv.cmo \
|
||||
$(MIDDLE_END_CLOSURE) \
|
||||
$(MIDDLE_END_FLAMBDA)
|
||||
|
||||
OPTCOMP=$(MIDDLE_END) $(ASMCOMP)
|
||||
|
||||
|
|
@ -541,6 +557,8 @@ endif
|
|||
parsing/*.cmi \
|
||||
typing/*.cmi \
|
||||
bytecomp/*.cmi \
|
||||
file_formats/*.cmi \
|
||||
lambda/*.cmi \
|
||||
driver/*.cmi \
|
||||
toplevel/*.cmi \
|
||||
"$(INSTALL_COMPLIBDIR)"
|
||||
|
|
@ -549,6 +567,8 @@ ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true"
|
|||
utils/*.cmt utils/*.cmti utils/*.mli \
|
||||
parsing/*.cmt parsing/*.cmti parsing/*.mli \
|
||||
typing/*.cmt typing/*.cmti typing/*.mli \
|
||||
file_formats/*.cmt file_formats/*.cmti file_formats/*.mli \
|
||||
lambda/*.cmt lambda/*.cmti lambda/*.mli \
|
||||
bytecomp/*.cmt bytecomp/*.cmti bytecomp/*.mli \
|
||||
driver/*.cmt driver/*.cmti driver/*.mli \
|
||||
toplevel/*.cmt toplevel/*.cmti toplevel/*.mli \
|
||||
|
|
@ -614,7 +634,13 @@ endif
|
|||
middle_end/*.cmi \
|
||||
"$(INSTALL_COMPLIBDIR)"
|
||||
$(INSTALL_DATA) \
|
||||
middle_end/base_types/*.cmi \
|
||||
middle_end/closure/*.cmi \
|
||||
"$(INSTALL_COMPLIBDIR)"
|
||||
$(INSTALL_DATA) \
|
||||
middle_end/flambda/*.cmi \
|
||||
"$(INSTALL_COMPLIBDIR)"
|
||||
$(INSTALL_DATA) \
|
||||
middle_end/flambda/base_types/*.cmi \
|
||||
"$(INSTALL_COMPLIBDIR)"
|
||||
$(INSTALL_DATA) \
|
||||
asmcomp/*.cmi \
|
||||
|
|
@ -625,8 +651,17 @@ ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true"
|
|||
middle_end/*.mli \
|
||||
"$(INSTALL_COMPLIBDIR)"
|
||||
$(INSTALL_DATA) \
|
||||
middle_end/base_types/*.cmt middle_end/base_types/*.cmti \
|
||||
middle_end/base_types/*.mli \
|
||||
middle_end/closure/*.cmt middle_end/closure/*.cmti \
|
||||
middle_end/closure/*.mli \
|
||||
"$(INSTALL_COMPLIBDIR)"
|
||||
$(INSTALL_DATA) \
|
||||
middle_end/flambda/*.cmt middle_end/flambda/*.cmti \
|
||||
middle_end/flambda/*.mli \
|
||||
"$(INSTALL_COMPLIBDIR)"
|
||||
$(INSTALL_DATA) \
|
||||
middle_end/flambda/base_types/*.cmt \
|
||||
middle_end/flambda/base_types/*.cmti \
|
||||
middle_end/flambda/base_types/*.mli \
|
||||
"$(INSTALL_COMPLIBDIR)"
|
||||
$(INSTALL_DATA) \
|
||||
asmcomp/*.cmt asmcomp/*.cmti \
|
||||
|
|
@ -670,8 +705,13 @@ installoptopt:
|
|||
$(LN) ocamllex.opt$(EXE) ocamllex$(EXE)
|
||||
$(INSTALL_DATA) \
|
||||
utils/*.cmx parsing/*.cmx typing/*.cmx bytecomp/*.cmx \
|
||||
file_formats/*.cmx \
|
||||
lambda/*.cmx \
|
||||
driver/*.cmx asmcomp/*.cmx middle_end/*.cmx \
|
||||
middle_end/base_types/*.cmx "$(INSTALL_COMPLIBDIR)"
|
||||
middle_end/closure/*.cmx \
|
||||
middle_end/flambda/*.cmx \
|
||||
middle_end/flambda/base_types/*.cmx \
|
||||
"$(INSTALL_COMPLIBDIR)"
|
||||
$(INSTALL_DATA) \
|
||||
compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \
|
||||
compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \
|
||||
|
|
@ -700,7 +740,10 @@ install-compiler-sources:
|
|||
ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true"
|
||||
$(INSTALL_DATA) \
|
||||
utils/*.ml parsing/*.ml typing/*.ml bytecomp/*.ml driver/*.ml \
|
||||
toplevel/*.ml middle_end/*.ml middle_end/base_types/*.ml \
|
||||
file_formats/*.ml \
|
||||
lambda/*.ml \
|
||||
toplevel/*.ml middle_end/*.ml middle_end/closure/*.ml \
|
||||
middle_end/flambda/*.ml middle_end/flambda/base_types/*.ml \
|
||||
asmcomp/*.ml \
|
||||
"$(INSTALL_COMPLIBDIR)"
|
||||
endif
|
||||
|
|
@ -857,14 +900,14 @@ $(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(OPTCOMP:.cmo=.cmx): ocamlopt
|
|||
runtime/primitives:
|
||||
$(MAKE) -C runtime primitives
|
||||
|
||||
bytecomp/runtimedef.ml: bytecomp/generate_runtimedef.sh runtime/caml/fail.h \
|
||||
lambda/runtimedef.ml: lambda/generate_runtimedef.sh runtime/caml/fail.h \
|
||||
runtime/primitives
|
||||
$^ > $@
|
||||
|
||||
partialclean::
|
||||
rm -f bytecomp/runtimedef.ml
|
||||
rm -f lambda/runtimedef.ml
|
||||
|
||||
beforedepend:: bytecomp/runtimedef.ml
|
||||
beforedepend:: lambda/runtimedef.ml
|
||||
|
||||
# Choose the right machine-dependent files
|
||||
|
||||
|
|
@ -1109,10 +1152,7 @@ lintapidiff:
|
|||
grep -Ev internal\|obj\|spacetime\|stdLabels\|moreLabels |\
|
||||
tools/lintapidiff.opt $(VERSIONS)
|
||||
|
||||
# The middle end (whose .cma library is currently only used for linking
|
||||
# the "ocamlobjinfo" program, since we cannot depend on the whole native code
|
||||
# compiler for "make world" and the list of dependencies for
|
||||
# asmcomp/export_info.cmo is long).
|
||||
# The middle end.
|
||||
|
||||
compilerlibs/ocamlmiddleend.cma: $(MIDDLE_END)
|
||||
$(CAMLC) -a -o $@ $^
|
||||
|
|
@ -1126,9 +1166,7 @@ partialclean::
|
|||
# Tools
|
||||
|
||||
.PHONY: ocamltools
|
||||
ocamltools: ocamlc ocamllex asmcomp/cmx_format.cmi \
|
||||
asmcomp/printclambda.cmo compilerlibs/ocamlmiddleend.cma \
|
||||
asmcomp/export_info.cmo
|
||||
ocamltools: ocamlc ocamllex compilerlibs/ocamlmiddleend.cma
|
||||
$(MAKE) -C tools all
|
||||
|
||||
.PHONY: ocamltoolsopt
|
||||
|
|
@ -1136,9 +1174,7 @@ ocamltoolsopt: ocamlopt
|
|||
$(MAKE) -C tools opt
|
||||
|
||||
.PHONY: ocamltoolsopt.opt
|
||||
ocamltoolsopt.opt: ocamlc.opt ocamllex.opt asmcomp/cmx_format.cmi \
|
||||
asmcomp/printclambda.cmx compilerlibs/ocamlmiddleend.cmxa \
|
||||
asmcomp/export_info.cmx
|
||||
ocamltoolsopt.opt: ocamlc.opt ocamllex.opt compilerlibs/ocamlmiddleend.cmxa
|
||||
$(MAKE) -C tools opt.opt
|
||||
|
||||
partialclean::
|
||||
|
|
@ -1261,8 +1297,10 @@ partialclean::
|
|||
$(CAMLOPT) $(COMPFLAGS) -c $<
|
||||
|
||||
partialclean::
|
||||
for d in utils parsing typing bytecomp asmcomp middle_end \
|
||||
middle_end/base_types asmcomp/debug driver toplevel tools; do \
|
||||
for d in utils parsing typing bytecomp asmcomp middle_end file_formats \
|
||||
lambda middle_end/closure middle_end/flambda \
|
||||
middle_end/flambda/base_types asmcomp/debug \
|
||||
driver toplevel tools; do \
|
||||
rm -f $$d/*.cm[ioxt] $$d/*.cmti $$d/*.annot $$d/*.$(S) \
|
||||
$$d/*.$(O) $$d/*.$(SO) $$d/*~; \
|
||||
done
|
||||
|
|
@ -1271,9 +1309,11 @@ partialclean::
|
|||
.PHONY: depend
|
||||
depend: beforedepend
|
||||
(for d in utils parsing typing bytecomp asmcomp middle_end \
|
||||
middle_end/base_types asmcomp/debug driver toplevel; \
|
||||
do $(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) $$d/*.mli $$d/*.ml || exit; \
|
||||
done) > .depend
|
||||
lambda file_formats middle_end/closure middle_end/flambda \
|
||||
middle_end/flambda/base_types asmcomp/debug \
|
||||
driver toplevel; \
|
||||
do $(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) $$d/*.mli $$d/*.ml || exit; \
|
||||
done) > .depend
|
||||
|
||||
.PHONY: distclean
|
||||
distclean: clean
|
||||
|
|
|
|||
|
|
@ -33,6 +33,7 @@ module String = Misc.Stdlib.String
|
|||
emit.mlp files for certain other targets; the reference here ensures
|
||||
that when releases are being prepared the .depend files are correct
|
||||
for all targets. *)
|
||||
[@@@ocaml.warning "-66"]
|
||||
open! Branch_relaxation
|
||||
|
||||
let _label s = D.label ~typ:QWORD s
|
||||
|
|
|
|||
|
|
@ -221,9 +221,11 @@ let flambda_gen_implementation ?toplevel ~backend ~ppf_dump
|
|||
end_gen_implementation ?toplevel ~ppf_dump
|
||||
(clambda, preallocated, constants)
|
||||
|
||||
let lambda_gen_implementation ?toplevel ~ppf_dump
|
||||
let lambda_gen_implementation ?toplevel ~backend ~ppf_dump
|
||||
(lambda:Lambda.program) =
|
||||
let clambda = Closure.intro lambda.main_module_block_size lambda.code in
|
||||
let clambda =
|
||||
Closure.intro ~backend ~size:lambda.main_module_block_size lambda.code
|
||||
in
|
||||
let provenance : Clambda.usymbol_provenance =
|
||||
{ original_idents = [];
|
||||
module_path =
|
||||
|
|
@ -259,10 +261,10 @@ let compile_implementation_gen ?toplevel prefixname
|
|||
gen_implementation ?toplevel ~ppf_dump program)
|
||||
|
||||
let compile_implementation_clambda ?toplevel prefixname
|
||||
~ppf_dump (program:Lambda.program) =
|
||||
~backend ~ppf_dump (program:Lambda.program) =
|
||||
compile_implementation_gen ?toplevel prefixname
|
||||
~required_globals:program.Lambda.required_globals
|
||||
~ppf_dump lambda_gen_implementation program
|
||||
~ppf_dump (lambda_gen_implementation ~backend) program
|
||||
|
||||
let compile_implementation_flambda ?toplevel prefixname
|
||||
~required_globals ~backend ~ppf_dump (program:Flambda.program) =
|
||||
|
|
|
|||
|
|
@ -25,6 +25,7 @@ val compile_implementation_flambda :
|
|||
val compile_implementation_clambda :
|
||||
?toplevel:(string -> bool) ->
|
||||
string ->
|
||||
backend:(module Backend_intf.S) ->
|
||||
ppf_dump:Format.formatter -> Lambda.program -> unit
|
||||
|
||||
val compile_phrase :
|
||||
|
|
|
|||
|
|
@ -102,7 +102,7 @@ let make_package_object ~ppf_dump members targetobj targetname coercion
|
|||
if Config.flambda then begin
|
||||
let size, lam = Translmod.transl_package_flambda components coercion in
|
||||
let flam =
|
||||
Middle_end.middle_end ~ppf_dump
|
||||
Flambda_middle_end.middle_end ~ppf_dump
|
||||
~prefixname
|
||||
~backend
|
||||
~size
|
||||
|
|
@ -117,7 +117,7 @@ let make_package_object ~ppf_dump members targetobj targetname coercion
|
|||
Translmod.transl_store_package
|
||||
components (Ident.create_persistent targetname) coercion in
|
||||
Asmgen.compile_implementation_clambda
|
||||
prefixname ~ppf_dump { Lambda.code; main_module_block_size;
|
||||
prefixname ~backend ~ppf_dump { Lambda.code; main_module_block_size;
|
||||
module_ident; required_globals = Ident.Set.empty }
|
||||
end;
|
||||
let objfiles =
|
||||
|
|
|
|||
|
|
@ -18,11 +18,3 @@
|
|||
(deps (:instr (file ../runtime/caml/instruct.h)))
|
||||
(action
|
||||
(bash "%{dep:../tools/make_opcodes.exe} -opcodes < %{instr} > %{targets}")))
|
||||
|
||||
(rule
|
||||
(targets runtimedef.ml)
|
||||
(mode fallback)
|
||||
(deps (:fail (file ../runtime/caml/fail.h))
|
||||
(:prim (file ../runtime/primitives)))
|
||||
(action (with-stdout-to %{targets}
|
||||
(run ./generate_runtimedef.sh %{fail} %{prim}))))
|
||||
|
|
|
|||
|
|
@ -286,6 +286,7 @@ main.cmo : \
|
|||
question.cmi \
|
||||
program_management.cmi \
|
||||
primitives.cmi \
|
||||
../typing/persistent_env.cmi \
|
||||
parameters.cmi \
|
||||
../utils/misc.cmi \
|
||||
loadprinter.cmi \
|
||||
|
|
@ -293,11 +294,10 @@ main.cmo : \
|
|||
input_handling.cmi \
|
||||
frames.cmi \
|
||||
exec.cmi \
|
||||
../typing/env.cmi \
|
||||
debugger_config.cmi \
|
||||
../utils/config.cmi \
|
||||
command_line.cmi \
|
||||
../typing/cmi_format.cmi \
|
||||
../file_formats/cmi_format.cmi \
|
||||
../utils/clflags.cmi \
|
||||
checkpoints.cmi
|
||||
main.cmx : \
|
||||
|
|
@ -308,6 +308,7 @@ main.cmx : \
|
|||
question.cmx \
|
||||
program_management.cmx \
|
||||
primitives.cmx \
|
||||
../typing/persistent_env.cmx \
|
||||
parameters.cmx \
|
||||
../utils/misc.cmx \
|
||||
loadprinter.cmx \
|
||||
|
|
@ -315,11 +316,10 @@ main.cmx : \
|
|||
input_handling.cmx \
|
||||
frames.cmx \
|
||||
exec.cmx \
|
||||
../typing/env.cmx \
|
||||
debugger_config.cmx \
|
||||
../utils/config.cmx \
|
||||
command_line.cmx \
|
||||
../typing/cmi_format.cmx \
|
||||
../file_formats/cmi_format.cmx \
|
||||
../utils/clflags.cmx \
|
||||
checkpoints.cmx
|
||||
parameters.cmo : \
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ DEPFLAGS=-slash
|
|||
DEPINCLUDES=$(INCLUDES)
|
||||
|
||||
DIRECTORIES=$(UNIXDIR) $(DYNLINKDIR) $(addprefix $(ROOTDIR)/,\
|
||||
utils parsing typing bytecomp toplevel)
|
||||
utils parsing typing bytecomp toplevel driver file_formats lambda)
|
||||
|
||||
INCLUDES=$(addprefix -I ,$(DIRECTORIES))
|
||||
|
||||
|
|
@ -48,16 +48,23 @@ parsing_modules := $(addprefix parsing/,\
|
|||
|
||||
typing_modules := $(addprefix typing/,\
|
||||
ident path types btype primitive typedtree subst predef datarepr \
|
||||
cmi_format persistent_env env oprint ctype printtyp mtype envaux)
|
||||
persistent_env env oprint ctype printtyp mtype envaux)
|
||||
|
||||
file_formats_modules := $(addprefix file_formats/,\
|
||||
cmi_format)
|
||||
|
||||
lambda_modules := $(addprefix lambda/,\
|
||||
runtimedef)
|
||||
|
||||
bytecomp_modules := $(addprefix bytecomp/,\
|
||||
runtimedef bytesections dll meta symtable opcodes)
|
||||
bytesections dll meta symtable opcodes)
|
||||
|
||||
other_compiler_modules := toplevel/genprintval
|
||||
|
||||
compiler_modules := $(addprefix $(ROOTDIR)/,\
|
||||
$(utils_modules) $(parsing_modules) $(typing_modules) \
|
||||
$(bytecomp_modules) $(other_compiler_modules))
|
||||
$(utils_modules) $(parsing_modules) $(file_formats_modules) \
|
||||
$(lambda_modules) \
|
||||
$(typing_modules) $(bytecomp_modules) $(other_compiler_modules))
|
||||
|
||||
debugger_modules := \
|
||||
int64ops primitives unix_tools debugger_config parameters lexer \
|
||||
|
|
|
|||
|
|
@ -12,14 +12,16 @@
|
|||
;* *
|
||||
;**************************************************************************
|
||||
|
||||
(ocamllex lexer)
|
||||
(ocamlyacc parser)
|
||||
; mshinwell: Disabled for now -- otherlibs/dynlink/dune needs fixing first.
|
||||
|
||||
(executable
|
||||
(name main)
|
||||
(modes byte)
|
||||
(flags (:standard -w -9))
|
||||
(modules_without_implementation parser_aux)
|
||||
(libraries ocamlcommon ocamltoplevel runtime stdlib unix))
|
||||
|
||||
(rule (copy main.exe ocamldebug.byte))
|
||||
;(ocamllex lexer)
|
||||
;(ocamlyacc parser)
|
||||
;
|
||||
;(executable
|
||||
; (name main)
|
||||
; (modes byte)
|
||||
; (flags (:standard -w -9))
|
||||
; (modules_without_implementation parser_aux)
|
||||
; (libraries ocamlcommon ocamltoplevel runtime stdlib unix))
|
||||
;
|
||||
;(rule (copy main.exe ocamldebug.byte))
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ let flambda i backend typed =
|
|||
|>> Simplif.simplify_lambda
|
||||
|>> print_if i.ppf_dump Clflags.dump_lambda Printlambda.lambda
|
||||
|> (fun ((module_ident, size), lam) ->
|
||||
Middle_end.middle_end
|
||||
Flambda_middle_end.middle_end
|
||||
~ppf_dump:i.ppf_dump
|
||||
~prefixname:i.output_prefix
|
||||
~size
|
||||
|
|
@ -61,7 +61,7 @@ let flambda i backend typed =
|
|||
i.output_prefix ~required_globals ~backend ~ppf_dump:i.ppf_dump;
|
||||
Compilenv.save_unit_info (cmx i))
|
||||
|
||||
let clambda i typed =
|
||||
let clambda i backend typed =
|
||||
Clflags.use_inlining_arguments_set Clflags.classic_arguments;
|
||||
typed
|
||||
|> Profile.(record transl)
|
||||
|
|
@ -73,7 +73,7 @@ let clambda i typed =
|
|||
{ program with Lambda.code }
|
||||
|> print_if i.ppf_dump Clflags.dump_lambda Printlambda.program
|
||||
|> Asmgen.compile_implementation_clambda
|
||||
i.output_prefix ~ppf_dump:i.ppf_dump;
|
||||
i.output_prefix ~backend ~ppf_dump:i.ppf_dump;
|
||||
Compilenv.save_unit_info (cmx i))
|
||||
|
||||
let implementation ~backend ~source_file ~output_prefix =
|
||||
|
|
@ -81,7 +81,7 @@ let implementation ~backend ~source_file ~output_prefix =
|
|||
Compilenv.reset ?packname:!Clflags.for_package info.module_name;
|
||||
if Config.flambda
|
||||
then flambda info backend typed
|
||||
else clambda info typed
|
||||
else clambda info backend typed
|
||||
in
|
||||
with_info ~source_file ~output_prefix ~dump_ext:"cmx" @@ fun info ->
|
||||
Compile_common.implementation info ~backend
|
||||
|
|
|
|||
|
|
@ -25,6 +25,7 @@ val implementation:
|
|||
|
||||
val clambda :
|
||||
Compile_common.info ->
|
||||
(module Backend_intf.S) ->
|
||||
Typedtree.structure * Typedtree.module_coercion -> unit
|
||||
(** [clambda info typed] applies the regular compilation pipeline to the
|
||||
given typechecked implementation and outputs the resulting files.
|
||||
|
|
|
|||
142
dune
142
dune
|
|
@ -27,8 +27,12 @@
|
|||
(copy_files# driver/*.ml{,i})
|
||||
(copy_files# asmcomp/*.ml{,i})
|
||||
(copy_files# asmcomp/debug/*.ml{,i})
|
||||
(copy_files# file_formats/*.ml{,i})
|
||||
(copy_files# lambda/*.ml{,i})
|
||||
(copy_files# middle_end/*.ml{,i})
|
||||
(copy_files# middle_end/base_types/*.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})
|
||||
|
||||
(library
|
||||
(name ocamlcommon)
|
||||
|
|
@ -41,7 +45,7 @@
|
|||
;; UTILS
|
||||
config build_path_prefix_map misc identifiable numbers arg_helper clflags
|
||||
profile terminfo ccomp warnings consistbl strongly_connected_components
|
||||
targetint load_path
|
||||
targetint load_path int_replace_polymorphic_compare
|
||||
|
||||
;; PARSING
|
||||
location longident docstrings syntaxerr ast_helper camlinternalMenhirLib
|
||||
|
|
@ -61,17 +65,20 @@
|
|||
; manual update: mli only files
|
||||
annot outcometree
|
||||
|
||||
;; COMP
|
||||
lambda printlambda semantics_of_primitives switch matching translobj
|
||||
translattribute translprim translcore translclass translmod simplif
|
||||
runtimedef meta opcodes bytesections dll symtable pparse main_args compenv
|
||||
compmisc makedepend compile_common clambda_primitives
|
||||
printclambda_primitives
|
||||
;; lambda/
|
||||
debuginfo lambda matching printlambda runtimedef simplif switch
|
||||
translattribute translclass translcore translmod translobj translprim
|
||||
|
||||
;; bytecomp/
|
||||
meta opcodes bytesections dll symtable
|
||||
|
||||
;; some of COMP
|
||||
pparse main_args compenv compmisc makedepend compile_common
|
||||
; manual update: mli only files
|
||||
cmo_format
|
||||
; manual update: this is required.
|
||||
instruct
|
||||
))
|
||||
))
|
||||
|
||||
(library
|
||||
(name ocamlbytecomp)
|
||||
|
|
@ -79,58 +86,79 @@
|
|||
(flags (:standard -principal -nostdlib))
|
||||
(libraries stdlib ocamlcommon)
|
||||
(modules
|
||||
bytegen printinstr emitcode bytelink bytelibrarian bytepackager errors
|
||||
compile))
|
||||
;; bytecomp/
|
||||
bytegen bytelibrarian bytelink bytepackager emitcode printinstr
|
||||
|
||||
;; driver/
|
||||
errors compile
|
||||
))
|
||||
|
||||
(library
|
||||
(name ocamlmiddleend)
|
||||
(wrapped false)
|
||||
(flags (:standard -principal -nostdlib))
|
||||
(libraries stdlib ocamlcommon)
|
||||
(modules_without_implementation
|
||||
cmx_format cmxs_format backend_intf inlining_decision_intf
|
||||
simplify_boxed_integer_ops_intf)
|
||||
(modules
|
||||
;; file_formats/
|
||||
cmx_format cmxs_format
|
||||
|
||||
;; middle_end/
|
||||
backend_intf backend_var backend_var clambda clambda_primitives
|
||||
compilation_unit compilenv convert_primitives internal_variable_names
|
||||
linkage_name printclambda printclambda_primitives semantics_of_primitives
|
||||
symbol variable
|
||||
|
||||
;; middle_end/closure/
|
||||
closure
|
||||
|
||||
;; 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 export_info_for_pack 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
|
||||
)
|
||||
)
|
||||
|
||||
(library
|
||||
(name ocamloptcomp)
|
||||
(wrapped false)
|
||||
(flags (:standard -principal -nostdlib))
|
||||
(libraries stdlib ocamlcommon)
|
||||
(modules_without_implementation
|
||||
cmxs_format cmx_format x86_ast backend_intf inlining_decision_intf
|
||||
simplify_boxed_integer_ops_intf)
|
||||
(libraries stdlib ocamlcommon ocamlmiddleend)
|
||||
(modules_without_implementation x86_ast)
|
||||
(modules
|
||||
;; ASMCOMP
|
||||
arch backend_var cmm printcmm reg reg_with_debug_info reg_availability_set
|
||||
mach proc clambda printclambda export_info export_info_for_pack compilenv
|
||||
closure traverse_for_exported_symbols build_export_info closure_offsets
|
||||
flambda_to_clambda import_approx un_anf afl_instrument strmatch cmmgen_state
|
||||
cmmgen interval printmach selectgen spacetime_profiling selection comballoc
|
||||
CSEgen CSE liveness spill split interf coloring linscan reloadgen reload
|
||||
deadcode printlinear linearize available_regs schedgen scheduling
|
||||
branch_relaxation_intf branch_relaxation emitaux emit asmgen asmlink
|
||||
asmlibrarian asmpackager opterrors optcompile
|
||||
; manual update: mli only files
|
||||
cmxs_format cmx_format
|
||||
;; asmcomp/
|
||||
afl_instrument arch asmgen asmlibrarian asmlink asmpackager branch_relaxation
|
||||
branch_relaxation_intf cmm cmmgen cmmgen_state coloring comballoc CSE CSEgen
|
||||
deadcode emit emitaux interf interval linearize linscan liveness mach
|
||||
printcmm printlinear printmach proc reg reload reloadgen schedgen scheduling
|
||||
selectgen selection spacetime_profiling spill split strmatch x86_ast
|
||||
x86_dsl x86_gas x86_masm x86_proc
|
||||
|
||||
; arch specific files: we always include them even though depending on the
|
||||
; target architecture they might not be used.
|
||||
x86_ast
|
||||
x86_proc
|
||||
x86_dsl
|
||||
x86_gas
|
||||
x86_masm
|
||||
;; asmcomp/debug/
|
||||
reg_availability_set compute_ranges_intf available_regs reg_with_debug_info
|
||||
compute_ranges
|
||||
|
||||
;; MIDDLE_END
|
||||
int_replace_polymorphic_compare debuginfo tag linkage_name compilation_unit
|
||||
internal_variable_names variable mutable_variable id_types set_of_closures_id
|
||||
set_of_closures_origin closure_element closure_id closure_origin
|
||||
var_within_closure static_exception export_id symbol pass_wrapper
|
||||
allocated_const parameter projection flambda flambda_iterators flambda_utils
|
||||
inlining_cost effect_analysis freshening simple_value_approx lift_code
|
||||
closure_conversion_aux closure_conversion initialize_symbol_to_let_symbol
|
||||
lift_let_to_initialize_symbol find_recursive_functions invariant_params
|
||||
inconstant_idents alias_analysis lift_constants share_constants
|
||||
simplify_common remove_unused_arguments remove_unused_closure_vars
|
||||
remove_unused_program_constructs simplify_boxed_integer_ops
|
||||
simplify_primitives inlining_stats_types inlining_stats
|
||||
inline_and_simplify_aux remove_free_vars_equal_to_args extract_projections
|
||||
augment_specialised_args unbox_free_vars_of_closures unbox_specialised_args
|
||||
unbox_closures inlining_transforms inlining_decision inline_and_simplify
|
||||
ref_to_variables flambda_invariants middle_end convert_primitives
|
||||
; manual update: mli only files
|
||||
backend_intf inlining_decision_intf simplify_boxed_integer_ops_intf
|
||||
;; driver/
|
||||
optcompile opterrors
|
||||
)
|
||||
)
|
||||
|
||||
|
|
@ -156,7 +184,7 @@
|
|||
(name optmain)
|
||||
(modes byte)
|
||||
(flags (:standard -principal -nostdlib))
|
||||
(libraries ocamloptcomp ocamlcommon runtime stdlib)
|
||||
(libraries ocamloptcomp ocamlmiddleend ocamlcommon runtime stdlib)
|
||||
(modules optmain))
|
||||
|
||||
(rule
|
||||
|
|
@ -166,12 +194,14 @@
|
|||
;;; aliases ;;;
|
||||
;;;;;;;;;;;;;;;
|
||||
|
||||
; mshinwell: The debugger and ocamldoc are currently disabled as Dynlink is
|
||||
; not built correctly.
|
||||
(alias
|
||||
(name world)
|
||||
(deps ocamlc.byte
|
||||
ocamlopt.byte
|
||||
debugger/ocamldebug.byte
|
||||
ocamldoc/ocamldoc.byte
|
||||
; debugger/ocamldebug.byte
|
||||
; ocamldoc/ocamldoc.byte
|
||||
ocamltest/ocamltest.byte
|
||||
toplevel/ocaml.byte
|
||||
toplevel/expunge.exe
|
||||
|
|
|
|||
|
|
@ -0,0 +1,21 @@
|
|||
;**************************************************************************
|
||||
;* *
|
||||
;* OCaml *
|
||||
;* *
|
||||
;* Thomas Refis, Jane Street Europe *
|
||||
;* *
|
||||
;* Copyright 2018 Jane Street Group LLC *
|
||||
;* *
|
||||
;* All rights reserved. This file is distributed under the terms of *
|
||||
;* the GNU Lesser General Public License version 2.1, with the *
|
||||
;* special exception on linking described in the file LICENSE. *
|
||||
;* *
|
||||
;**************************************************************************
|
||||
|
||||
(rule
|
||||
(targets runtimedef.ml)
|
||||
(mode fallback)
|
||||
(deps (:fail (file ../runtime/caml/fail.h))
|
||||
(:prim (file ../runtime/primitives)))
|
||||
(action (with-stdout-to %{targets}
|
||||
(run ./generate_runtimedef.sh %{fail} %{prim}))))
|
||||
|
|
@ -36,6 +36,8 @@ module Storer =
|
|||
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"
|
||||
|
||||
|
|
@ -271,7 +273,8 @@ 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 fpc p (args, approxs) dbg =
|
||||
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
|
||||
|
|
@ -303,11 +306,11 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
|
|||
| 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 * Arch.size_int ->
|
||||
| Plslint when 0 <= n2 && n2 < 8 * B.size_int ->
|
||||
make_const_int (n1 lsl n2)
|
||||
| Plsrint when 0 <= n2 && n2 < 8 * Arch.size_int ->
|
||||
| Plsrint when 0 <= n2 && n2 < 8 * B.size_int ->
|
||||
make_const_int (n1 lsr n2)
|
||||
| Pasrint when 0 <= n2 && n2 < 8 * Arch.size_int ->
|
||||
| Pasrint when 0 <= n2 && n2 < 8 * B.size_int ->
|
||||
make_const_int (n1 asr n2)
|
||||
| Pintcomp c -> make_integer_comparison c n1 n2
|
||||
| _ -> default
|
||||
|
|
@ -361,11 +364,11 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
|
|||
| [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1)));
|
||||
Value_const(Uconst_int n2)] ->
|
||||
begin match p with
|
||||
| Plslbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int ->
|
||||
| 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 * Arch.size_int ->
|
||||
| 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 * Arch.size_int ->
|
||||
| Pasrbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int ->
|
||||
make_const_natint (Nativeint.shift_right n1 n2)
|
||||
| _ -> default
|
||||
end
|
||||
|
|
@ -457,7 +460,7 @@ let field_approx n = function
|
|||
Value_const (List.nth l n)
|
||||
| _ -> Value_unknown
|
||||
|
||||
let simplif_prim_pure fpc p (args, approxs) dbg =
|
||||
let simplif_prim_pure ~backend fpc p (args, approxs) dbg =
|
||||
let open Clambda_primitives in
|
||||
match p, args, approxs with
|
||||
(* Block construction *)
|
||||
|
|
@ -497,11 +500,11 @@ let simplif_prim_pure fpc p (args, approxs) dbg =
|
|||
end
|
||||
(* Catch-all *)
|
||||
| _ ->
|
||||
simplif_arith_prim_pure fpc p (args, approxs) dbg
|
||||
simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg
|
||||
|
||||
let simplif_prim fpc p (args, approxs as 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 fpc p args_approxs dbg
|
||||
then simplif_prim_pure ~backend fpc p args_approxs dbg
|
||||
else
|
||||
(* XXX : always return the same approxs as simplif_prim_pure? *)
|
||||
let approx =
|
||||
|
|
@ -542,18 +545,18 @@ let subst_debuginfo loc dbg =
|
|||
else
|
||||
dbg
|
||||
|
||||
let rec substitute loc fpc sb rn ulam =
|
||||
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, dbg) ->
|
||||
let dbg = subst_debuginfo loc dbg in
|
||||
Udirect_apply(lbl, List.map (substitute loc fpc sb rn) args, dbg)
|
||||
Udirect_apply(lbl, List.map (substitute loc st sb rn) args, dbg)
|
||||
| Ugeneric_apply(fn, args, dbg) ->
|
||||
let dbg = subst_debuginfo loc dbg in
|
||||
Ugeneric_apply(substitute loc fpc sb rn fn,
|
||||
List.map (substitute loc fpc sb rn) args, dbg)
|
||||
Ugeneric_apply(substitute loc st sb rn fn,
|
||||
List.map (substitute loc st sb rn) args, dbg)
|
||||
| Uclosure(defs, env) ->
|
||||
(* Question: should we rename function labels as well? Otherwise,
|
||||
there is a risk that function labels are not globally unique.
|
||||
|
|
@ -563,12 +566,12 @@ let rec substitute loc fpc sb rn ulam =
|
|||
- 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. *)
|
||||
Uclosure(defs, List.map (substitute loc fpc sb rn) env)
|
||||
| Uoffset(u, ofs) -> Uoffset(substitute loc fpc sb rn u, ofs)
|
||||
Uclosure(defs, List.map (substitute loc st sb rn) env)
|
||||
| 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 fpc sb rn u1,
|
||||
substitute loc fpc
|
||||
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) ->
|
||||
|
|
@ -583,17 +586,17 @@ let rec substitute loc fpc sb rn ulam =
|
|||
in
|
||||
Uletrec(
|
||||
List.map
|
||||
(fun (_id, id', rhs) -> (id', substitute loc fpc sb' rn rhs))
|
||||
(fun (_id, id', rhs) -> (id', substitute loc st sb' rn rhs))
|
||||
bindings1,
|
||||
substitute loc fpc sb' rn body)
|
||||
substitute loc st sb' rn body)
|
||||
| Uprim(p, args, dbg) ->
|
||||
let sargs = List.map (substitute loc fpc sb rn) args in
|
||||
let sargs = List.map (substitute loc st sb rn) args in
|
||||
let dbg = subst_debuginfo loc dbg in
|
||||
let (res, _) =
|
||||
simplif_prim fpc p (sargs, List.map approx_ulam sargs) dbg in
|
||||
simplif_prim ~backend fpc p (sargs, List.map approx_ulam sargs) dbg in
|
||||
res
|
||||
| Uswitch(arg, sw, dbg) ->
|
||||
let sarg = substitute loc fpc sb rn arg in
|
||||
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
|
||||
|
|
@ -609,22 +612,22 @@ let rec substitute loc fpc sb rn ulam =
|
|||
| _ -> None
|
||||
in
|
||||
begin match action with
|
||||
| Some u -> substitute loc fpc sb rn u
|
||||
| Some u -> substitute loc st sb rn u
|
||||
| None ->
|
||||
Uswitch(sarg,
|
||||
{ sw with
|
||||
us_actions_consts =
|
||||
Array.map (substitute loc fpc sb rn) sw.us_actions_consts;
|
||||
Array.map (substitute loc st sb rn) sw.us_actions_consts;
|
||||
us_actions_blocks =
|
||||
Array.map (substitute loc fpc sb rn) sw.us_actions_blocks;
|
||||
Array.map (substitute loc st sb rn) sw.us_actions_blocks;
|
||||
},
|
||||
dbg)
|
||||
end
|
||||
| Ustringswitch(arg,sw,d) ->
|
||||
Ustringswitch
|
||||
(substitute loc fpc sb rn arg,
|
||||
List.map (fun (s,act) -> s,substitute loc fpc sb rn act) sw,
|
||||
Misc.may_map (substitute loc fpc sb rn) d)
|
||||
(substitute loc st sb rn arg,
|
||||
List.map (fun (s,act) -> s,substitute loc st sb rn act) sw,
|
||||
Misc.may_map (substitute loc st sb rn) d)
|
||||
| Ustaticfail (nfail, args) ->
|
||||
let nfail =
|
||||
match rn with
|
||||
|
|
@ -635,7 +638,7 @@ let rec substitute loc fpc sb rn ulam =
|
|||
fatal_errorf "Closure.split_list: invalid nfail (%d)" nfail
|
||||
end
|
||||
| None -> nfail in
|
||||
Ustaticfail (nfail, List.map (substitute loc fpc sb rn) args)
|
||||
Ustaticfail (nfail, List.map (substitute loc st sb rn) args)
|
||||
| Ucatch(nfail, ids, u1, u2) ->
|
||||
let nfail, rn =
|
||||
match rn with
|
||||
|
|
@ -651,34 +654,34 @@ let rec substitute loc fpc sb rn ulam =
|
|||
)
|
||||
ids ids' sb
|
||||
in
|
||||
Ucatch(nfail, ids', substitute loc fpc sb rn u1,
|
||||
substitute loc fpc sb' rn u2)
|
||||
Ucatch(nfail, ids', substitute loc st sb rn u1,
|
||||
substitute loc st sb' rn u2)
|
||||
| Utrywith(u1, id, u2) ->
|
||||
let id' = VP.rename id in
|
||||
Utrywith(substitute loc fpc sb rn u1, id',
|
||||
substitute loc fpc
|
||||
Utrywith(substitute loc st sb rn u1, id',
|
||||
substitute loc st
|
||||
(V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2)
|
||||
| Uifthenelse(u1, u2, u3) ->
|
||||
begin match substitute loc fpc sb rn u1 with
|
||||
begin match substitute loc st sb rn u1 with
|
||||
Uconst (Uconst_ptr n) ->
|
||||
if n <> 0 then
|
||||
substitute loc fpc sb rn u2
|
||||
substitute loc st sb rn u2
|
||||
else
|
||||
substitute loc fpc sb rn u3
|
||||
substitute loc st sb rn u3
|
||||
| Uprim(P.Pmakeblock _, _, _) ->
|
||||
substitute loc fpc sb rn u2
|
||||
substitute loc st sb rn u2
|
||||
| su1 ->
|
||||
Uifthenelse(su1, substitute loc fpc sb rn u2,
|
||||
substitute loc fpc sb rn u3)
|
||||
Uifthenelse(su1, substitute loc st sb rn u2,
|
||||
substitute loc st sb rn u3)
|
||||
end
|
||||
| Usequence(u1, u2) ->
|
||||
Usequence(substitute loc fpc sb rn u1, substitute loc fpc sb rn u2)
|
||||
Usequence(substitute loc st sb rn u1, substitute loc st sb rn u2)
|
||||
| Uwhile(u1, u2) ->
|
||||
Uwhile(substitute loc fpc sb rn u1, substitute loc fpc sb rn 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 fpc sb rn u1, substitute loc fpc sb rn u2, dir,
|
||||
substitute loc fpc
|
||||
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' =
|
||||
|
|
@ -686,11 +689,11 @@ let rec substitute loc fpc sb rn ulam =
|
|||
match V.Map.find id sb with Uvar i -> i | _ -> assert false
|
||||
with Not_found ->
|
||||
id in
|
||||
Uassign(id', substitute loc fpc sb rn u)
|
||||
Uassign(id', substitute loc st sb rn u)
|
||||
| Usend(k, u1, u2, ul, dbg) ->
|
||||
let dbg = subst_debuginfo loc dbg in
|
||||
Usend(k, substitute loc fpc sb rn u1, substitute loc fpc sb rn u2,
|
||||
List.map (substitute loc fpc sb rn) ul, dbg)
|
||||
Usend(k, substitute loc st sb rn u1, substitute loc st sb rn u2,
|
||||
List.map (substitute loc st sb rn) ul, dbg)
|
||||
| Uunreachable ->
|
||||
Uunreachable
|
||||
|
||||
|
|
@ -746,7 +749,7 @@ let warning_if_forced_inline ~loc ~attribute warning =
|
|||
|
||||
(* Generate a direct application *)
|
||||
|
||||
let direct_apply fundesc ufunct uargs ~loc ~attribute =
|
||||
let direct_apply ~backend fundesc ufunct uargs ~loc ~attribute =
|
||||
let app_args =
|
||||
if fundesc.fun_closed then uargs else uargs @ [ufunct] in
|
||||
let app =
|
||||
|
|
@ -757,7 +760,8 @@ let direct_apply fundesc ufunct uargs ~loc ~attribute =
|
|||
"Function information unavailable";
|
||||
Udirect_apply(fundesc.fun_label, app_args, dbg)
|
||||
| Some(params, body), _ ->
|
||||
bind_params loc fundesc.fun_float_const_prop params app_args body
|
||||
bind_params loc (backend, fundesc.fun_float_const_prop) params app_args
|
||||
body
|
||||
in
|
||||
(* If ufunct can contain side-effects or function definitions,
|
||||
we must make sure that it is evaluated exactly once.
|
||||
|
|
@ -818,7 +822,13 @@ let excessive_function_nesting_depth = 5
|
|||
|
||||
exception NotClosed
|
||||
|
||||
let close_approx_var fenv cenv id =
|
||||
type env = {
|
||||
backend : (module Backend_intf.S);
|
||||
cenv : ulambda V.Map.t;
|
||||
fenv : value_approximation V.Map.t;
|
||||
}
|
||||
|
||||
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
|
||||
|
|
@ -826,12 +836,14 @@ let close_approx_var fenv cenv id =
|
|||
let subst = try V.Map.find id cenv with Not_found -> Uvar id in
|
||||
(subst, approx)
|
||||
|
||||
let close_var fenv cenv id =
|
||||
let (ulam, _app) = close_approx_var fenv cenv id in ulam
|
||||
let close_var env id =
|
||||
let (ulam, _app) = close_approx_var env id in ulam
|
||||
|
||||
let rec close fenv cenv = function
|
||||
Lvar id ->
|
||||
close_approx_var fenv cenv id
|
||||
let rec close ({ backend; fenv; cenv } as env) lam =
|
||||
let module B = (val backend : Backend_intf.S) in
|
||||
match lam with
|
||||
| Lvar id ->
|
||||
close_approx_var env id
|
||||
| Lconst cst ->
|
||||
let str ?(shared = true) cst =
|
||||
let name =
|
||||
|
|
@ -865,24 +877,24 @@ let rec close fenv cenv = function
|
|||
in
|
||||
make_const (transl cst)
|
||||
| Lfunction _ as funct ->
|
||||
close_one_function fenv cenv (Ident.create_local "fun") 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_loc = loc;
|
||||
ap_inlined = attribute} ->
|
||||
let nargs = List.length args in
|
||||
begin match (close fenv cenv funct, close_list fenv cenv args) with
|
||||
begin match (close env funct, close_list env args) with
|
||||
((ufunct, Value_closure(fundesc, approx_res)),
|
||||
[Uprim(P.Pmakeblock _, uargs, _)])
|
||||
when List.length uargs = - fundesc.fun_arity ->
|
||||
let app =
|
||||
direct_apply ~loc ~attribute fundesc ufunct uargs in
|
||||
direct_apply ~backend ~loc ~attribute fundesc ufunct uargs in
|
||||
(app, strengthen_approx app approx_res)
|
||||
| ((ufunct, Value_closure(fundesc, approx_res)), uargs)
|
||||
when nargs = fundesc.fun_arity ->
|
||||
let app =
|
||||
direct_apply ~loc ~attribute fundesc ufunct uargs in
|
||||
direct_apply ~backend ~loc ~attribute fundesc ufunct uargs in
|
||||
(app, strengthen_approx app approx_res)
|
||||
|
||||
| ((ufunct, (Value_closure(fundesc, _) as fapprox)), uargs)
|
||||
|
|
@ -905,7 +917,7 @@ let rec close fenv cenv = function
|
|||
in
|
||||
let funct_var = V.create_local "funct" in
|
||||
let fenv = V.Map.add funct_var fapprox fenv in
|
||||
let (new_fun, approx) = close fenv cenv
|
||||
let (new_fun, approx) = close { backend; fenv; cenv }
|
||||
(Lfunction{
|
||||
kind = Curried;
|
||||
return = Pgenval;
|
||||
|
|
@ -935,7 +947,7 @@ let rec close fenv cenv = function
|
|||
let dbg = Debuginfo.from_location loc in
|
||||
warning_if_forced_inline ~loc ~attribute "Over-application";
|
||||
let body =
|
||||
Ugeneric_apply(direct_apply ~loc ~attribute
|
||||
Ugeneric_apply(direct_apply ~backend ~loc ~attribute
|
||||
fundesc ufunct first_args,
|
||||
rem_args, dbg)
|
||||
in
|
||||
|
|
@ -952,22 +964,24 @@ let rec close fenv cenv = function
|
|||
(Ugeneric_apply(ufunct, uargs, dbg), Value_unknown)
|
||||
end
|
||||
| Lsend(kind, met, obj, args, loc) ->
|
||||
let (umet, _) = close fenv cenv met in
|
||||
let (uobj, _) = close fenv cenv obj in
|
||||
let (umet, _) = close env met in
|
||||
let (uobj, _) = close env obj in
|
||||
let dbg = Debuginfo.from_location loc in
|
||||
(Usend(kind, umet, uobj, close_list fenv cenv args, dbg),
|
||||
(Usend(kind, umet, uobj, close_list env args, dbg),
|
||||
Value_unknown)
|
||||
| Llet(str, kind, id, lam, body) ->
|
||||
let (ulam, alam) = close_named fenv cenv id lam in
|
||||
let (ulam, alam) = close_named env id lam in
|
||||
begin match (str, alam) with
|
||||
(Variable, _) ->
|
||||
let (ubody, abody) = close fenv cenv body in
|
||||
let (ubody, abody) = close env body in
|
||||
(Ulet(Mutable, kind, VP.create id, ulam, ubody), abody)
|
||||
| (_, Value_const _)
|
||||
when str = Alias || is_pure ulam ->
|
||||
close (V.Map.add id alam fenv) cenv body
|
||||
close { backend; fenv = (V.Map.add id alam fenv); cenv } body
|
||||
| (_, _) ->
|
||||
let (ubody, abody) = close (V.Map.add id alam fenv) cenv body in
|
||||
let (ubody, abody) =
|
||||
close { backend; fenv = (V.Map.add id alam fenv); cenv } body
|
||||
in
|
||||
(Ulet(Immutable, kind, VP.create id, ulam, ubody), abody)
|
||||
end
|
||||
| Lletrec(defs, body) ->
|
||||
|
|
@ -976,20 +990,21 @@ let rec close fenv cenv = function
|
|||
defs
|
||||
then begin
|
||||
(* Simple case: only function definitions *)
|
||||
let (clos, infos) = close_functions fenv cenv defs in
|
||||
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 (ubody, approx) = close fenv_body cenv body in
|
||||
let (ubody, approx) = close { backend; fenv = fenv_body; cenv } 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, Pgenval, VP.create clos_ident, clos,
|
||||
substitute Location.none !Clflags.float_const_prop sb None ubody),
|
||||
substitute Location.none (backend, !Clflags.float_const_prop) sb
|
||||
None ubody),
|
||||
approx)
|
||||
end else begin
|
||||
(* General case: recursive definition of values *)
|
||||
|
|
@ -997,37 +1012,37 @@ let rec close fenv cenv = function
|
|||
[] -> ([], fenv)
|
||||
| (id, lam) :: rem ->
|
||||
let (udefs, fenv_body) = clos_defs rem in
|
||||
let (ulam, approx) = close_named fenv cenv id lam in
|
||||
let (ulam, approx) = close_named env 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 fenv_body cenv body in
|
||||
let (ubody, approx) = close { backend; fenv = fenv_body; cenv } 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 Arch.big_endian
|
||||
| Word_size -> make_const_int (8*Arch.size_int)
|
||||
| Int_size -> make_const_int (8*Arch.size_int - 1)
|
||||
| Max_wosize -> make_const_int ((1 lsl ((8*Arch.size_int) - 10)) - 1 )
|
||||
| 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_ptr 0 (* tag 0 is the same as Native here *)
|
||||
in
|
||||
let arg, _approx = close fenv cenv arg in
|
||||
let arg, _approx = close env arg in
|
||||
let id = Ident.create_local "dummy" in
|
||||
Ulet(Immutable, Pgenval, VP.create id, arg, cst), approx
|
||||
| Lprim(Pignore, [arg], _loc) ->
|
||||
let expr, approx = make_const_ptr 0 in
|
||||
Usequence(fst (close fenv cenv arg), expr), approx
|
||||
Usequence(fst (close env arg), expr), approx
|
||||
| Lprim((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _loc) ->
|
||||
close fenv cenv arg
|
||||
close env arg
|
||||
| Lprim(Pdirapply,[funct;arg], loc)
|
||||
| Lprim(Prevapply,[arg;funct], loc) ->
|
||||
close fenv cenv (Lapply{ap_should_be_tailcall=false;
|
||||
close env (Lapply{ap_should_be_tailcall=false;
|
||||
ap_loc=loc;
|
||||
ap_func=funct;
|
||||
ap_args=[arg];
|
||||
|
|
@ -1038,19 +1053,19 @@ let rec close fenv cenv = function
|
|||
check_constant_result (getglobal dbg id)
|
||||
(Compilenv.global_approx id)
|
||||
| Lprim(Pfield n, [lam], loc) ->
|
||||
let (ulam, approx) = close fenv cenv lam in
|
||||
let (ulam, approx) = close env lam in
|
||||
let dbg = Debuginfo.from_location loc in
|
||||
check_constant_result (Uprim(P.Pfield n, [ulam], dbg))
|
||||
(field_approx n approx)
|
||||
| Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, [], _); lam], loc)->
|
||||
let (ulam, approx) = close fenv cenv lam in
|
||||
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 id; ulam], dbg),
|
||||
Value_unknown)
|
||||
| Lprim(Praise k, [arg], loc) ->
|
||||
let (ulam, _approx) = close fenv cenv arg in
|
||||
let (ulam, _approx) = close env arg in
|
||||
let dbg = Debuginfo.from_location loc in
|
||||
(Uprim(P.Praise k, [ulam], dbg),
|
||||
Value_unknown)
|
||||
|
|
@ -1058,15 +1073,15 @@ let rec close fenv cenv = function
|
|||
| Lprim(p, args, loc) ->
|
||||
let p = Convert_primitives.convert p in
|
||||
let dbg = Debuginfo.from_location loc in
|
||||
simplif_prim !Clflags.float_const_prop
|
||||
p (close_list_approx fenv cenv args) dbg
|
||||
simplif_prim ~backend !Clflags.float_const_prop
|
||||
p (close_list_approx env args) dbg
|
||||
| Lswitch(arg, sw, dbg) ->
|
||||
let fn fail =
|
||||
let (uarg, _) = close fenv cenv arg in
|
||||
let (uarg, _) = close env arg in
|
||||
let const_index, const_actions, fconst =
|
||||
close_switch fenv cenv sw.sw_consts sw.sw_numconsts fail
|
||||
close_switch env sw.sw_consts sw.sw_numconsts fail
|
||||
and block_index, block_actions, fblock =
|
||||
close_switch fenv cenv sw.sw_blocks sw.sw_numblocks fail in
|
||||
close_switch env sw.sw_blocks sw.sw_numblocks fail in
|
||||
let ulam =
|
||||
Uswitch
|
||||
(uarg,
|
||||
|
|
@ -1088,88 +1103,88 @@ let rec close fenv cenv = function
|
|||
then
|
||||
let i = next_raise_count () in
|
||||
let ubody,_ = fn (Some (Lstaticraise (i,[])))
|
||||
and uhandler,_ = close fenv cenv lamfail in
|
||||
and uhandler,_ = close env lamfail in
|
||||
Ucatch (i,[],ubody,uhandler),Value_unknown
|
||||
else fn fail
|
||||
end
|
||||
| Lstringswitch(arg,sw,d,_) ->
|
||||
let uarg,_ = close fenv cenv arg in
|
||||
let uarg,_ = close env arg in
|
||||
let usw =
|
||||
List.map
|
||||
(fun (s,act) ->
|
||||
let uact,_ = close fenv cenv act in
|
||||
let uact,_ = close env act in
|
||||
s,uact)
|
||||
sw in
|
||||
let ud =
|
||||
Misc.may_map
|
||||
(fun d ->
|
||||
let ud,_ = close fenv cenv d in
|
||||
let ud,_ = close env d in
|
||||
ud) d in
|
||||
Ustringswitch (uarg,usw,ud),Value_unknown
|
||||
| Lstaticraise (i, args) ->
|
||||
(Ustaticfail (i, close_list fenv cenv args), Value_unknown)
|
||||
(Ustaticfail (i, close_list env args), Value_unknown)
|
||||
| Lstaticcatch(body, (i, vars), handler) ->
|
||||
let (ubody, _) = close fenv cenv body in
|
||||
let (uhandler, _) = close fenv cenv handler in
|
||||
let (ubody, _) = close env body in
|
||||
let (uhandler, _) = close env handler in
|
||||
let vars = List.map (fun (var, k) -> VP.create var, k) vars in
|
||||
(Ucatch(i, vars, ubody, uhandler), Value_unknown)
|
||||
| Ltrywith(body, id, handler) ->
|
||||
let (ubody, _) = close fenv cenv body in
|
||||
let (uhandler, _) = close fenv cenv handler in
|
||||
let (ubody, _) = close env body in
|
||||
let (uhandler, _) = close env handler in
|
||||
(Utrywith(ubody, VP.create id, uhandler), Value_unknown)
|
||||
| Lifthenelse(arg, ifso, ifnot) ->
|
||||
begin match close fenv cenv arg with
|
||||
begin match close env arg with
|
||||
(uarg, Value_const (Uconst_ptr n)) ->
|
||||
sequence_constant_expr uarg
|
||||
(close fenv cenv (if n = 0 then ifnot else ifso))
|
||||
(close env (if n = 0 then ifnot else ifso))
|
||||
| (uarg, _ ) ->
|
||||
let (uifso, _) = close fenv cenv ifso in
|
||||
let (uifnot, _) = close fenv cenv ifnot in
|
||||
let (uifso, _) = close env ifso in
|
||||
let (uifnot, _) = close env ifnot in
|
||||
(Uifthenelse(uarg, uifso, uifnot), Value_unknown)
|
||||
end
|
||||
| Lsequence(lam1, lam2) ->
|
||||
let (ulam1, _) = close fenv cenv lam1 in
|
||||
let (ulam2, approx) = close fenv cenv lam2 in
|
||||
let (ulam1, _) = close env lam1 in
|
||||
let (ulam2, approx) = close env lam2 in
|
||||
(Usequence(ulam1, ulam2), approx)
|
||||
| Lwhile(cond, body) ->
|
||||
let (ucond, _) = close fenv cenv cond in
|
||||
let (ubody, _) = close fenv cenv body in
|
||||
let (ucond, _) = close env cond in
|
||||
let (ubody, _) = close env body in
|
||||
(Uwhile(ucond, ubody), Value_unknown)
|
||||
| Lfor(id, lo, hi, dir, body) ->
|
||||
let (ulo, _) = close fenv cenv lo in
|
||||
let (uhi, _) = close fenv cenv hi in
|
||||
let (ubody, _) = close fenv cenv body in
|
||||
let (ulo, _) = close env lo in
|
||||
let (uhi, _) = close env hi in
|
||||
let (ubody, _) = close env body in
|
||||
(Ufor(VP.create id, ulo, uhi, dir, ubody), Value_unknown)
|
||||
| Lassign(id, lam) ->
|
||||
let (ulam, _) = close fenv cenv lam in
|
||||
let (ulam, _) = close env lam in
|
||||
(Uassign(id, ulam), Value_unknown)
|
||||
| Levent(lam, _) ->
|
||||
close fenv cenv lam
|
||||
close env lam
|
||||
| Lifused _ ->
|
||||
assert false
|
||||
|
||||
and close_list fenv cenv = function
|
||||
and close_list env = function
|
||||
[] -> []
|
||||
| lam :: rem ->
|
||||
let (ulam, _) = close fenv cenv lam in
|
||||
ulam :: close_list fenv cenv rem
|
||||
let (ulam, _) = close env lam in
|
||||
ulam :: close_list env rem
|
||||
|
||||
and close_list_approx fenv cenv = function
|
||||
and close_list_approx env = function
|
||||
[] -> ([], [])
|
||||
| lam :: rem ->
|
||||
let (ulam, approx) = close fenv cenv lam in
|
||||
let (ulams, approxs) = close_list_approx fenv cenv rem in
|
||||
let (ulam, approx) = close env lam in
|
||||
let (ulams, approxs) = close_list_approx env rem in
|
||||
(ulam :: ulams, approx :: approxs)
|
||||
|
||||
and close_named fenv cenv id = function
|
||||
and close_named env id = function
|
||||
Lfunction _ as funct ->
|
||||
close_one_function fenv cenv id funct
|
||||
close_one_function env id funct
|
||||
| lam ->
|
||||
close fenv cenv lam
|
||||
close env lam
|
||||
|
||||
(* Build a shared closure for a set of mutually recursive functions *)
|
||||
|
||||
and close_functions fenv cenv fun_defs =
|
||||
and close_functions { backend; fenv; cenv } fun_defs =
|
||||
let fun_defs =
|
||||
List.flatten
|
||||
(List.map
|
||||
|
|
@ -1240,7 +1255,9 @@ and close_functions fenv cenv fun_defs =
|
|||
(fun (id, _params, _return, _body, _fundesc, _dbg) pos env ->
|
||||
V.Map.add id (Uoffset(Uvar env_param, pos - env_pos)) env)
|
||||
uncurried_defs clos_offsets cenv_fv in
|
||||
let (ubody, approx) = close fenv_rec cenv_body body in
|
||||
let (ubody, approx) =
|
||||
close { backend; fenv = fenv_rec; cenv = cenv_body } body
|
||||
in
|
||||
if !useless_env && occurs_var env_param ubody then raise NotClosed;
|
||||
let fun_params =
|
||||
if !useless_env
|
||||
|
|
@ -1311,18 +1328,18 @@ and close_functions fenv cenv fun_defs =
|
|||
with offsets and approximations. *)
|
||||
let (clos, infos) = List.split clos_info_list in
|
||||
let fv = if !useless_env then [] else fv in
|
||||
(Uclosure(clos, List.map (close_var fenv cenv) fv), infos)
|
||||
(Uclosure(clos, List.map (close_var { backend; fenv; cenv }) fv), infos)
|
||||
|
||||
(* Same, for one non-recursive function *)
|
||||
|
||||
and close_one_function fenv cenv id funct =
|
||||
match close_functions fenv cenv [id, funct] with
|
||||
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 fenv cenv cases num_keys default =
|
||||
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
|
||||
|
|
@ -1349,10 +1366,10 @@ and close_switch fenv cenv cases num_keys default =
|
|||
Array.map
|
||||
(function
|
||||
| Single lam|Shared (Lstaticraise (_,[]) as lam) ->
|
||||
let ulam,_ = close fenv cenv lam in
|
||||
let ulam,_ = close env lam in
|
||||
ulam
|
||||
| Shared lam ->
|
||||
let ulam,_ = close fenv cenv lam in
|
||||
let ulam,_ = close env lam in
|
||||
let i = next_raise_count () in
|
||||
(*
|
||||
let string_of_lambda e =
|
||||
|
|
@ -1436,12 +1453,14 @@ let reset () =
|
|||
|
||||
(* The entry point *)
|
||||
|
||||
let intro size lam =
|
||||
let intro ~backend ~size lam =
|
||||
reset ();
|
||||
let id = Compilenv.make_symbol None in
|
||||
global_approx := Array.init size (fun i -> Value_global_field (id, i));
|
||||
Compilenv.set_global_approx(Value_tuple !global_approx);
|
||||
let (ulam, _approx) = close V.Map.empty V.Map.empty lam in
|
||||
let (ulam, _approx) =
|
||||
close { backend; fenv = V.Map.empty; cenv = V.Map.empty } lam
|
||||
in
|
||||
let opaque =
|
||||
!Clflags.opaque
|
||||
|| Env.is_imported_opaque (Compilenv.current_unit_name ())
|
||||
|
|
@ -15,5 +15,10 @@
|
|||
|
||||
(* Introduction of closures, uncurrying, recognition of direct calls *)
|
||||
|
||||
val intro: int -> Lambda.lambda -> Clambda.ulambda
|
||||
val intro
|
||||
: backend:(module Backend_intf.S)
|
||||
-> size:int
|
||||
-> Lambda.lambda
|
||||
-> Clambda.ulambda
|
||||
|
||||
val reset : unit -> unit
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue