Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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 2019-04-01 17:18:47 +01:00 committed by GitHub
parent 36d299b4aa
commit 72ea849d2a
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
212 changed files with 3345 additions and 3220 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5637
.depend
View File

File diff suppressed because it is too large Load Diff

3
Changes
View File

@ -73,6 +73,9 @@ Working version
- #2280: Don't make more Clambda constants after starting Cmmgen - #2280: Don't make more Clambda constants after starting Cmmgen
(Mark Shinwell, review by Vincent Laviron) (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 - #2283: Add [is_prefix] and [find_and_chop_longest_common_prefix] to
[Misc.Stdlib.List] [Misc.Stdlib.List]
(Mark Shinwell, review by Alain Frisch and Stephen Dolan) (Mark Shinwell, review by Alain Frisch and Stephen Dolan)

268
Makefile
View File

@ -46,8 +46,10 @@ include stdlib/StdlibModules
CAMLC=$(BOOT_OCAMLC) -g -nostdlib -I boot -use-prims runtime/primitives CAMLC=$(BOOT_OCAMLC) -g -nostdlib -I boot -use-prims runtime/primitives
CAMLOPT=$(CAMLRUN) ./ocamlopt -g -nostdlib -I stdlib -I otherlibs/dynlink CAMLOPT=$(CAMLRUN) ./ocamlopt -g -nostdlib -I stdlib -I otherlibs/dynlink
ARCHES=amd64 i386 arm arm64 power s390x ARCHES=amd64 i386 arm arm64 power s390x
INCLUDES=-I utils -I parsing -I typing -I bytecomp -I middle_end \ INCLUDES=-I utils -I parsing -I typing -I bytecomp -I file_formats \
-I middle_end/base_types -I asmcomp -I asmcomp/debug \ -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 -I driver -I toplevel
COMPFLAGS=-strict-sequence -principal -absname -w +a-4-9-41-42-44-45-48-66 \ 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/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
utils/consistbl.cmo \ utils/consistbl.cmo \
utils/strongly_connected_components.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=parsing/location.cmo parsing/longident.cmo \
parsing/docstrings.cmo parsing/syntaxerr.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/primitive.cmo typing/types.cmo \
typing/btype.cmo typing/oprint.cmo \ typing/btype.cmo typing/oprint.cmo \
typing/subst.cmo typing/predef.cmo \ typing/subst.cmo typing/predef.cmo \
typing/datarepr.cmo typing/cmi_format.cmo \ typing/datarepr.cmo file_formats/cmi_format.cmo \
typing/persistent_env.cmo \ typing/persistent_env.cmo typing/env.cmo \
typing/env.cmo \
typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \ typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \
typing/printtyp.cmo typing/includeclass.cmo \ typing/printtyp.cmo typing/includeclass.cmo \
typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \ typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \
typing/tast_iterator.cmo typing/tast_mapper.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/includemod.cmo typing/typetexp.cmo typing/printpat.cmo \
typing/parmatch.cmo typing/stypes.cmo \ typing/parmatch.cmo typing/stypes.cmo \
typing/typedecl_properties.cmo typing/typedecl_variance.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/rec_check.cmo typing/typecore.cmo typing/typeclass.cmo \
typing/typemod.cmo typing/typemod.cmo
COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \ LAMBDA=lambda/debuginfo.cmo \
bytecomp/switch.cmo bytecomp/matching.cmo \ lambda/lambda.cmo lambda/printlambda.cmo \
bytecomp/translobj.cmo bytecomp/translattribute.cmo \ lambda/switch.cmo lambda/matching.cmo \
bytecomp/translprim.cmo bytecomp/translcore.cmo \ lambda/translobj.cmo lambda/translattribute.cmo \
bytecomp/translclass.cmo bytecomp/translmod.cmo \ lambda/translprim.cmo lambda/translcore.cmo \
bytecomp/simplif.cmo bytecomp/runtimedef.cmo \ lambda/translclass.cmo lambda/translmod.cmo \
lambda/simplif.cmo lambda/runtimedef.cmo
COMP=\
bytecomp/meta.cmo bytecomp/opcodes.cmo \ bytecomp/meta.cmo bytecomp/opcodes.cmo \
bytecomp/bytesections.cmo bytecomp/dll.cmo \ bytecomp/bytesections.cmo bytecomp/dll.cmo \
bytecomp/symtable.cmo \ bytecomp/symtable.cmo \
@ -121,8 +126,7 @@ COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
driver/makedepend.cmo \ driver/makedepend.cmo \
driver/compile_common.cmo driver/compile_common.cmo
COMMON=$(UTILS) $(PARSING) $(TYPING) $(LAMBDA) $(COMP)
COMMON=$(UTILS) $(PARSING) $(TYPING) $(COMP)
BYTECOMP=bytecomp/instruct.cmo bytecomp/bytegen.cmo \ BYTECOMP=bytecomp/instruct.cmo bytecomp/bytegen.cmo \
bytecomp/printinstr.cmo bytecomp/emitcode.cmo \ bytecomp/printinstr.cmo bytecomp/emitcode.cmo \
@ -150,22 +154,10 @@ endif
ASMCOMP=\ ASMCOMP=\
$(ARCH_SPECIFIC_ASMCOMP) \ $(ARCH_SPECIFIC_ASMCOMP) \
asmcomp/arch.cmo \ asmcomp/arch.cmo \
asmcomp/backend_var.cmo \
asmcomp/cmm.cmo asmcomp/printcmm.cmo \ asmcomp/cmm.cmo asmcomp/printcmm.cmo \
asmcomp/reg.cmo asmcomp/debug/reg_with_debug_info.cmo \ asmcomp/reg.cmo asmcomp/debug/reg_with_debug_info.cmo \
asmcomp/debug/reg_availability_set.cmo \ asmcomp/debug/reg_availability_set.cmo \
asmcomp/mach.cmo asmcomp/proc.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/afl_instrument.cmo \
asmcomp/strmatch.cmo \ asmcomp/strmatch.cmo \
asmcomp/cmmgen_state.cmo \ asmcomp/cmmgen_state.cmo \
@ -192,72 +184,96 @@ ASMCOMP=\
asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo \ asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo \
driver/opterrors.cmo driver/optcompile.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=\
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/internal_variable_names.cmo \
middle_end/base_types/variable.cmo \ middle_end/linkage_name.cmo \
middle_end/base_types/mutable_variable.cmo \ middle_end/compilation_unit.cmo \
middle_end/base_types/id_types.cmo \ middle_end/variable.cmo \
middle_end/base_types/set_of_closures_id.cmo \ middle_end/flambda/base_types/closure_element.cmo \
middle_end/base_types/set_of_closures_origin.cmo \ middle_end/flambda/base_types/closure_id.cmo \
middle_end/base_types/closure_element.cmo \ middle_end/symbol.cmo \
middle_end/base_types/closure_id.cmo \ middle_end/backend_var.cmo \
middle_end/base_types/closure_origin.cmo \ middle_end/clambda_primitives.cmo \
middle_end/base_types/var_within_closure.cmo \ middle_end/printclambda_primitives.cmo \
middle_end/base_types/static_exception.cmo \ middle_end/clambda.cmo \
middle_end/base_types/export_id.cmo \ middle_end/printclambda.cmo \
middle_end/base_types/symbol.cmo \ middle_end/semantics_of_primitives.cmo \
middle_end/pass_wrapper.cmo \ middle_end/convert_primitives.cmo \
middle_end/allocated_const.cmo \ middle_end/flambda/base_types/id_types.cmo \
middle_end/parameter.cmo \ middle_end/flambda/base_types/export_id.cmo \
middle_end/projection.cmo \ middle_end/flambda/base_types/tag.cmo \
middle_end/flambda.cmo \ middle_end/flambda/base_types/mutable_variable.cmo \
middle_end/flambda_iterators.cmo \ middle_end/flambda/base_types/set_of_closures_id.cmo \
middle_end/flambda_utils.cmo \ middle_end/flambda/base_types/set_of_closures_origin.cmo \
middle_end/inlining_cost.cmo \ middle_end/flambda/base_types/closure_origin.cmo \
middle_end/effect_analysis.cmo \ middle_end/flambda/base_types/var_within_closure.cmo \
middle_end/freshening.cmo \ middle_end/flambda/base_types/static_exception.cmo \
middle_end/simple_value_approx.cmo \ middle_end/flambda/pass_wrapper.cmo \
middle_end/lift_code.cmo \ middle_end/flambda/allocated_const.cmo \
middle_end/closure_conversion_aux.cmo \ middle_end/flambda/parameter.cmo \
middle_end/closure_conversion.cmo \ middle_end/flambda/projection.cmo \
middle_end/initialize_symbol_to_let_symbol.cmo \ middle_end/flambda/flambda.cmo \
middle_end/lift_let_to_initialize_symbol.cmo \ middle_end/flambda/flambda_iterators.cmo \
middle_end/find_recursive_functions.cmo \ middle_end/flambda/flambda_utils.cmo \
middle_end/invariant_params.cmo \ middle_end/flambda/freshening.cmo \
middle_end/inconstant_idents.cmo \ middle_end/flambda/effect_analysis.cmo \
middle_end/alias_analysis.cmo \ middle_end/flambda/inlining_cost.cmo \
middle_end/lift_constants.cmo \ middle_end/flambda/simple_value_approx.cmo \
middle_end/share_constants.cmo \ middle_end/flambda/export_info.cmo \
middle_end/simplify_common.cmo \ middle_end/flambda/export_info_for_pack.cmo \
middle_end/remove_unused_arguments.cmo \ middle_end/compilenv.cmo \
middle_end/remove_unused_closure_vars.cmo \ $(MIDDLE_END_CLOSURE) \
middle_end/remove_unused_program_constructs.cmo \ $(MIDDLE_END_FLAMBDA)
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
OPTCOMP=$(MIDDLE_END) $(ASMCOMP) OPTCOMP=$(MIDDLE_END) $(ASMCOMP)
@ -541,6 +557,8 @@ endif
parsing/*.cmi \ parsing/*.cmi \
typing/*.cmi \ typing/*.cmi \
bytecomp/*.cmi \ bytecomp/*.cmi \
file_formats/*.cmi \
lambda/*.cmi \
driver/*.cmi \ driver/*.cmi \
toplevel/*.cmi \ toplevel/*.cmi \
"$(INSTALL_COMPLIBDIR)" "$(INSTALL_COMPLIBDIR)"
@ -549,6 +567,8 @@ ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true"
utils/*.cmt utils/*.cmti utils/*.mli \ utils/*.cmt utils/*.cmti utils/*.mli \
parsing/*.cmt parsing/*.cmti parsing/*.mli \ parsing/*.cmt parsing/*.cmti parsing/*.mli \
typing/*.cmt typing/*.cmti typing/*.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 \ bytecomp/*.cmt bytecomp/*.cmti bytecomp/*.mli \
driver/*.cmt driver/*.cmti driver/*.mli \ driver/*.cmt driver/*.cmti driver/*.mli \
toplevel/*.cmt toplevel/*.cmti toplevel/*.mli \ toplevel/*.cmt toplevel/*.cmti toplevel/*.mli \
@ -614,7 +634,13 @@ endif
middle_end/*.cmi \ middle_end/*.cmi \
"$(INSTALL_COMPLIBDIR)" "$(INSTALL_COMPLIBDIR)"
$(INSTALL_DATA) \ $(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_COMPLIBDIR)"
$(INSTALL_DATA) \ $(INSTALL_DATA) \
asmcomp/*.cmi \ asmcomp/*.cmi \
@ -625,8 +651,17 @@ ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true"
middle_end/*.mli \ middle_end/*.mli \
"$(INSTALL_COMPLIBDIR)" "$(INSTALL_COMPLIBDIR)"
$(INSTALL_DATA) \ $(INSTALL_DATA) \
middle_end/base_types/*.cmt middle_end/base_types/*.cmti \ middle_end/closure/*.cmt middle_end/closure/*.cmti \
middle_end/base_types/*.mli \ 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_COMPLIBDIR)"
$(INSTALL_DATA) \ $(INSTALL_DATA) \
asmcomp/*.cmt asmcomp/*.cmti \ asmcomp/*.cmt asmcomp/*.cmti \
@ -670,8 +705,13 @@ installoptopt:
$(LN) ocamllex.opt$(EXE) ocamllex$(EXE) $(LN) ocamllex.opt$(EXE) ocamllex$(EXE)
$(INSTALL_DATA) \ $(INSTALL_DATA) \
utils/*.cmx parsing/*.cmx typing/*.cmx bytecomp/*.cmx \ utils/*.cmx parsing/*.cmx typing/*.cmx bytecomp/*.cmx \
file_formats/*.cmx \
lambda/*.cmx \
driver/*.cmx asmcomp/*.cmx middle_end/*.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) \ $(INSTALL_DATA) \
compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \
compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \ compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \
@ -700,7 +740,10 @@ install-compiler-sources:
ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true" ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true"
$(INSTALL_DATA) \ $(INSTALL_DATA) \
utils/*.ml parsing/*.ml typing/*.ml bytecomp/*.ml driver/*.ml \ 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 \ asmcomp/*.ml \
"$(INSTALL_COMPLIBDIR)" "$(INSTALL_COMPLIBDIR)"
endif endif
@ -857,14 +900,14 @@ $(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(OPTCOMP:.cmo=.cmx): ocamlopt
runtime/primitives: runtime/primitives:
$(MAKE) -C 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 runtime/primitives
$^ > $@ $^ > $@
partialclean:: 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 # Choose the right machine-dependent files
@ -1109,10 +1152,7 @@ lintapidiff:
grep -Ev internal\|obj\|spacetime\|stdLabels\|moreLabels |\ grep -Ev internal\|obj\|spacetime\|stdLabels\|moreLabels |\
tools/lintapidiff.opt $(VERSIONS) tools/lintapidiff.opt $(VERSIONS)
# The middle end (whose .cma library is currently only used for linking # The middle end.
# 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).
compilerlibs/ocamlmiddleend.cma: $(MIDDLE_END) compilerlibs/ocamlmiddleend.cma: $(MIDDLE_END)
$(CAMLC) -a -o $@ $^ $(CAMLC) -a -o $@ $^
@ -1126,9 +1166,7 @@ partialclean::
# Tools # Tools
.PHONY: ocamltools .PHONY: ocamltools
ocamltools: ocamlc ocamllex asmcomp/cmx_format.cmi \ ocamltools: ocamlc ocamllex compilerlibs/ocamlmiddleend.cma
asmcomp/printclambda.cmo compilerlibs/ocamlmiddleend.cma \
asmcomp/export_info.cmo
$(MAKE) -C tools all $(MAKE) -C tools all
.PHONY: ocamltoolsopt .PHONY: ocamltoolsopt
@ -1136,9 +1174,7 @@ ocamltoolsopt: ocamlopt
$(MAKE) -C tools opt $(MAKE) -C tools opt
.PHONY: ocamltoolsopt.opt .PHONY: ocamltoolsopt.opt
ocamltoolsopt.opt: ocamlc.opt ocamllex.opt asmcomp/cmx_format.cmi \ ocamltoolsopt.opt: ocamlc.opt ocamllex.opt compilerlibs/ocamlmiddleend.cmxa
asmcomp/printclambda.cmx compilerlibs/ocamlmiddleend.cmxa \
asmcomp/export_info.cmx
$(MAKE) -C tools opt.opt $(MAKE) -C tools opt.opt
partialclean:: partialclean::
@ -1261,8 +1297,10 @@ partialclean::
$(CAMLOPT) $(COMPFLAGS) -c $< $(CAMLOPT) $(COMPFLAGS) -c $<
partialclean:: partialclean::
for d in utils parsing typing bytecomp asmcomp middle_end \ for d in utils parsing typing bytecomp asmcomp middle_end file_formats \
middle_end/base_types asmcomp/debug driver toplevel tools; do \ 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) \ rm -f $$d/*.cm[ioxt] $$d/*.cmti $$d/*.annot $$d/*.$(S) \
$$d/*.$(O) $$d/*.$(SO) $$d/*~; \ $$d/*.$(O) $$d/*.$(SO) $$d/*~; \
done done
@ -1271,9 +1309,11 @@ partialclean::
.PHONY: depend .PHONY: depend
depend: beforedepend depend: beforedepend
(for d in utils parsing typing bytecomp asmcomp middle_end \ (for d in utils parsing typing bytecomp asmcomp middle_end \
middle_end/base_types asmcomp/debug driver toplevel; \ lambda file_formats middle_end/closure middle_end/flambda \
do $(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) $$d/*.mli $$d/*.ml || exit; \ middle_end/flambda/base_types asmcomp/debug \
done) > .depend driver toplevel; \
do $(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) $$d/*.mli $$d/*.ml || exit; \
done) > .depend
.PHONY: distclean .PHONY: distclean
distclean: clean distclean: clean

1
asmcomp/amd64/emit.mlp
View File

@ -33,6 +33,7 @@ module String = Misc.Stdlib.String
emit.mlp files for certain other targets; the reference here ensures emit.mlp files for certain other targets; the reference here ensures
that when releases are being prepared the .depend files are correct that when releases are being prepared the .depend files are correct
for all targets. *) for all targets. *)
[@@@ocaml.warning "-66"]
open! Branch_relaxation open! Branch_relaxation
let _label s = D.label ~typ:QWORD s let _label s = D.label ~typ:QWORD s

10
asmcomp/asmgen.ml
View File

@ -221,9 +221,11 @@ let flambda_gen_implementation ?toplevel ~backend ~ppf_dump
end_gen_implementation ?toplevel ~ppf_dump end_gen_implementation ?toplevel ~ppf_dump
(clambda, preallocated, constants) (clambda, preallocated, constants)
let lambda_gen_implementation ?toplevel ~ppf_dump let lambda_gen_implementation ?toplevel ~backend ~ppf_dump
(lambda:Lambda.program) = (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 = let provenance : Clambda.usymbol_provenance =
{ original_idents = []; { original_idents = [];
module_path = module_path =
@ -259,10 +261,10 @@ let compile_implementation_gen ?toplevel prefixname
gen_implementation ?toplevel ~ppf_dump program) gen_implementation ?toplevel ~ppf_dump program)
let compile_implementation_clambda ?toplevel prefixname let compile_implementation_clambda ?toplevel prefixname
~ppf_dump (program:Lambda.program) = ~backend ~ppf_dump (program:Lambda.program) =
compile_implementation_gen ?toplevel prefixname compile_implementation_gen ?toplevel prefixname
~required_globals:program.Lambda.required_globals ~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 let compile_implementation_flambda ?toplevel prefixname
~required_globals ~backend ~ppf_dump (program:Flambda.program) = ~required_globals ~backend ~ppf_dump (program:Flambda.program) =

1
asmcomp/asmgen.mli
View File

@ -25,6 +25,7 @@ val compile_implementation_flambda :
val compile_implementation_clambda : val compile_implementation_clambda :
?toplevel:(string -> bool) -> ?toplevel:(string -> bool) ->
string -> string ->
backend:(module Backend_intf.S) ->
ppf_dump:Format.formatter -> Lambda.program -> unit ppf_dump:Format.formatter -> Lambda.program -> unit
val compile_phrase : val compile_phrase :

4
asmcomp/asmpackager.ml
View File

@ -102,7 +102,7 @@ let make_package_object ~ppf_dump members targetobj targetname coercion
if Config.flambda then begin if Config.flambda then begin
let size, lam = Translmod.transl_package_flambda components coercion in let size, lam = Translmod.transl_package_flambda components coercion in
let flam = let flam =
Middle_end.middle_end ~ppf_dump Flambda_middle_end.middle_end ~ppf_dump
~prefixname ~prefixname
~backend ~backend
~size ~size
@ -117,7 +117,7 @@ let make_package_object ~ppf_dump members targetobj targetname coercion
Translmod.transl_store_package Translmod.transl_store_package
components (Ident.create_persistent targetname) coercion in components (Ident.create_persistent targetname) coercion in
Asmgen.compile_implementation_clambda 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 } module_ident; required_globals = Ident.Set.empty }
end; end;
let objfiles = let objfiles =

8
bytecomp/dune
View File

@ -18,11 +18,3 @@
(deps (:instr (file ../runtime/caml/instruct.h))) (deps (:instr (file ../runtime/caml/instruct.h)))
(action (action
(bash "%{dep:../tools/make_opcodes.exe} -opcodes < %{instr} > %{targets}"))) (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}))))

8
debugger/.depend
View File

@ -286,6 +286,7 @@ main.cmo : \
question.cmi \ question.cmi \
program_management.cmi \ program_management.cmi \
primitives.cmi \ primitives.cmi \
../typing/persistent_env.cmi \
parameters.cmi \ parameters.cmi \
../utils/misc.cmi \ ../utils/misc.cmi \
loadprinter.cmi \ loadprinter.cmi \
@ -293,11 +294,10 @@ main.cmo : \
input_handling.cmi \ input_handling.cmi \
frames.cmi \ frames.cmi \
exec.cmi \ exec.cmi \
../typing/env.cmi \
debugger_config.cmi \ debugger_config.cmi \
../utils/config.cmi \ ../utils/config.cmi \
command_line.cmi \ command_line.cmi \
../typing/cmi_format.cmi \ ../file_formats/cmi_format.cmi \
../utils/clflags.cmi \ ../utils/clflags.cmi \
checkpoints.cmi checkpoints.cmi
main.cmx : \ main.cmx : \
@ -308,6 +308,7 @@ main.cmx : \
question.cmx \ question.cmx \
program_management.cmx \ program_management.cmx \
primitives.cmx \ primitives.cmx \
../typing/persistent_env.cmx \
parameters.cmx \ parameters.cmx \
../utils/misc.cmx \ ../utils/misc.cmx \
loadprinter.cmx \ loadprinter.cmx \
@ -315,11 +316,10 @@ main.cmx : \
input_handling.cmx \ input_handling.cmx \
frames.cmx \ frames.cmx \
exec.cmx \ exec.cmx \
../typing/env.cmx \
debugger_config.cmx \ debugger_config.cmx \
../utils/config.cmx \ ../utils/config.cmx \
command_line.cmx \ command_line.cmx \
../typing/cmi_format.cmx \ ../file_formats/cmi_format.cmx \
../utils/clflags.cmx \ ../utils/clflags.cmx \
checkpoints.cmx checkpoints.cmx
parameters.cmo : \ parameters.cmo : \

17
debugger/Makefile
View File

@ -34,7 +34,7 @@ DEPFLAGS=-slash
DEPINCLUDES=$(INCLUDES) DEPINCLUDES=$(INCLUDES)
DIRECTORIES=$(UNIXDIR) $(DYNLINKDIR) $(addprefix $(ROOTDIR)/,\ DIRECTORIES=$(UNIXDIR) $(DYNLINKDIR) $(addprefix $(ROOTDIR)/,\
utils parsing typing bytecomp toplevel) utils parsing typing bytecomp toplevel driver file_formats lambda)
INCLUDES=$(addprefix -I ,$(DIRECTORIES)) INCLUDES=$(addprefix -I ,$(DIRECTORIES))
@ -48,16 +48,23 @@ parsing_modules := $(addprefix parsing/,\
typing_modules := $(addprefix typing/,\ typing_modules := $(addprefix typing/,\
ident path types btype primitive typedtree subst predef datarepr \ 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/,\ bytecomp_modules := $(addprefix bytecomp/,\
runtimedef bytesections dll meta symtable opcodes) bytesections dll meta symtable opcodes)
other_compiler_modules := toplevel/genprintval other_compiler_modules := toplevel/genprintval
compiler_modules := $(addprefix $(ROOTDIR)/,\ compiler_modules := $(addprefix $(ROOTDIR)/,\
$(utils_modules) $(parsing_modules) $(typing_modules) \ $(utils_modules) $(parsing_modules) $(file_formats_modules) \
$(bytecomp_modules) $(other_compiler_modules)) $(lambda_modules) \
$(typing_modules) $(bytecomp_modules) $(other_compiler_modules))
debugger_modules := \ debugger_modules := \
int64ops primitives unix_tools debugger_config parameters lexer \ int64ops primitives unix_tools debugger_config parameters lexer \

22
debugger/dune
View File

@ -12,14 +12,16 @@
;* * ;* *
;************************************************************************** ;**************************************************************************
(ocamllex lexer) ; mshinwell: Disabled for now -- otherlibs/dynlink/dune needs fixing first.
(ocamlyacc parser)
(executable ;(ocamllex lexer)
(name main) ;(ocamlyacc parser)
(modes byte) ;
(flags (:standard -w -9)) ;(executable
(modules_without_implementation parser_aux) ; (name main)
(libraries ocamlcommon ocamltoplevel runtime stdlib unix)) ; (modes byte)
; (flags (:standard -w -9))
(rule (copy main.exe ocamldebug.byte)) ; (modules_without_implementation parser_aux)
; (libraries ocamlcommon ocamltoplevel runtime stdlib unix))
;
;(rule (copy main.exe ocamldebug.byte))

8
driver/optcompile.ml
View File

@ -49,7 +49,7 @@ let flambda i backend typed =
|>> 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, size), lam) ->
Middle_end.middle_end Flambda_middle_end.middle_end
~ppf_dump:i.ppf_dump ~ppf_dump:i.ppf_dump
~prefixname:i.output_prefix ~prefixname:i.output_prefix
~size ~size
@ -61,7 +61,7 @@ let flambda i backend typed =
i.output_prefix ~required_globals ~backend ~ppf_dump:i.ppf_dump; i.output_prefix ~required_globals ~backend ~ppf_dump:i.ppf_dump;
Compilenv.save_unit_info (cmx i)) Compilenv.save_unit_info (cmx i))
let clambda i typed = let clambda i backend typed =
Clflags.use_inlining_arguments_set Clflags.classic_arguments; Clflags.use_inlining_arguments_set Clflags.classic_arguments;
typed typed
|> Profile.(record transl) |> Profile.(record transl)
@ -73,7 +73,7 @@ let clambda i typed =
{ 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_clambda
i.output_prefix ~ppf_dump:i.ppf_dump; i.output_prefix ~backend ~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 =
@ -81,7 +81,7 @@ let implementation ~backend ~source_file ~output_prefix =
Compilenv.reset ?packname:!Clflags.for_package info.module_name; Compilenv.reset ?packname:!Clflags.for_package info.module_name;
if Config.flambda if Config.flambda
then flambda info backend typed then flambda info backend typed
else clambda info typed else clambda info backend typed
in in
with_info ~source_file ~output_prefix ~dump_ext:"cmx" @@ fun info -> with_info ~source_file ~output_prefix ~dump_ext:"cmx" @@ fun info ->
Compile_common.implementation info ~backend Compile_common.implementation info ~backend

1
driver/optcompile.mli
View File

@ -25,6 +25,7 @@ val implementation:
val clambda : val clambda :
Compile_common.info -> Compile_common.info ->
(module Backend_intf.S) ->
Typedtree.structure * Typedtree.module_coercion -> unit Typedtree.structure * Typedtree.module_coercion -> unit
(** [clambda info typed] applies the regular compilation pipeline to the (** [clambda info typed] applies the regular compilation pipeline to the
given typechecked implementation and outputs the resulting files. given typechecked implementation and outputs the resulting files.

142
dune
View File

@ -27,8 +27,12 @@
(copy_files# driver/*.ml{,i}) (copy_files# driver/*.ml{,i})
(copy_files# asmcomp/*.ml{,i}) (copy_files# asmcomp/*.ml{,i})
(copy_files# asmcomp/debug/*.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/*.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 (library
(name ocamlcommon) (name ocamlcommon)
@ -41,7 +45,7 @@
;; UTILS ;; UTILS
config build_path_prefix_map misc identifiable numbers arg_helper clflags config build_path_prefix_map misc identifiable numbers arg_helper clflags
profile terminfo ccomp warnings consistbl strongly_connected_components profile terminfo ccomp warnings consistbl strongly_connected_components
targetint load_path targetint load_path int_replace_polymorphic_compare
;; PARSING ;; PARSING
location longident docstrings syntaxerr ast_helper camlinternalMenhirLib location longident docstrings syntaxerr ast_helper camlinternalMenhirLib
@ -61,17 +65,20 @@
; manual update: mli only files ; manual update: mli only files
annot outcometree annot outcometree
;; COMP ;; lambda/
lambda printlambda semantics_of_primitives switch matching translobj debuginfo lambda matching printlambda runtimedef simplif switch
translattribute translprim translcore translclass translmod simplif translattribute translclass translcore translmod translobj translprim
runtimedef meta opcodes bytesections dll symtable pparse main_args compenv
compmisc makedepend compile_common clambda_primitives ;; bytecomp/
printclambda_primitives meta opcodes bytesections dll symtable
;; some of COMP
pparse main_args compenv compmisc makedepend compile_common
; manual update: mli only files ; manual update: mli only files
cmo_format cmo_format
; manual update: this is required. ; manual update: this is required.
instruct instruct
)) ))
(library (library
(name ocamlbytecomp) (name ocamlbytecomp)
@ -79,58 +86,79 @@
(flags (:standard -principal -nostdlib)) (flags (:standard -principal -nostdlib))
(libraries stdlib ocamlcommon) (libraries stdlib ocamlcommon)
(modules (modules
bytegen printinstr emitcode bytelink bytelibrarian bytepackager errors ;; bytecomp/
compile)) 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 (library
(name ocamloptcomp) (name ocamloptcomp)
(wrapped false) (wrapped false)
(flags (:standard -principal -nostdlib)) (flags (:standard -principal -nostdlib))
(libraries stdlib ocamlcommon) (libraries stdlib ocamlcommon ocamlmiddleend)
(modules_without_implementation (modules_without_implementation x86_ast)
cmxs_format cmx_format x86_ast backend_intf inlining_decision_intf
simplify_boxed_integer_ops_intf)
(modules (modules
;; ASMCOMP ;; asmcomp/
arch backend_var cmm printcmm reg reg_with_debug_info reg_availability_set afl_instrument arch asmgen asmlibrarian asmlink asmpackager branch_relaxation
mach proc clambda printclambda export_info export_info_for_pack compilenv branch_relaxation_intf cmm cmmgen cmmgen_state coloring comballoc CSE CSEgen
closure traverse_for_exported_symbols build_export_info closure_offsets deadcode emit emitaux interf interval linearize linscan liveness mach
flambda_to_clambda import_approx un_anf afl_instrument strmatch cmmgen_state printcmm printlinear printmach proc reg reload reloadgen schedgen scheduling
cmmgen interval printmach selectgen spacetime_profiling selection comballoc selectgen selection spacetime_profiling spill split strmatch x86_ast
CSEgen CSE liveness spill split interf coloring linscan reloadgen reload x86_dsl x86_gas x86_masm x86_proc
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
; arch specific files: we always include them even though depending on the ;; asmcomp/debug/
; target architecture they might not be used. reg_availability_set compute_ranges_intf available_regs reg_with_debug_info
x86_ast compute_ranges
x86_proc
x86_dsl
x86_gas
x86_masm
;; MIDDLE_END ;; driver/
int_replace_polymorphic_compare debuginfo tag linkage_name compilation_unit optcompile opterrors
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
) )
) )
@ -156,7 +184,7 @@
(name optmain) (name optmain)
(modes byte) (modes byte)
(flags (:standard -principal -nostdlib)) (flags (:standard -principal -nostdlib))
(libraries ocamloptcomp ocamlcommon runtime stdlib) (libraries ocamloptcomp ocamlmiddleend ocamlcommon runtime stdlib)
(modules optmain)) (modules optmain))
(rule (rule
@ -166,12 +194,14 @@
;;; aliases ;;; ;;; aliases ;;;
;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;
; mshinwell: The debugger and ocamldoc are currently disabled as Dynlink is
; not built correctly.
(alias (alias
(name world) (name world)
(deps ocamlc.byte (deps ocamlc.byte
ocamlopt.byte ocamlopt.byte
debugger/ocamldebug.byte ; debugger/ocamldebug.byte
ocamldoc/ocamldoc.byte ; ocamldoc/ocamldoc.byte
ocamltest/ocamltest.byte ocamltest/ocamltest.byte
toplevel/ocaml.byte toplevel/ocaml.byte
toplevel/expunge.exe toplevel/expunge.exe

0
typing/cmi_format.ml → file_formats/cmi_format.ml
View File

0
typing/cmi_format.mli → file_formats/cmi_format.mli
View File

0
bytecomp/cmo_format.mli → file_formats/cmo_format.mli
View File

0
typing/cmt_format.ml → file_formats/cmt_format.ml
View File

0
typing/cmt_format.mli → file_formats/cmt_format.mli
View File

0
asmcomp/cmx_format.mli → file_formats/cmx_format.mli
View File

0
asmcomp/cmxs_format.mli → file_formats/cmxs_format.mli
View File

0
middle_end/debuginfo.ml → lambda/debuginfo.ml
View File

0
middle_end/debuginfo.mli → lambda/debuginfo.mli
View File

21
lambda/dune Normal file
View File

@ -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}))))

0
bytecomp/generate_runtimedef.sh → lambda/generate_runtimedef.sh
View File

0
bytecomp/lambda.ml → lambda/lambda.ml
View File

0
bytecomp/lambda.mli → lambda/lambda.mli
View File

0
bytecomp/matching.ml → lambda/matching.ml
View File

0
bytecomp/matching.mli → lambda/matching.mli
View File

0
bytecomp/printlambda.ml → lambda/printlambda.ml
View File

0
bytecomp/printlambda.mli → lambda/printlambda.mli
View File

0
bytecomp/runtimedef.mli → lambda/runtimedef.mli
View File

0
bytecomp/simplif.ml → lambda/simplif.ml
View File

0
bytecomp/simplif.mli → lambda/simplif.mli
View File

0
bytecomp/switch.ml → lambda/switch.ml
View File

0
bytecomp/switch.mli → lambda/switch.mli
View File

0
bytecomp/translattribute.ml → lambda/translattribute.ml
View File

0
bytecomp/translattribute.mli → lambda/translattribute.mli
View File

0
bytecomp/translclass.ml → lambda/translclass.ml
View File

0
bytecomp/translclass.mli → lambda/translclass.mli
View File

0
bytecomp/translcore.ml → lambda/translcore.ml
View File

0
bytecomp/translcore.mli → lambda/translcore.mli
View File

0
bytecomp/translmod.ml → lambda/translmod.ml
View File

0
bytecomp/translmod.mli → lambda/translmod.mli
View File

0
bytecomp/translobj.ml → lambda/translobj.ml
View File

0
bytecomp/translobj.mli → lambda/translobj.mli
View File

0
bytecomp/translprim.ml → lambda/translprim.ml
View File

0
bytecomp/translprim.mli → lambda/translprim.mli
View File

0
asmcomp/backend_var.ml → middle_end/backend_var.ml
View File

0
asmcomp/backend_var.mli → middle_end/backend_var.mli
View File

0
asmcomp/clambda.ml → middle_end/clambda.ml
View File

0
asmcomp/clambda.mli → middle_end/clambda.mli
View File

0
asmcomp/clambda_primitives.ml → middle_end/clambda_primitives.ml
View File

0
asmcomp/clambda_primitives.mli → middle_end/clambda_primitives.mli
View File

281
asmcomp/closure.ml → middle_end/closure/closure.ml
View File

@ -36,6 +36,8 @@ module Storer =
module V = Backend_var module V = Backend_var
module VP = Backend_var.With_provenance module VP = Backend_var.With_provenance
(* The current backend *)
let no_phantom_lets () = let no_phantom_lets () =
Misc.fatal_error "Closure does not support phantom let generation" 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 (* The [fpc] parameter is true if constant propagation of
floating-point computations is allowed *) 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 open Clambda_primitives in
let default = (Uprim(p, args, dbg), Value_unknown) in let default = (Uprim(p, args, dbg), Value_unknown) in
match approxs with match approxs with
@ -303,11 +306,11 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
| Pandint -> make_const_int (n1 land n2) | Pandint -> make_const_int (n1 land n2)
| Porint -> make_const_int (n1 lor n2) | Porint -> make_const_int (n1 lor n2)
| Pxorint -> make_const_int (n1 lxor 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) 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) 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) make_const_int (n1 asr n2)
| Pintcomp c -> make_integer_comparison c n1 n2 | Pintcomp c -> make_integer_comparison c n1 n2
| _ -> default | _ -> 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_ref(_, Some (Uconst_nativeint n1)));
Value_const(Uconst_int n2)] -> Value_const(Uconst_int n2)] ->
begin match p with 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) 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) 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) make_const_natint (Nativeint.shift_right n1 n2)
| _ -> default | _ -> default
end end
@ -457,7 +460,7 @@ let field_approx n = function
Value_const (List.nth l n) Value_const (List.nth l n)
| _ -> Value_unknown | _ -> 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 let open Clambda_primitives in
match p, args, approxs with match p, args, approxs with
(* Block construction *) (* Block construction *)
@ -497,11 +500,11 @@ let simplif_prim_pure fpc p (args, approxs) dbg =
end end
(* Catch-all *) (* 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 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 else
(* XXX : always return the same approxs as simplif_prim_pure? *) (* XXX : always return the same approxs as simplif_prim_pure? *)
let approx = let approx =
@ -542,18 +545,18 @@ let subst_debuginfo loc dbg =
else else
dbg dbg
let rec substitute loc fpc sb rn ulam = let rec substitute loc ((backend, fpc) as st) sb rn ulam =
match ulam with match ulam with
Uvar v -> Uvar v ->
begin try V.Map.find v sb with Not_found -> ulam end begin try V.Map.find v sb with Not_found -> ulam end
| Uconst _ -> ulam | Uconst _ -> ulam
| Udirect_apply(lbl, args, dbg) -> | Udirect_apply(lbl, args, dbg) ->
let dbg = subst_debuginfo loc dbg in 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) -> | Ugeneric_apply(fn, args, dbg) ->
let dbg = subst_debuginfo loc dbg in let dbg = subst_debuginfo loc dbg in
Ugeneric_apply(substitute loc fpc sb rn fn, Ugeneric_apply(substitute loc st sb rn fn,
List.map (substitute loc fpc sb rn) args, dbg) List.map (substitute loc st sb rn) args, dbg)
| Uclosure(defs, env) -> | Uclosure(defs, env) ->
(* Question: should we rename function labels as well? Otherwise, (* Question: should we rename function labels as well? Otherwise,
there is a risk that function labels are not globally unique. 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 - When we substitute offsets for idents bound by let rec
in [close], case [Lletrec], we discard the original in [close], case [Lletrec], we discard the original
let rec body and use only the substituted term. *) let rec body and use only the substituted term. *)
Uclosure(defs, List.map (substitute loc fpc sb rn) env) Uclosure(defs, List.map (substitute loc st sb rn) env)
| Uoffset(u, ofs) -> Uoffset(substitute loc fpc sb rn u, ofs) | Uoffset(u, ofs) -> Uoffset(substitute loc st sb rn u, ofs)
| Ulet(str, kind, id, u1, u2) -> | Ulet(str, kind, id, u1, u2) ->
let id' = VP.rename id in let id' = VP.rename id in
Ulet(str, kind, id', substitute loc fpc sb rn u1, Ulet(str, kind, id', substitute loc st sb rn u1,
substitute loc fpc substitute loc st
(V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2) (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2)
| Uphantom_let _ -> no_phantom_lets () | Uphantom_let _ -> no_phantom_lets ()
| Uletrec(bindings, body) -> | Uletrec(bindings, body) ->
@ -583,17 +586,17 @@ let rec substitute loc fpc sb rn ulam =
in in
Uletrec( Uletrec(
List.map 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, bindings1,
substitute loc fpc sb' rn body) substitute loc st sb' rn body)
| Uprim(p, args, dbg) -> | 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 dbg = subst_debuginfo loc dbg in
let (res, _) = 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 res
| Uswitch(arg, sw, dbg) -> | Uswitch(arg, sw, dbg) ->
let sarg = substitute loc fpc sb rn arg in let sarg = substitute loc st sb rn arg in
let action = let action =
(* Unfortunately, we cannot easily deal with the (* Unfortunately, we cannot easily deal with the
case of a constructed block (makeblock) bound to a local case of a constructed block (makeblock) bound to a local
@ -609,22 +612,22 @@ let rec substitute loc fpc sb rn ulam =
| _ -> None | _ -> None
in in
begin match action with begin match action with
| Some u -> substitute loc fpc sb rn u | Some u -> substitute loc st sb rn u
| None -> | None ->
Uswitch(sarg, Uswitch(sarg,
{ sw with { sw with
us_actions_consts = 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 = 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) dbg)
end end
| Ustringswitch(arg,sw,d) -> | Ustringswitch(arg,sw,d) ->
Ustringswitch Ustringswitch
(substitute loc fpc sb rn arg, (substitute loc st sb rn arg,
List.map (fun (s,act) -> s,substitute loc fpc sb rn act) sw, List.map (fun (s,act) -> s,substitute loc st sb rn act) sw,
Misc.may_map (substitute loc fpc sb rn) d) Misc.may_map (substitute loc st sb rn) d)
| Ustaticfail (nfail, args) -> | Ustaticfail (nfail, args) ->
let nfail = let nfail =
match rn with match rn with
@ -635,7 +638,7 @@ let rec substitute loc fpc sb rn ulam =
fatal_errorf "Closure.split_list: invalid nfail (%d)" nfail fatal_errorf "Closure.split_list: invalid nfail (%d)" nfail
end end
| None -> nfail in | 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) -> | Ucatch(nfail, ids, u1, u2) ->
let nfail, rn = let nfail, rn =
match rn with match rn with
@ -651,34 +654,34 @@ let rec substitute loc fpc sb rn ulam =
) )
ids ids' sb ids ids' sb
in in
Ucatch(nfail, ids', substitute loc fpc sb rn u1, Ucatch(nfail, ids', substitute loc st sb rn u1,
substitute loc fpc sb' rn u2) substitute loc st sb' rn u2)
| Utrywith(u1, id, u2) -> | Utrywith(u1, id, u2) ->
let id' = VP.rename id in let id' = VP.rename id in
Utrywith(substitute loc fpc sb rn u1, id', Utrywith(substitute loc st sb rn u1, id',
substitute loc fpc substitute loc st
(V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2) (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2)
| Uifthenelse(u1, u2, u3) -> | 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) -> Uconst (Uconst_ptr n) ->
if n <> 0 then if n <> 0 then
substitute loc fpc sb rn u2 substitute loc st sb rn u2
else else
substitute loc fpc sb rn u3 substitute loc st sb rn u3
| Uprim(P.Pmakeblock _, _, _) -> | Uprim(P.Pmakeblock _, _, _) ->
substitute loc fpc sb rn u2 substitute loc st sb rn u2
| su1 -> | su1 ->
Uifthenelse(su1, substitute loc fpc sb rn u2, Uifthenelse(su1, substitute loc st sb rn u2,
substitute loc fpc sb rn u3) substitute loc st sb rn u3)
end end
| Usequence(u1, u2) -> | 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(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) -> | Ufor(id, u1, u2, dir, u3) ->
let id' = VP.rename id in let id' = VP.rename id in
Ufor(id', substitute loc fpc sb rn u1, substitute loc fpc sb rn u2, dir, Ufor(id', substitute loc st sb rn u1, substitute loc st sb rn u2, dir,
substitute loc fpc substitute loc st
(V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u3) (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u3)
| Uassign(id, u) -> | Uassign(id, u) ->
let id' = 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 match V.Map.find id sb with Uvar i -> i | _ -> assert false
with Not_found -> with Not_found ->
id in id in
Uassign(id', substitute loc fpc sb rn u) Uassign(id', substitute loc st sb rn u)
| Usend(k, u1, u2, ul, dbg) -> | Usend(k, u1, u2, ul, dbg) ->
let dbg = subst_debuginfo loc dbg in let dbg = subst_debuginfo loc dbg in
Usend(k, substitute loc fpc sb rn u1, substitute loc fpc sb rn u2, Usend(k, substitute loc st sb rn u1, substitute loc st sb rn u2,
List.map (substitute loc fpc sb rn) ul, dbg) List.map (substitute loc st sb rn) ul, dbg)
| Uunreachable -> | Uunreachable ->
Uunreachable Uunreachable
@ -746,7 +749,7 @@ let warning_if_forced_inline ~loc ~attribute warning =
(* Generate a direct application *) (* Generate a direct application *)
let direct_apply fundesc ufunct uargs ~loc ~attribute = let direct_apply ~backend fundesc ufunct uargs ~loc ~attribute =
let app_args = let app_args =
if fundesc.fun_closed then uargs else uargs @ [ufunct] in if fundesc.fun_closed then uargs else uargs @ [ufunct] in
let app = let app =
@ -757,7 +760,8 @@ let direct_apply fundesc ufunct uargs ~loc ~attribute =
"Function information unavailable"; "Function information unavailable";
Udirect_apply(fundesc.fun_label, app_args, dbg) Udirect_apply(fundesc.fun_label, app_args, dbg)
| Some(params, body), _ -> | 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 in
(* If ufunct can contain side-effects or function definitions, (* If ufunct can contain side-effects or function definitions,
we must make sure that it is evaluated exactly once. we must make sure that it is evaluated exactly once.
@ -818,7 +822,13 @@ let excessive_function_nesting_depth = 5
exception NotClosed 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 let approx = try V.Map.find id fenv with Not_found -> Value_unknown in
match approx with match approx with
Value_const c -> make_const c 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 let subst = try V.Map.find id cenv with Not_found -> Uvar id in
(subst, approx) (subst, approx)
let close_var fenv cenv id = let close_var env id =
let (ulam, _app) = close_approx_var fenv cenv id in ulam let (ulam, _app) = close_approx_var env id in ulam
let rec close fenv cenv = function let rec close ({ backend; fenv; cenv } as env) lam =
Lvar id -> let module B = (val backend : Backend_intf.S) in
close_approx_var fenv cenv id match lam with
| Lvar id ->
close_approx_var env id
| Lconst cst -> | Lconst cst ->
let str ?(shared = true) cst = let str ?(shared = true) cst =
let name = let name =
@ -865,24 +877,24 @@ let rec close fenv cenv = function
in in
make_const (transl cst) make_const (transl cst)
| Lfunction _ as funct -> | 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] (* We convert [f a] to [let a' = a in let f' = f in fun b c -> f' a' b c]
when fun_arity > nargs *) when fun_arity > nargs *)
| Lapply{ap_func = funct; ap_args = args; ap_loc = loc; | Lapply{ap_func = funct; ap_args = args; ap_loc = loc;
ap_inlined = attribute} -> ap_inlined = attribute} ->
let nargs = List.length args in 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)), ((ufunct, Value_closure(fundesc, approx_res)),
[Uprim(P.Pmakeblock _, uargs, _)]) [Uprim(P.Pmakeblock _, uargs, _)])
when List.length uargs = - fundesc.fun_arity -> when List.length uargs = - fundesc.fun_arity ->
let app = 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) (app, strengthen_approx app approx_res)
| ((ufunct, Value_closure(fundesc, approx_res)), uargs) | ((ufunct, Value_closure(fundesc, approx_res)), uargs)
when nargs = fundesc.fun_arity -> when nargs = fundesc.fun_arity ->
let app = 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) (app, strengthen_approx app approx_res)
| ((ufunct, (Value_closure(fundesc, _) as fapprox)), uargs) | ((ufunct, (Value_closure(fundesc, _) as fapprox)), uargs)
@ -905,7 +917,7 @@ let rec close fenv cenv = function
in in
let funct_var = V.create_local "funct" in let funct_var = V.create_local "funct" in
let fenv = V.Map.add funct_var fapprox fenv 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{ (Lfunction{
kind = Curried; kind = Curried;
return = Pgenval; return = Pgenval;
@ -935,7 +947,7 @@ let rec close fenv cenv = function
let dbg = Debuginfo.from_location loc in let dbg = Debuginfo.from_location loc in
warning_if_forced_inline ~loc ~attribute "Over-application"; warning_if_forced_inline ~loc ~attribute "Over-application";
let body = let body =
Ugeneric_apply(direct_apply ~loc ~attribute Ugeneric_apply(direct_apply ~backend ~loc ~attribute
fundesc ufunct first_args, fundesc ufunct first_args,
rem_args, dbg) rem_args, dbg)
in in
@ -952,22 +964,24 @@ let rec close fenv cenv = function
(Ugeneric_apply(ufunct, uargs, dbg), Value_unknown) (Ugeneric_apply(ufunct, uargs, dbg), Value_unknown)
end end
| Lsend(kind, met, obj, args, loc) -> | Lsend(kind, met, obj, args, loc) ->
let (umet, _) = close fenv cenv met in let (umet, _) = close env met in
let (uobj, _) = close fenv cenv obj in let (uobj, _) = close env obj in
let dbg = Debuginfo.from_location loc 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) Value_unknown)
| Llet(str, kind, id, lam, body) -> | 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 begin match (str, alam) with
(Variable, _) -> (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) (Ulet(Mutable, kind, VP.create id, ulam, ubody), abody)
| (_, Value_const _) | (_, Value_const _)
when str = Alias || is_pure ulam -> 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) (Ulet(Immutable, kind, VP.create id, ulam, ubody), abody)
end end
| Lletrec(defs, body) -> | Lletrec(defs, body) ->
@ -976,20 +990,21 @@ let rec close fenv cenv = function
defs defs
then begin then begin
(* Simple case: only function definitions *) (* 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 clos_ident = V.create_local "clos" in
let fenv_body = let fenv_body =
List.fold_right List.fold_right
(fun (id, _pos, approx) fenv -> V.Map.add id approx fenv) (fun (id, _pos, approx) fenv -> V.Map.add id approx fenv)
infos fenv in 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 = let sb =
List.fold_right List.fold_right
(fun (id, pos, _approx) sb -> (fun (id, pos, _approx) sb ->
V.Map.add id (Uoffset(Uvar clos_ident, pos)) sb) V.Map.add id (Uoffset(Uvar clos_ident, pos)) sb)
infos V.Map.empty in infos V.Map.empty in
(Ulet(Immutable, Pgenval, VP.create clos_ident, clos, (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) approx)
end else begin end else begin
(* General case: recursive definition of values *) (* General case: recursive definition of values *)
@ -997,37 +1012,37 @@ let rec close fenv cenv = function
[] -> ([], fenv) [] -> ([], fenv)
| (id, lam) :: rem -> | (id, lam) :: rem ->
let (udefs, fenv_body) = clos_defs rem in 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 ((VP.create id, ulam) :: udefs, V.Map.add id approx fenv_body) in
let (udefs, fenv_body) = clos_defs defs 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) (Uletrec(udefs, ubody), approx)
end end
(* Compile-time constants *) (* Compile-time constants *)
| Lprim(Pctconst c, [arg], _loc) -> | Lprim(Pctconst c, [arg], _loc) ->
let cst, approx = let cst, approx =
match c with match c with
| Big_endian -> make_const_bool Arch.big_endian | Big_endian -> make_const_bool B.big_endian
| Word_size -> make_const_int (8*Arch.size_int) | Word_size -> make_const_int (8*B.size_int)
| Int_size -> make_const_int (8*Arch.size_int - 1) | Int_size -> make_const_int (8*B.size_int - 1)
| Max_wosize -> make_const_int ((1 lsl ((8*Arch.size_int) - 10)) - 1 ) | Max_wosize -> make_const_int ((1 lsl ((8*B.size_int) - 10)) - 1 )
| Ostype_unix -> make_const_bool (Sys.os_type = "Unix") | Ostype_unix -> make_const_bool (Sys.os_type = "Unix")
| Ostype_win32 -> make_const_bool (Sys.os_type = "Win32") | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32")
| Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin") | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin")
| Backend_type -> | Backend_type ->
make_const_ptr 0 (* tag 0 is the same as Native here *) make_const_ptr 0 (* tag 0 is the same as Native here *)
in in
let arg, _approx = close fenv cenv arg in let arg, _approx = close env arg in
let id = Ident.create_local "dummy" in let id = Ident.create_local "dummy" in
Ulet(Immutable, Pgenval, VP.create id, arg, cst), approx Ulet(Immutable, Pgenval, VP.create id, arg, cst), approx
| Lprim(Pignore, [arg], _loc) -> | Lprim(Pignore, [arg], _loc) ->
let expr, approx = make_const_ptr 0 in 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) -> | Lprim((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _loc) ->
close fenv cenv arg close env arg
| Lprim(Pdirapply,[funct;arg], loc) | Lprim(Pdirapply,[funct;arg], loc)
| Lprim(Prevapply,[arg;funct], 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_loc=loc;
ap_func=funct; ap_func=funct;
ap_args=[arg]; ap_args=[arg];
@ -1038,19 +1053,19 @@ let rec close fenv cenv = function
check_constant_result (getglobal dbg id) check_constant_result (getglobal dbg id)
(Compilenv.global_approx id) (Compilenv.global_approx id)
| Lprim(Pfield n, [lam], loc) -> | 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 let dbg = Debuginfo.from_location loc in
check_constant_result (Uprim(P.Pfield n, [ulam], dbg)) check_constant_result (Uprim(P.Pfield n, [ulam], dbg))
(field_approx n approx) (field_approx n approx)
| Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, [], _); lam], loc)-> | 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 if approx <> Value_unknown then
(!global_approx).(n) <- approx; (!global_approx).(n) <- approx;
let dbg = Debuginfo.from_location loc in let dbg = Debuginfo.from_location loc in
(Uprim(P.Psetfield(n, is_ptr, init), [getglobal dbg id; ulam], dbg), (Uprim(P.Psetfield(n, is_ptr, init), [getglobal dbg id; ulam], dbg),
Value_unknown) Value_unknown)
| Lprim(Praise k, [arg], loc) -> | 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 let dbg = Debuginfo.from_location loc in
(Uprim(P.Praise k, [ulam], dbg), (Uprim(P.Praise k, [ulam], dbg),
Value_unknown) Value_unknown)
@ -1058,15 +1073,15 @@ let rec close fenv cenv = function
| Lprim(p, args, loc) -> | Lprim(p, args, loc) ->
let p = Convert_primitives.convert p in let p = Convert_primitives.convert p in
let dbg = Debuginfo.from_location loc in let dbg = Debuginfo.from_location loc in
simplif_prim !Clflags.float_const_prop simplif_prim ~backend !Clflags.float_const_prop
p (close_list_approx fenv cenv args) dbg p (close_list_approx env args) dbg
| Lswitch(arg, sw, dbg) -> | Lswitch(arg, sw, dbg) ->
let fn fail = let fn fail =
let (uarg, _) = close fenv cenv arg in let (uarg, _) = close env arg in
let const_index, const_actions, fconst = 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 = 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 = let ulam =
Uswitch Uswitch
(uarg, (uarg,
@ -1088,88 +1103,88 @@ let rec close fenv cenv = function
then then
let i = next_raise_count () in let i = next_raise_count () in
let ubody,_ = fn (Some (Lstaticraise (i,[]))) 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 Ucatch (i,[],ubody,uhandler),Value_unknown
else fn fail else fn fail
end end
| Lstringswitch(arg,sw,d,_) -> | Lstringswitch(arg,sw,d,_) ->
let uarg,_ = close fenv cenv arg in let uarg,_ = close env arg in
let usw = let usw =
List.map List.map
(fun (s,act) -> (fun (s,act) ->
let uact,_ = close fenv cenv act in let uact,_ = close env act in
s,uact) s,uact)
sw in sw in
let ud = let ud =
Misc.may_map Misc.may_map
(fun d -> (fun d ->
let ud,_ = close fenv cenv d in let ud,_ = close env d in
ud) d in ud) d in
Ustringswitch (uarg,usw,ud),Value_unknown Ustringswitch (uarg,usw,ud),Value_unknown
| Lstaticraise (i, args) -> | 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) -> | Lstaticcatch(body, (i, vars), handler) ->
let (ubody, _) = close fenv cenv body in let (ubody, _) = close env body in
let (uhandler, _) = close fenv cenv handler in let (uhandler, _) = close env handler in
let vars = List.map (fun (var, k) -> VP.create var, k) vars in let vars = List.map (fun (var, k) -> VP.create var, k) vars in
(Ucatch(i, vars, ubody, uhandler), Value_unknown) (Ucatch(i, vars, ubody, uhandler), Value_unknown)
| Ltrywith(body, id, handler) -> | Ltrywith(body, id, handler) ->
let (ubody, _) = close fenv cenv body in let (ubody, _) = close env body in
let (uhandler, _) = close fenv cenv handler in let (uhandler, _) = close env handler in
(Utrywith(ubody, VP.create id, uhandler), Value_unknown) (Utrywith(ubody, VP.create id, uhandler), Value_unknown)
| Lifthenelse(arg, ifso, ifnot) -> | Lifthenelse(arg, ifso, ifnot) ->
begin match close fenv cenv arg with begin match close env arg with
(uarg, Value_const (Uconst_ptr n)) -> (uarg, Value_const (Uconst_ptr n)) ->
sequence_constant_expr uarg sequence_constant_expr uarg
(close fenv cenv (if n = 0 then ifnot else ifso)) (close env (if n = 0 then ifnot else ifso))
| (uarg, _ ) -> | (uarg, _ ) ->
let (uifso, _) = close fenv cenv ifso in let (uifso, _) = close env ifso in
let (uifnot, _) = close fenv cenv ifnot in let (uifnot, _) = close env ifnot in
(Uifthenelse(uarg, uifso, uifnot), Value_unknown) (Uifthenelse(uarg, uifso, uifnot), Value_unknown)
end end
| Lsequence(lam1, lam2) -> | Lsequence(lam1, lam2) ->
let (ulam1, _) = close fenv cenv lam1 in let (ulam1, _) = close env lam1 in
let (ulam2, approx) = close fenv cenv lam2 in let (ulam2, approx) = close env lam2 in
(Usequence(ulam1, ulam2), approx) (Usequence(ulam1, ulam2), approx)
| Lwhile(cond, body) -> | Lwhile(cond, body) ->
let (ucond, _) = close fenv cenv cond in let (ucond, _) = close env cond in
let (ubody, _) = close fenv cenv body in let (ubody, _) = close env body in
(Uwhile(ucond, ubody), Value_unknown) (Uwhile(ucond, ubody), Value_unknown)
| Lfor(id, lo, hi, dir, body) -> | Lfor(id, lo, hi, dir, body) ->
let (ulo, _) = close fenv cenv lo in let (ulo, _) = close env lo in
let (uhi, _) = close fenv cenv hi in let (uhi, _) = close env hi in
let (ubody, _) = close fenv cenv body in let (ubody, _) = close env body in
(Ufor(VP.create id, ulo, uhi, dir, ubody), Value_unknown) (Ufor(VP.create id, ulo, uhi, dir, ubody), Value_unknown)
| Lassign(id, lam) -> | Lassign(id, lam) ->
let (ulam, _) = close fenv cenv lam in let (ulam, _) = close env lam in
(Uassign(id, ulam), Value_unknown) (Uassign(id, ulam), Value_unknown)
| Levent(lam, _) -> | Levent(lam, _) ->
close fenv cenv lam close env lam
| Lifused _ -> | Lifused _ ->
assert false assert false
and close_list fenv cenv = function and close_list env = function
[] -> [] [] -> []
| lam :: rem -> | lam :: rem ->
let (ulam, _) = close fenv cenv lam in let (ulam, _) = close env lam in
ulam :: close_list fenv cenv rem ulam :: close_list env rem
and close_list_approx fenv cenv = function and close_list_approx env = function
[] -> ([], []) [] -> ([], [])
| lam :: rem -> | lam :: rem ->
let (ulam, approx) = close fenv cenv lam in let (ulam, approx) = close env lam in
let (ulams, approxs) = close_list_approx fenv cenv rem in let (ulams, approxs) = close_list_approx env rem in
(ulam :: ulams, approx :: approxs) (ulam :: ulams, approx :: approxs)
and close_named fenv cenv id = function and close_named env id = function
Lfunction _ as funct -> Lfunction _ as funct ->
close_one_function fenv cenv id funct close_one_function env id funct
| lam -> | lam ->
close fenv cenv lam close env lam
(* Build a shared closure for a set of mutually recursive functions *) (* 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 = let fun_defs =
List.flatten List.flatten
(List.map (List.map
@ -1240,7 +1255,9 @@ and close_functions fenv cenv fun_defs =
(fun (id, _params, _return, _body, _fundesc, _dbg) pos env -> (fun (id, _params, _return, _body, _fundesc, _dbg) pos env ->
V.Map.add id (Uoffset(Uvar env_param, pos - env_pos)) env) V.Map.add id (Uoffset(Uvar env_param, pos - env_pos)) env)
uncurried_defs clos_offsets cenv_fv in 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; if !useless_env && occurs_var env_param ubody then raise NotClosed;
let fun_params = let fun_params =
if !useless_env if !useless_env
@ -1311,18 +1328,18 @@ and close_functions fenv cenv fun_defs =
with offsets and approximations. *) with offsets and approximations. *)
let (clos, infos) = List.split clos_info_list in let (clos, infos) = List.split clos_info_list in
let fv = if !useless_env then [] else fv 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 *) (* Same, for one non-recursive function *)
and close_one_function fenv cenv id funct = and close_one_function env id funct =
match close_functions fenv cenv [id, funct] with match close_functions env [id, funct] with
| (clos, (i, _, approx) :: _) when id = i -> (clos, approx) | (clos, (i, _, approx) :: _) when id = i -> (clos, approx)
| _ -> fatal_error "Closure.close_one_function" | _ -> fatal_error "Closure.close_one_function"
(* Close a switch *) (* 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 ncases = List.length cases in
let index = Array.make num_keys 0 let index = Array.make num_keys 0
and store = Storer.mk_store () in and store = Storer.mk_store () in
@ -1349,10 +1366,10 @@ and close_switch fenv cenv cases num_keys default =
Array.map Array.map
(function (function
| Single lam|Shared (Lstaticraise (_,[]) as lam) -> | Single lam|Shared (Lstaticraise (_,[]) as lam) ->
let ulam,_ = close fenv cenv lam in let ulam,_ = close env lam in
ulam ulam
| Shared lam -> | Shared lam ->
let ulam,_ = close fenv cenv lam in let ulam,_ = close env lam in
let i = next_raise_count () in let i = next_raise_count () in
(* (*
let string_of_lambda e = let string_of_lambda e =
@ -1436,12 +1453,14 @@ let reset () =
(* The entry point *) (* The entry point *)
let intro size lam = let intro ~backend ~size lam =
reset (); reset ();
let id = Compilenv.make_symbol None in let id = Compilenv.make_symbol None in
global_approx := Array.init size (fun i -> Value_global_field (id, i)); global_approx := Array.init size (fun i -> Value_global_field (id, i));
Compilenv.set_global_approx(Value_tuple !global_approx); 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 = let opaque =
!Clflags.opaque !Clflags.opaque
|| Env.is_imported_opaque (Compilenv.current_unit_name ()) || Env.is_imported_opaque (Compilenv.current_unit_name ())

7
asmcomp/closure.mli → middle_end/closure/closure.mli
View File

@ -15,5 +15,10 @@
(* Introduction of closures, uncurrying, recognition of direct calls *) (* 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 val reset : unit -> unit

0
middle_end/base_types/compilation_unit.ml → middle_end/compilation_unit.ml
View File

0
middle_end/base_types/compilation_unit.mli → middle_end/compilation_unit.mli
View File

0
asmcomp/compilenv.ml → middle_end/compilenv.ml
View File

0
asmcomp/compilenv.mli → middle_end/compilenv.mli
View File

0
asmcomp/convert_primitives.ml → middle_end/convert_primitives.ml
View File

0
asmcomp/convert_primitives.mli → middle_end/convert_primitives.mli
View File

0
middle_end/alias_analysis.ml → middle_end/flambda/alias_analysis.ml
View File

0
middle_end/alias_analysis.mli → middle_end/flambda/alias_analysis.mli
View File

0
middle_end/allocated_const.ml → middle_end/flambda/allocated_const.ml
View File

0
middle_end/allocated_const.mli → middle_end/flambda/allocated_const.mli
View File

0
middle_end/augment_specialised_args.ml → middle_end/flambda/augment_specialised_args.ml
View File

0
middle_end/augment_specialised_args.mli → middle_end/flambda/augment_specialised_args.mli
View File

0
middle_end/base_types/closure_element.ml → middle_end/flambda/base_types/closure_element.ml
View File

0
middle_end/base_types/closure_element.mli → middle_end/flambda/base_types/closure_element.mli
View File

0
middle_end/base_types/closure_id.ml → middle_end/flambda/base_types/closure_id.ml
View File

0
middle_end/base_types/closure_id.mli → middle_end/flambda/base_types/closure_id.mli
View File

0
middle_end/base_types/closure_origin.ml → middle_end/flambda/base_types/closure_origin.ml
View File

0
middle_end/base_types/closure_origin.mli → middle_end/flambda/base_types/closure_origin.mli
View File

0
middle_end/base_types/export_id.ml → middle_end/flambda/base_types/export_id.ml
View File

0
middle_end/base_types/export_id.mli → middle_end/flambda/base_types/export_id.mli
View File

0
middle_end/base_types/id_types.ml → middle_end/flambda/base_types/id_types.ml
View File

0
middle_end/base_types/id_types.mli → middle_end/flambda/base_types/id_types.mli
View File

0
middle_end/base_types/mutable_variable.ml → middle_end/flambda/base_types/mutable_variable.ml
View File

0
middle_end/base_types/mutable_variable.mli → middle_end/flambda/base_types/mutable_variable.mli
View File

0
middle_end/base_types/set_of_closures_id.ml → middle_end/flambda/base_types/set_of_closures_id.ml
View File

0
middle_end/base_types/set_of_closures_id.mli → middle_end/flambda/base_types/set_of_closures_id.mli
View File

0
middle_end/base_types/set_of_closures_origin.ml → middle_end/flambda/base_types/set_of_closures_origin.ml
View File

0
middle_end/base_types/set_of_closures_origin.mli → middle_end/flambda/base_types/set_of_closures_origin.mli
View File

0
middle_end/base_types/static_exception.ml → middle_end/flambda/base_types/static_exception.ml
View File

0
middle_end/base_types/static_exception.mli → middle_end/flambda/base_types/static_exception.mli
View File

0
middle_end/base_types/tag.ml → middle_end/flambda/base_types/tag.ml
View File

0
middle_end/base_types/tag.mli → middle_end/flambda/base_types/tag.mli
View File

0
middle_end/base_types/var_within_closure.ml → middle_end/flambda/base_types/var_within_closure.ml
View File

0
middle_end/base_types/var_within_closure.mli → middle_end/flambda/base_types/var_within_closure.mli
View File

0
asmcomp/build_export_info.ml → middle_end/flambda/build_export_info.ml
View File

0
asmcomp/build_export_info.mli → middle_end/flambda/build_export_info.mli
View File

0
middle_end/closure_conversion.ml → middle_end/flambda/closure_conversion.ml
View File

0
middle_end/closure_conversion.mli → middle_end/flambda/closure_conversion.mli
View File

0
middle_end/closure_conversion_aux.ml → middle_end/flambda/closure_conversion_aux.ml
View File

0
middle_end/closure_conversion_aux.mli → middle_end/flambda/closure_conversion_aux.mli
View File

0
asmcomp/closure_offsets.ml → middle_end/flambda/closure_offsets.ml
View File

0
asmcomp/closure_offsets.mli → middle_end/flambda/closure_offsets.mli
View File

0
middle_end/effect_analysis.ml → middle_end/flambda/effect_analysis.ml
View File

0
middle_end/effect_analysis.mli → middle_end/flambda/effect_analysis.mli
View File

Some files were not shown because too many files have changed in this diff Show More