From: Stephane Glondu Date: Thu, 3 Sep 2020 12:51:38 +0000 (+0200) Subject: New upstream version 4.09.0 X-Git-Tag: archive/raspbian/4.11.1-5+rpi1~1^2~25^2~5 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=d52c4ab5e88aadcead3f0f28c6161670867728f3;p=ocaml.git New upstream version 4.09.0 --- diff --git a/.depend b/.depend index cea6ca97..83c43d90 100644 --- a/.depend +++ b/.depend @@ -44,10 +44,13 @@ utils/config.cmx : \ utils/config.cmi utils/config.cmi : utils/consistbl.cmo : \ + utils/misc.cmi \ utils/consistbl.cmi utils/consistbl.cmx : \ + utils/misc.cmx \ utils/consistbl.cmi -utils/consistbl.cmi : +utils/consistbl.cmi : \ + utils/misc.cmi utils/identifiable.cmo : \ utils/misc.cmi \ utils/identifiable.cmi @@ -55,6 +58,11 @@ utils/identifiable.cmx : \ utils/misc.cmx \ utils/identifiable.cmi utils/identifiable.cmi : +utils/int_replace_polymorphic_compare.cmo : \ + utils/int_replace_polymorphic_compare.cmi +utils/int_replace_polymorphic_compare.cmx : \ + utils/int_replace_polymorphic_compare.cmi +utils/int_replace_polymorphic_compare.cmi : utils/load_path.cmo : \ utils/misc.cmi \ utils/load_path.cmi @@ -428,53 +436,6 @@ typing/btype.cmi : \ typing/types.cmi \ typing/path.cmi \ parsing/asttypes.cmi -typing/cmi_format.cmo : \ - typing/types.cmi \ - utils/misc.cmi \ - parsing/location.cmi \ - utils/config.cmi \ - typing/cmi_format.cmi -typing/cmi_format.cmx : \ - typing/types.cmx \ - utils/misc.cmx \ - parsing/location.cmx \ - utils/config.cmx \ - typing/cmi_format.cmi -typing/cmi_format.cmi : \ - typing/types.cmi \ - utils/misc.cmi -typing/cmt_format.cmo : \ - typing/types.cmi \ - typing/typedtree.cmi \ - typing/tast_mapper.cmi \ - utils/misc.cmi \ - parsing/location.cmi \ - utils/load_path.cmi \ - parsing/lexer.cmi \ - typing/env.cmi \ - utils/config.cmi \ - typing/cmi_format.cmi \ - utils/clflags.cmi \ - typing/cmt_format.cmi -typing/cmt_format.cmx : \ - typing/types.cmx \ - typing/typedtree.cmx \ - typing/tast_mapper.cmx \ - utils/misc.cmx \ - parsing/location.cmx \ - utils/load_path.cmx \ - parsing/lexer.cmx \ - typing/env.cmx \ - utils/config.cmx \ - typing/cmi_format.cmx \ - utils/clflags.cmx \ - typing/cmt_format.cmi -typing/cmt_format.cmi : \ - typing/types.cmi \ - typing/typedtree.cmi \ - parsing/location.cmi \ - typing/env.cmi \ - typing/cmi_format.cmi typing/ctype.cmo : \ typing/types.cmi \ typing/subst.cmi \ @@ -535,6 +496,7 @@ typing/env.cmo : \ typing/types.cmi \ typing/subst.cmi \ typing/predef.cmi \ + typing/persistent_env.cmi \ typing/path.cmi \ utils/misc.cmi \ parsing/longident.cmi \ @@ -542,9 +504,7 @@ typing/env.cmo : \ utils/load_path.cmi \ typing/ident.cmi \ typing/datarepr.cmi \ - utils/consistbl.cmi \ - utils/config.cmi \ - typing/cmi_format.cmi \ + file_formats/cmi_format.cmi \ utils/clflags.cmi \ parsing/builtin_attributes.cmi \ typing/btype.cmi \ @@ -555,6 +515,7 @@ typing/env.cmx : \ typing/types.cmx \ typing/subst.cmx \ typing/predef.cmx \ + typing/persistent_env.cmx \ typing/path.cmx \ utils/misc.cmx \ parsing/longident.cmx \ @@ -562,9 +523,7 @@ typing/env.cmx : \ utils/load_path.cmx \ typing/ident.cmx \ typing/datarepr.cmx \ - utils/consistbl.cmx \ - utils/config.cmx \ - typing/cmi_format.cmx \ + file_formats/cmi_format.cmx \ utils/clflags.cmx \ parsing/builtin_attributes.cmx \ typing/btype.cmx \ @@ -580,8 +539,7 @@ typing/env.cmi : \ parsing/location.cmi \ utils/load_path.cmi \ typing/ident.cmi \ - utils/consistbl.cmi \ - typing/cmi_format.cmi \ + file_formats/cmi_format.cmi \ parsing/asttypes.cmi typing/envaux.cmo : \ typing/subst.cmi \ @@ -679,7 +637,7 @@ typing/includemod.cmo : \ typing/ident.cmi \ typing/env.cmi \ typing/ctype.cmi \ - typing/cmt_format.cmi \ + file_formats/cmt_format.cmi \ utils/clflags.cmi \ parsing/builtin_attributes.cmi \ typing/btype.cmi \ @@ -700,7 +658,7 @@ typing/includemod.cmx : \ typing/ident.cmx \ typing/env.cmx \ typing/ctype.cmx \ - typing/cmt_format.cmx \ + file_formats/cmt_format.cmx \ utils/clflags.cmx \ parsing/builtin_attributes.cmx \ typing/btype.cmx \ @@ -763,8 +721,8 @@ typing/parmatch.cmo : \ utils/warnings.cmi \ typing/untypeast.cmi \ typing/types.cmi \ - typing/typedtreeIter.cmi \ typing/typedtree.cmi \ + typing/tast_iterator.cmi \ typing/subst.cmi \ typing/printpat.cmi \ typing/predef.cmi \ @@ -785,8 +743,8 @@ typing/parmatch.cmx : \ utils/warnings.cmx \ typing/untypeast.cmx \ typing/types.cmx \ - typing/typedtreeIter.cmx \ typing/typedtree.cmx \ + typing/tast_iterator.cmx \ typing/subst.cmx \ typing/printpat.cmx \ typing/predef.cmx \ @@ -818,6 +776,32 @@ typing/path.cmx : \ typing/path.cmi typing/path.cmi : \ typing/ident.cmi +typing/persistent_env.cmo : \ + utils/warnings.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + utils/load_path.cmi \ + utils/consistbl.cmi \ + utils/config.cmi \ + file_formats/cmi_format.cmi \ + utils/clflags.cmi \ + typing/persistent_env.cmi +typing/persistent_env.cmx : \ + utils/warnings.cmx \ + utils/misc.cmx \ + parsing/location.cmx \ + utils/load_path.cmx \ + utils/consistbl.cmx \ + utils/config.cmx \ + file_formats/cmi_format.cmx \ + utils/clflags.cmx \ + typing/persistent_env.cmi +typing/persistent_env.cmi : \ + typing/types.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + utils/consistbl.cmi \ + file_formats/cmi_format.cmi typing/predef.cmo : \ typing/types.cmi \ typing/path.cmi \ @@ -957,7 +941,7 @@ typing/rec_check.cmo : \ typing/typedtree.cmi \ typing/primitive.cmi \ typing/path.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/ident.cmi \ parsing/asttypes.cmi \ typing/rec_check.cmi @@ -967,7 +951,7 @@ typing/rec_check.cmx : \ typing/typedtree.cmx \ typing/primitive.cmx \ typing/path.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ typing/ident.cmx \ parsing/asttypes.cmi \ typing/rec_check.cmi @@ -1020,6 +1004,20 @@ typing/subst.cmi : \ typing/types.cmi \ typing/path.cmi \ typing/ident.cmi +typing/tast_iterator.cmo : \ + typing/typedtree.cmi \ + typing/env.cmi \ + parsing/asttypes.cmi \ + typing/tast_iterator.cmi +typing/tast_iterator.cmx : \ + typing/typedtree.cmx \ + typing/env.cmx \ + parsing/asttypes.cmi \ + typing/tast_iterator.cmi +typing/tast_iterator.cmi : \ + typing/typedtree.cmi \ + typing/env.cmi \ + parsing/asttypes.cmi typing/tast_mapper.cmo : \ typing/typedtree.cmi \ typing/env.cmi \ @@ -1056,7 +1054,7 @@ typing/typeclass.cmo : \ typing/ident.cmi \ typing/env.cmi \ typing/ctype.cmi \ - typing/cmt_format.cmi \ + file_formats/cmt_format.cmi \ utils/clflags.cmi \ parsing/builtin_attributes.cmi \ typing/btype.cmi \ @@ -1085,7 +1083,7 @@ typing/typeclass.cmx : \ typing/ident.cmx \ typing/env.cmx \ typing/ctype.cmx \ - typing/cmt_format.cmx \ + file_formats/cmt_format.cmx \ utils/clflags.cmx \ parsing/builtin_attributes.cmx \ typing/btype.cmx \ @@ -1115,6 +1113,7 @@ typing/typecore.cmo : \ typing/printpat.cmi \ typing/primitive.cmi \ typing/predef.cmi \ + typing/persistent_env.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ typing/parmatch.cmi \ @@ -1126,7 +1125,7 @@ typing/typecore.cmo : \ typing/ident.cmi \ typing/env.cmi \ typing/ctype.cmi \ - typing/cmt_format.cmi \ + file_formats/cmt_format.cmi \ utils/clflags.cmi \ parsing/builtin_attributes.cmi \ typing/btype.cmi \ @@ -1147,6 +1146,7 @@ typing/typecore.cmx : \ typing/printpat.cmx \ typing/primitive.cmx \ typing/predef.cmx \ + typing/persistent_env.cmx \ typing/path.cmx \ parsing/parsetree.cmi \ typing/parmatch.cmx \ @@ -1158,7 +1158,7 @@ typing/typecore.cmx : \ typing/ident.cmx \ typing/env.cmx \ typing/ctype.cmx \ - typing/cmt_format.cmx \ + file_formats/cmt_format.cmx \ utils/clflags.cmx \ parsing/builtin_attributes.cmx \ typing/btype.cmx \ @@ -1376,19 +1376,6 @@ typing/typedtree.cmi : \ typing/ident.cmi \ typing/env.cmi \ parsing/asttypes.cmi -typing/typedtreeIter.cmo : \ - typing/typedtree.cmi \ - utils/misc.cmi \ - parsing/asttypes.cmi \ - typing/typedtreeIter.cmi -typing/typedtreeIter.cmx : \ - typing/typedtree.cmx \ - utils/misc.cmx \ - parsing/asttypes.cmi \ - typing/typedtreeIter.cmi -typing/typedtreeIter.cmi : \ - typing/typedtree.cmi \ - parsing/asttypes.cmi typing/typemod.cmo : \ utils/warnings.cmi \ typing/typetexp.cmi \ @@ -1412,8 +1399,8 @@ typing/typemod.cmo : \ typing/env.cmi \ typing/ctype.cmi \ utils/config.cmi \ - typing/cmt_format.cmi \ - typing/cmi_format.cmi \ + file_formats/cmt_format.cmi \ + file_formats/cmi_format.cmi \ utils/clflags.cmi \ parsing/builtin_attributes.cmi \ typing/btype.cmi \ @@ -1444,8 +1431,8 @@ typing/typemod.cmx : \ typing/env.cmx \ typing/ctype.cmx \ utils/config.cmx \ - typing/cmt_format.cmx \ - typing/cmi_format.cmx \ + file_formats/cmt_format.cmx \ + file_formats/cmi_format.cmx \ utils/clflags.cmx \ parsing/builtin_attributes.cmx \ typing/btype.cmx \ @@ -1459,20 +1446,19 @@ typing/typemod.cmi : \ typing/typedecl.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ - utils/misc.cmi \ parsing/longident.cmi \ parsing/location.cmi \ typing/includemod.cmi \ typing/ident.cmi \ typing/env.cmi \ - typing/cmi_format.cmi + file_formats/cmi_format.cmi typing/typeopt.cmo : \ typing/types.cmi \ typing/typedtree.cmi \ typing/typedecl.cmi \ typing/predef.cmi \ typing/path.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/ident.cmi \ typing/env.cmi \ typing/ctype.cmi \ @@ -1485,7 +1471,7 @@ typing/typeopt.cmx : \ typing/typedecl.cmx \ typing/predef.cmx \ typing/path.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ typing/ident.cmx \ typing/env.cmx \ typing/ctype.cmx \ @@ -1496,7 +1482,7 @@ typing/typeopt.cmi : \ typing/types.cmi \ typing/typedtree.cmi \ typing/path.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/env.cmi typing/types.cmo : \ typing/primitive.cmi \ @@ -1612,12 +1598,12 @@ typing/untypeast.cmi : \ parsing/asttypes.cmi bytecomp/bytegen.cmo : \ typing/types.cmi \ - bytecomp/switch.cmi \ + lambda/switch.cmi \ typing/subst.cmi \ typing/primitive.cmi \ utils/misc.cmi \ - bytecomp/matching.cmi \ - bytecomp/lambda.cmi \ + lambda/matching.cmi \ + lambda/lambda.cmi \ bytecomp/instruct.cmi \ typing/ident.cmi \ typing/env.cmi \ @@ -1626,12 +1612,12 @@ bytecomp/bytegen.cmo : \ bytecomp/bytegen.cmi bytecomp/bytegen.cmx : \ typing/types.cmx \ - bytecomp/switch.cmx \ + lambda/switch.cmx \ typing/subst.cmx \ typing/primitive.cmx \ utils/misc.cmx \ - bytecomp/matching.cmx \ - bytecomp/lambda.cmx \ + lambda/matching.cmx \ + lambda/lambda.cmx \ bytecomp/instruct.cmx \ typing/ident.cmx \ typing/env.cmx \ @@ -1639,7 +1625,7 @@ bytecomp/bytegen.cmx : \ parsing/asttypes.cmi \ bytecomp/bytegen.cmi bytecomp/bytegen.cmi : \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ bytecomp/instruct.cmi bytecomp/bytelibrarian.cmo : \ utils/misc.cmi \ @@ -1647,7 +1633,7 @@ bytecomp/bytelibrarian.cmo : \ utils/load_path.cmi \ bytecomp/emitcode.cmi \ utils/config.cmi \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmi \ bytecomp/bytelink.cmi \ bytecomp/bytelibrarian.cmi @@ -1657,7 +1643,7 @@ bytecomp/bytelibrarian.cmx : \ utils/load_path.cmx \ bytecomp/emitcode.cmx \ utils/config.cmx \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmx \ bytecomp/bytelink.cmx \ bytecomp/bytelibrarian.cmi @@ -1665,7 +1651,7 @@ bytecomp/bytelibrarian.cmi : bytecomp/bytelink.cmo : \ utils/warnings.cmi \ bytecomp/symtable.cmi \ - bytecomp/opcodes.cmo \ + bytecomp/opcodes.cmi \ utils/misc.cmi \ parsing/location.cmi \ utils/load_path.cmi \ @@ -1675,7 +1661,7 @@ bytecomp/bytelink.cmo : \ bytecomp/dll.cmi \ utils/consistbl.cmi \ utils/config.cmi \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmi \ utils/ccomp.cmi \ bytecomp/bytesections.cmi \ @@ -1693,20 +1679,21 @@ bytecomp/bytelink.cmx : \ bytecomp/dll.cmx \ utils/consistbl.cmx \ utils/config.cmx \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmx \ utils/ccomp.cmx \ bytecomp/bytesections.cmx \ bytecomp/bytelink.cmi bytecomp/bytelink.cmi : \ bytecomp/symtable.cmi \ - bytecomp/cmo_format.cmi + utils/misc.cmi \ + file_formats/cmo_format.cmi bytecomp/bytepackager.cmo : \ typing/typemod.cmi \ - bytecomp/translmod.cmi \ + lambda/translmod.cmi \ typing/subst.cmi \ - bytecomp/simplif.cmi \ - bytecomp/printlambda.cmi \ + lambda/simplif.cmi \ + lambda/printlambda.cmi \ typing/path.cmi \ utils/misc.cmi \ parsing/location.cmi \ @@ -1716,17 +1703,17 @@ bytecomp/bytepackager.cmo : \ typing/env.cmi \ bytecomp/emitcode.cmi \ utils/config.cmi \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmi \ bytecomp/bytelink.cmi \ bytecomp/bytegen.cmi \ bytecomp/bytepackager.cmi bytecomp/bytepackager.cmx : \ typing/typemod.cmx \ - bytecomp/translmod.cmx \ + lambda/translmod.cmx \ typing/subst.cmx \ - bytecomp/simplif.cmx \ - bytecomp/printlambda.cmx \ + lambda/simplif.cmx \ + lambda/printlambda.cmx \ typing/path.cmx \ utils/misc.cmx \ parsing/location.cmx \ @@ -1736,7 +1723,7 @@ bytecomp/bytepackager.cmx : \ typing/env.cmx \ bytecomp/emitcode.cmx \ utils/config.cmx \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmx \ bytecomp/bytelink.cmx \ bytecomp/bytegen.cmx \ @@ -1751,9 +1738,6 @@ bytecomp/bytesections.cmx : \ utils/config.cmx \ bytecomp/bytesections.cmi bytecomp/bytesections.cmi : -bytecomp/cmo_format.cmi : \ - bytecomp/lambda.cmi \ - typing/ident.cmi bytecomp/dll.cmo : \ utils/misc.cmi \ utils/config.cmi \ @@ -1764,34 +1748,34 @@ bytecomp/dll.cmx : \ bytecomp/dll.cmi bytecomp/dll.cmi : bytecomp/emitcode.cmo : \ - bytecomp/translmod.cmi \ + lambda/translmod.cmi \ typing/primitive.cmi \ - bytecomp/opcodes.cmo \ + bytecomp/opcodes.cmi \ utils/misc.cmi \ parsing/location.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ bytecomp/instruct.cmi \ typing/ident.cmi \ typing/env.cmi \ utils/config.cmi \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmi \ bytecomp/bytegen.cmi \ typing/btype.cmi \ parsing/asttypes.cmi \ bytecomp/emitcode.cmi bytecomp/emitcode.cmx : \ - bytecomp/translmod.cmx \ + lambda/translmod.cmx \ typing/primitive.cmx \ bytecomp/opcodes.cmx \ utils/misc.cmx \ parsing/location.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ bytecomp/instruct.cmx \ typing/ident.cmx \ typing/env.cmx \ utils/config.cmx \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmx \ bytecomp/bytegen.cmx \ typing/btype.cmx \ @@ -1801,12 +1785,12 @@ bytecomp/emitcode.cmi : \ utils/misc.cmi \ bytecomp/instruct.cmi \ typing/ident.cmi \ - bytecomp/cmo_format.cmi + file_formats/cmo_format.cmi bytecomp/instruct.cmo : \ typing/types.cmi \ typing/subst.cmi \ parsing/location.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/ident.cmi \ typing/env.cmi \ bytecomp/instruct.cmi @@ -1814,7 +1798,7 @@ bytecomp/instruct.cmx : \ typing/types.cmx \ typing/subst.cmx \ parsing/location.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ typing/ident.cmx \ typing/env.cmx \ bytecomp/instruct.cmi @@ -1822,84 +1806,9 @@ bytecomp/instruct.cmi : \ typing/types.cmi \ typing/subst.cmi \ parsing/location.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/ident.cmi \ typing/env.cmi -bytecomp/lambda.cmo : \ - typing/types.cmi \ - typing/primitive.cmi \ - typing/path.cmi \ - utils/misc.cmi \ - parsing/longident.cmi \ - parsing/location.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - parsing/asttypes.cmi \ - bytecomp/lambda.cmi -bytecomp/lambda.cmx : \ - typing/types.cmx \ - typing/primitive.cmx \ - typing/path.cmx \ - utils/misc.cmx \ - parsing/longident.cmx \ - parsing/location.cmx \ - typing/ident.cmx \ - typing/env.cmx \ - parsing/asttypes.cmi \ - bytecomp/lambda.cmi -bytecomp/lambda.cmi : \ - typing/types.cmi \ - typing/primitive.cmi \ - typing/path.cmi \ - parsing/location.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - parsing/asttypes.cmi -bytecomp/matching.cmo : \ - typing/types.cmi \ - typing/typeopt.cmi \ - typing/typedtree.cmi \ - bytecomp/switch.cmi \ - typing/printpat.cmi \ - bytecomp/printlambda.cmi \ - typing/primitive.cmi \ - typing/predef.cmi \ - typing/parmatch.cmi \ - utils/misc.cmi \ - parsing/longident.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - utils/clflags.cmi \ - typing/btype.cmi \ - parsing/asttypes.cmi \ - bytecomp/matching.cmi -bytecomp/matching.cmx : \ - typing/types.cmx \ - typing/typeopt.cmx \ - typing/typedtree.cmx \ - bytecomp/switch.cmx \ - typing/printpat.cmx \ - bytecomp/printlambda.cmx \ - typing/primitive.cmx \ - typing/predef.cmx \ - typing/parmatch.cmx \ - utils/misc.cmx \ - parsing/longident.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - typing/env.cmx \ - utils/clflags.cmx \ - typing/btype.cmx \ - parsing/asttypes.cmi \ - bytecomp/matching.cmi -bytecomp/matching.cmi : \ - typing/typedtree.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi bytecomp/meta.cmo : \ bytecomp/instruct.cmi \ bytecomp/meta.cmi @@ -1908,419 +1817,111 @@ bytecomp/meta.cmx : \ bytecomp/meta.cmi bytecomp/meta.cmi : \ bytecomp/instruct.cmi -bytecomp/opcodes.cmo : -bytecomp/opcodes.cmx : +bytecomp/opcodes.cmo : \ + bytecomp/opcodes.cmi +bytecomp/opcodes.cmx : \ + bytecomp/opcodes.cmi +bytecomp/opcodes.cmi : bytecomp/printinstr.cmo : \ - bytecomp/printlambda.cmi \ + lambda/printlambda.cmi \ parsing/location.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ bytecomp/instruct.cmi \ typing/ident.cmi \ bytecomp/printinstr.cmi bytecomp/printinstr.cmx : \ - bytecomp/printlambda.cmx \ + lambda/printlambda.cmx \ parsing/location.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ bytecomp/instruct.cmx \ typing/ident.cmx \ bytecomp/printinstr.cmi bytecomp/printinstr.cmi : \ bytecomp/instruct.cmi -bytecomp/printlambda.cmo : \ - typing/types.cmi \ - typing/printtyp.cmi \ - typing/primitive.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - parsing/asttypes.cmi \ - bytecomp/printlambda.cmi -bytecomp/printlambda.cmx : \ - typing/types.cmx \ - typing/printtyp.cmx \ - typing/primitive.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - parsing/asttypes.cmi \ - bytecomp/printlambda.cmi -bytecomp/printlambda.cmi : \ - bytecomp/lambda.cmi -bytecomp/runtimedef.cmo : \ - bytecomp/runtimedef.cmi -bytecomp/runtimedef.cmx : \ - bytecomp/runtimedef.cmi -bytecomp/runtimedef.cmi : -bytecomp/semantics_of_primitives.cmo : \ - bytecomp/lambda.cmi \ - bytecomp/semantics_of_primitives.cmi -bytecomp/semantics_of_primitives.cmx : \ - bytecomp/lambda.cmx \ - bytecomp/semantics_of_primitives.cmi -bytecomp/semantics_of_primitives.cmi : \ - bytecomp/lambda.cmi -bytecomp/simplif.cmo : \ - utils/warnings.cmi \ - typing/stypes.cmi \ - utils/misc.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - utils/clflags.cmi \ - parsing/asttypes.cmi \ - typing/annot.cmi \ - bytecomp/simplif.cmi -bytecomp/simplif.cmx : \ - utils/warnings.cmx \ - typing/stypes.cmx \ - utils/misc.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - utils/clflags.cmx \ - parsing/asttypes.cmi \ - typing/annot.cmi \ - bytecomp/simplif.cmi -bytecomp/simplif.cmi : \ - utils/misc.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi -bytecomp/switch.cmo : \ - parsing/location.cmi \ - bytecomp/switch.cmi -bytecomp/switch.cmx : \ - parsing/location.cmx \ - bytecomp/switch.cmi -bytecomp/switch.cmi : \ - parsing/location.cmi bytecomp/symtable.cmo : \ - bytecomp/runtimedef.cmi \ + lambda/runtimedef.cmi \ typing/predef.cmi \ utils/misc.cmi \ bytecomp/meta.cmi \ parsing/location.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/ident.cmi \ bytecomp/dll.cmi \ utils/config.cmi \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmi \ bytecomp/bytesections.cmi \ parsing/asttypes.cmi \ bytecomp/symtable.cmi bytecomp/symtable.cmx : \ - bytecomp/runtimedef.cmx \ + lambda/runtimedef.cmx \ typing/predef.cmx \ utils/misc.cmx \ bytecomp/meta.cmx \ parsing/location.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ typing/ident.cmx \ bytecomp/dll.cmx \ utils/config.cmx \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmx \ bytecomp/bytesections.cmx \ parsing/asttypes.cmi \ bytecomp/symtable.cmi bytecomp/symtable.cmi : \ utils/misc.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - bytecomp/cmo_format.cmi -bytecomp/translattribute.cmo : \ - utils/warnings.cmi \ - typing/typedtree.cmi \ - parsing/parsetree.cmi \ - utils/misc.cmi \ - parsing/longident.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - utils/config.cmi \ - bytecomp/translattribute.cmi -bytecomp/translattribute.cmx : \ - utils/warnings.cmx \ - typing/typedtree.cmx \ - parsing/parsetree.cmi \ - utils/misc.cmx \ - parsing/longident.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - utils/config.cmx \ - bytecomp/translattribute.cmi -bytecomp/translattribute.cmi : \ - typing/typedtree.cmi \ - parsing/parsetree.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi -bytecomp/translclass.cmo : \ - typing/types.cmi \ - typing/typeopt.cmi \ - typing/typedtree.cmi \ - bytecomp/translobj.cmi \ - bytecomp/translcore.cmi \ - typing/path.cmi \ - bytecomp/matching.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/ident.cmi \ - typing/env.cmi \ + file_formats/cmo_format.cmi +asmcomp/CSE.cmo : \ + asmcomp/mach.cmi \ + asmcomp/CSEgen.cmi \ + asmcomp/arch.cmo +asmcomp/CSE.cmx : \ + asmcomp/mach.cmx \ + asmcomp/CSEgen.cmx \ + asmcomp/arch.cmx +asmcomp/CSEgen.cmo : \ + asmcomp/reg.cmi \ + asmcomp/proc.cmi \ + asmcomp/mach.cmi \ + asmcomp/cmm.cmi \ + asmcomp/CSEgen.cmi +asmcomp/CSEgen.cmx : \ + asmcomp/reg.cmx \ + asmcomp/proc.cmx \ + asmcomp/mach.cmx \ + asmcomp/cmm.cmx \ + asmcomp/CSEgen.cmi +asmcomp/CSEgen.cmi : \ + asmcomp/mach.cmi +asmcomp/afl_instrument.cmo : \ + lambda/lambda.cmi \ + asmcomp/cmm.cmi \ utils/clflags.cmi \ - typing/btype.cmi \ + middle_end/backend_var.cmi \ parsing/asttypes.cmi \ - bytecomp/translclass.cmi -bytecomp/translclass.cmx : \ - typing/types.cmx \ - typing/typeopt.cmx \ - typing/typedtree.cmx \ - bytecomp/translobj.cmx \ - bytecomp/translcore.cmx \ - typing/path.cmx \ - bytecomp/matching.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - typing/env.cmx \ + asmcomp/afl_instrument.cmi +asmcomp/afl_instrument.cmx : \ + lambda/lambda.cmx \ + asmcomp/cmm.cmx \ utils/clflags.cmx \ - typing/btype.cmx \ + middle_end/backend_var.cmx \ parsing/asttypes.cmi \ - bytecomp/translclass.cmi -bytecomp/translclass.cmi : \ - typing/typedtree.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - parsing/asttypes.cmi -bytecomp/translcore.cmo : \ - typing/types.cmi \ - typing/typeopt.cmi \ - typing/typedtree.cmi \ - typing/typecore.cmi \ - bytecomp/translprim.cmi \ - bytecomp/translobj.cmi \ - bytecomp/translattribute.cmi \ - typing/printtyp.cmi \ - typing/primitive.cmi \ - typing/predef.cmi \ - typing/path.cmi \ - parsing/parsetree.cmi \ - typing/parmatch.cmi \ - utils/misc.cmi \ - bytecomp/matching.cmi \ - parsing/longident.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - utils/config.cmi \ - utils/clflags.cmi \ - typing/btype.cmi \ - parsing/asttypes.cmi \ - bytecomp/translcore.cmi -bytecomp/translcore.cmx : \ - typing/types.cmx \ - typing/typeopt.cmx \ - typing/typedtree.cmx \ - typing/typecore.cmx \ - bytecomp/translprim.cmx \ - bytecomp/translobj.cmx \ - bytecomp/translattribute.cmx \ - typing/printtyp.cmx \ - typing/primitive.cmx \ - typing/predef.cmx \ - typing/path.cmx \ - parsing/parsetree.cmi \ - typing/parmatch.cmx \ - utils/misc.cmx \ - bytecomp/matching.cmx \ - parsing/longident.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - typing/env.cmx \ - utils/config.cmx \ - utils/clflags.cmx \ - typing/btype.cmx \ - parsing/asttypes.cmi \ - bytecomp/translcore.cmi -bytecomp/translcore.cmi : \ - typing/typedtree.cmi \ - typing/path.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - parsing/asttypes.cmi -bytecomp/translmod.cmo : \ - typing/types.cmi \ - typing/typedtree.cmi \ - bytecomp/translprim.cmi \ - bytecomp/translobj.cmi \ - bytecomp/translcore.cmi \ - bytecomp/translclass.cmi \ - bytecomp/translattribute.cmi \ - typing/primitive.cmi \ - typing/predef.cmi \ - typing/path.cmi \ - typing/mtype.cmi \ - utils/misc.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - typing/ctype.cmi \ - utils/clflags.cmi \ - parsing/asttypes.cmi \ - bytecomp/translmod.cmi -bytecomp/translmod.cmx : \ - typing/types.cmx \ - typing/typedtree.cmx \ - bytecomp/translprim.cmx \ - bytecomp/translobj.cmx \ - bytecomp/translcore.cmx \ - bytecomp/translclass.cmx \ - bytecomp/translattribute.cmx \ - typing/primitive.cmx \ - typing/predef.cmx \ - typing/path.cmx \ - typing/mtype.cmx \ - utils/misc.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - typing/env.cmx \ - typing/ctype.cmx \ - utils/clflags.cmx \ - parsing/asttypes.cmi \ - bytecomp/translmod.cmi -bytecomp/translmod.cmi : \ - typing/typedtree.cmi \ - typing/primitive.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi -bytecomp/translobj.cmo : \ - typing/primitive.cmi \ - utils/misc.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - utils/config.cmi \ - utils/clflags.cmi \ - typing/btype.cmi \ - parsing/asttypes.cmi \ - bytecomp/translobj.cmi -bytecomp/translobj.cmx : \ - typing/primitive.cmx \ - utils/misc.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - typing/env.cmx \ - utils/config.cmx \ - utils/clflags.cmx \ - typing/btype.cmx \ - parsing/asttypes.cmi \ - bytecomp/translobj.cmi -bytecomp/translobj.cmi : \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - typing/env.cmi -bytecomp/translprim.cmo : \ - typing/types.cmi \ - typing/typeopt.cmi \ - typing/typedtree.cmi \ - typing/primitive.cmi \ - typing/predef.cmi \ - typing/path.cmi \ - utils/misc.cmi \ - bytecomp/matching.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - utils/config.cmi \ - utils/clflags.cmi \ - parsing/asttypes.cmi \ - bytecomp/translprim.cmi -bytecomp/translprim.cmx : \ - typing/types.cmx \ - typing/typeopt.cmx \ - typing/typedtree.cmx \ - typing/primitive.cmx \ - typing/predef.cmx \ - typing/path.cmx \ - utils/misc.cmx \ - bytecomp/matching.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - typing/env.cmx \ - utils/config.cmx \ - utils/clflags.cmx \ - parsing/asttypes.cmi \ - bytecomp/translprim.cmi -bytecomp/translprim.cmi : \ - typing/types.cmi \ - typing/typedtree.cmi \ - typing/primitive.cmi \ - typing/path.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - typing/env.cmi -asmcomp/CSE.cmo : \ - asmcomp/mach.cmi \ - asmcomp/CSEgen.cmi \ - asmcomp/arch.cmo -asmcomp/CSE.cmx : \ - asmcomp/mach.cmx \ - asmcomp/CSEgen.cmx \ - asmcomp/arch.cmx -asmcomp/CSEgen.cmo : \ - asmcomp/reg.cmi \ - asmcomp/proc.cmi \ - asmcomp/mach.cmi \ - asmcomp/cmm.cmi \ - asmcomp/CSEgen.cmi -asmcomp/CSEgen.cmx : \ - asmcomp/reg.cmx \ - asmcomp/proc.cmx \ - asmcomp/mach.cmx \ - asmcomp/cmm.cmx \ - asmcomp/CSEgen.cmi -asmcomp/CSEgen.cmi : \ - asmcomp/mach.cmi -asmcomp/afl_instrument.cmo : \ - bytecomp/lambda.cmi \ - middle_end/debuginfo.cmi \ - asmcomp/cmm.cmi \ - utils/clflags.cmi \ - asmcomp/backend_var.cmi \ - parsing/asttypes.cmi \ - asmcomp/afl_instrument.cmi -asmcomp/afl_instrument.cmx : \ - bytecomp/lambda.cmx \ - middle_end/debuginfo.cmx \ - asmcomp/cmm.cmx \ - utils/clflags.cmx \ - asmcomp/backend_var.cmx \ - parsing/asttypes.cmi \ - asmcomp/afl_instrument.cmi -asmcomp/afl_instrument.cmi : \ - asmcomp/cmm.cmi -asmcomp/arch.cmo : \ + asmcomp/afl_instrument.cmi +asmcomp/afl_instrument.cmi : \ + lambda/debuginfo.cmi \ + asmcomp/cmm.cmi +asmcomp/arch.cmo : \ utils/config.cmi \ utils/clflags.cmi asmcomp/arch.cmx : \ utils/config.cmx \ utils/clflags.cmx asmcomp/asmgen.cmo : \ - asmcomp/un_anf.cmi \ - bytecomp/translmod.cmi \ - middle_end/base_types/symbol.cmi \ + middle_end/flambda/un_anf.cmi \ + lambda/translmod.cmi \ + middle_end/symbol.cmi \ asmcomp/split.cmi \ asmcomp/spill.cmi \ asmcomp/selection.cmi \ @@ -2332,7 +1933,7 @@ asmcomp/asmgen.cmo : \ asmcomp/printmach.cmi \ asmcomp/printlinear.cmi \ asmcomp/printcmm.cmi \ - asmcomp/printclambda.cmi \ + middle_end/printclambda.cmi \ typing/primitive.cmi \ typing/path.cmi \ utils/misc.cmi \ @@ -2340,34 +1941,34 @@ asmcomp/asmgen.cmo : \ parsing/location.cmi \ asmcomp/liveness.cmi \ asmcomp/linscan.cmi \ - middle_end/base_types/linkage_name.cmi \ + middle_end/linkage_name.cmi \ asmcomp/linearize.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ asmcomp/interval.cmi \ asmcomp/interf.cmi \ typing/ident.cmi \ - asmcomp/flambda_to_clambda.cmi \ - middle_end/flambda.cmi \ + middle_end/flambda/flambda_to_clambda.cmi \ + middle_end/flambda/flambda.cmi \ asmcomp/emitaux.cmi \ asmcomp/emit.cmi \ asmcomp/deadcode.cmi \ utils/config.cmi \ - asmcomp/compilenv.cmi \ + middle_end/compilenv.cmi \ asmcomp/comballoc.cmi \ asmcomp/coloring.cmi \ asmcomp/cmmgen.cmi \ asmcomp/cmm.cmi \ - asmcomp/closure.cmi \ + middle_end/closure/closure.cmi \ utils/clflags.cmi \ - asmcomp/clambda.cmi \ + middle_end/clambda.cmi \ asmcomp/CSE.cmo \ - asmcomp/build_export_info.cmi \ + middle_end/flambda/build_export_info.cmi \ asmcomp/debug/available_regs.cmi \ asmcomp/asmgen.cmi asmcomp/asmgen.cmx : \ - asmcomp/un_anf.cmx \ - bytecomp/translmod.cmx \ - middle_end/base_types/symbol.cmx \ + middle_end/flambda/un_anf.cmx \ + lambda/translmod.cmx \ + middle_end/symbol.cmx \ asmcomp/split.cmx \ asmcomp/spill.cmx \ asmcomp/selection.cmx \ @@ -2379,7 +1980,7 @@ asmcomp/asmgen.cmx : \ asmcomp/printmach.cmx \ asmcomp/printlinear.cmx \ asmcomp/printcmm.cmx \ - asmcomp/printclambda.cmx \ + middle_end/printclambda.cmx \ typing/primitive.cmx \ typing/path.cmx \ utils/misc.cmx \ @@ -2387,46 +1988,46 @@ asmcomp/asmgen.cmx : \ parsing/location.cmx \ asmcomp/liveness.cmx \ asmcomp/linscan.cmx \ - middle_end/base_types/linkage_name.cmx \ + middle_end/linkage_name.cmx \ asmcomp/linearize.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ asmcomp/interval.cmx \ asmcomp/interf.cmx \ typing/ident.cmx \ - asmcomp/flambda_to_clambda.cmx \ - middle_end/flambda.cmx \ + middle_end/flambda/flambda_to_clambda.cmx \ + middle_end/flambda/flambda.cmx \ asmcomp/emitaux.cmx \ asmcomp/emit.cmx \ asmcomp/deadcode.cmx \ utils/config.cmx \ - asmcomp/compilenv.cmx \ + middle_end/compilenv.cmx \ asmcomp/comballoc.cmx \ asmcomp/coloring.cmx \ asmcomp/cmmgen.cmx \ asmcomp/cmm.cmx \ - asmcomp/closure.cmx \ + middle_end/closure/closure.cmx \ utils/clflags.cmx \ - asmcomp/clambda.cmx \ + middle_end/clambda.cmx \ asmcomp/CSE.cmx \ - asmcomp/build_export_info.cmx \ + middle_end/flambda/build_export_info.cmx \ asmcomp/debug/available_regs.cmx \ asmcomp/asmgen.cmi asmcomp/asmgen.cmi : \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/ident.cmi \ - middle_end/flambda.cmi \ + middle_end/flambda/flambda.cmi \ asmcomp/cmm.cmi \ middle_end/backend_intf.cmi asmcomp/asmlibrarian.cmo : \ utils/misc.cmi \ parsing/location.cmi \ utils/load_path.cmi \ - asmcomp/export_info.cmi \ + middle_end/flambda/export_info.cmi \ utils/config.cmi \ - asmcomp/compilenv.cmi \ - asmcomp/cmx_format.cmi \ + middle_end/compilenv.cmi \ + file_formats/cmx_format.cmi \ utils/clflags.cmi \ - asmcomp/clambda.cmi \ + middle_end/clambda.cmi \ utils/ccomp.cmi \ asmcomp/asmlink.cmi \ asmcomp/asmlibrarian.cmi @@ -2434,18 +2035,18 @@ asmcomp/asmlibrarian.cmx : \ utils/misc.cmx \ parsing/location.cmx \ utils/load_path.cmx \ - asmcomp/export_info.cmx \ + middle_end/flambda/export_info.cmx \ utils/config.cmx \ - asmcomp/compilenv.cmx \ - asmcomp/cmx_format.cmi \ + middle_end/compilenv.cmx \ + file_formats/cmx_format.cmi \ utils/clflags.cmx \ - asmcomp/clambda.cmx \ + middle_end/clambda.cmx \ utils/ccomp.cmx \ asmcomp/asmlink.cmx \ asmcomp/asmlibrarian.cmi asmcomp/asmlibrarian.cmi : asmcomp/asmlink.cmo : \ - bytecomp/runtimedef.cmi \ + lambda/runtimedef.cmi \ utils/profile.cmi \ utils/misc.cmi \ parsing/location.cmi \ @@ -2454,8 +2055,8 @@ asmcomp/asmlink.cmo : \ asmcomp/emit.cmi \ utils/consistbl.cmi \ utils/config.cmi \ - asmcomp/compilenv.cmi \ - asmcomp/cmx_format.cmi \ + middle_end/compilenv.cmi \ + file_formats/cmx_format.cmi \ asmcomp/cmmgen.cmi \ asmcomp/cmm.cmi \ utils/clflags.cmi \ @@ -2463,7 +2064,7 @@ asmcomp/asmlink.cmo : \ asmcomp/asmgen.cmi \ asmcomp/asmlink.cmi asmcomp/asmlink.cmx : \ - bytecomp/runtimedef.cmx \ + lambda/runtimedef.cmx \ utils/profile.cmx \ utils/misc.cmx \ parsing/location.cmx \ @@ -2472,8 +2073,8 @@ asmcomp/asmlink.cmx : \ asmcomp/emit.cmx \ utils/consistbl.cmx \ utils/config.cmx \ - asmcomp/compilenv.cmx \ - asmcomp/cmx_format.cmi \ + middle_end/compilenv.cmx \ + file_formats/cmx_format.cmi \ asmcomp/cmmgen.cmx \ asmcomp/cmm.cmx \ utils/clflags.cmx \ @@ -2481,25 +2082,26 @@ asmcomp/asmlink.cmx : \ asmcomp/asmgen.cmx \ asmcomp/asmlink.cmi asmcomp/asmlink.cmi : \ - asmcomp/cmx_format.cmi + utils/misc.cmi \ + file_formats/cmx_format.cmi asmcomp/asmpackager.cmo : \ typing/typemod.cmi \ - bytecomp/translmod.cmi \ - bytecomp/simplif.cmi \ + lambda/translmod.cmi \ + lambda/simplif.cmi \ utils/profile.cmi \ utils/misc.cmi \ - middle_end/middle_end.cmi \ parsing/location.cmi \ utils/load_path.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/ident.cmi \ - asmcomp/export_info_for_pack.cmi \ - asmcomp/export_info.cmi \ + middle_end/flambda/flambda_middle_end.cmi \ + middle_end/flambda/export_info_for_pack.cmi \ + middle_end/flambda/export_info.cmi \ typing/env.cmi \ utils/config.cmi \ - asmcomp/compilenv.cmi \ - middle_end/base_types/compilation_unit.cmi \ - asmcomp/cmx_format.cmi \ + middle_end/compilenv.cmi \ + middle_end/compilation_unit.cmi \ + file_formats/cmx_format.cmi \ utils/clflags.cmi \ utils/ccomp.cmi \ asmcomp/asmlink.cmi \ @@ -2507,22 +2109,22 @@ asmcomp/asmpackager.cmo : \ asmcomp/asmpackager.cmi asmcomp/asmpackager.cmx : \ typing/typemod.cmx \ - bytecomp/translmod.cmx \ - bytecomp/simplif.cmx \ + lambda/translmod.cmx \ + lambda/simplif.cmx \ utils/profile.cmx \ utils/misc.cmx \ - middle_end/middle_end.cmx \ parsing/location.cmx \ utils/load_path.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ typing/ident.cmx \ - asmcomp/export_info_for_pack.cmx \ - asmcomp/export_info.cmx \ + middle_end/flambda/flambda_middle_end.cmx \ + middle_end/flambda/export_info_for_pack.cmx \ + middle_end/flambda/export_info.cmx \ typing/env.cmx \ utils/config.cmx \ - asmcomp/compilenv.cmx \ - middle_end/base_types/compilation_unit.cmx \ - asmcomp/cmx_format.cmi \ + middle_end/compilenv.cmx \ + middle_end/compilation_unit.cmx \ + file_formats/cmx_format.cmi \ utils/clflags.cmx \ utils/ccomp.cmx \ asmcomp/asmlink.cmx \ @@ -2531,20 +2133,6 @@ asmcomp/asmpackager.cmx : \ asmcomp/asmpackager.cmi : \ typing/env.cmi \ middle_end/backend_intf.cmi -asmcomp/backend_var.cmo : \ - typing/path.cmi \ - typing/ident.cmi \ - middle_end/debuginfo.cmi \ - asmcomp/backend_var.cmi -asmcomp/backend_var.cmx : \ - typing/path.cmx \ - typing/ident.cmx \ - middle_end/debuginfo.cmx \ - asmcomp/backend_var.cmi -asmcomp/backend_var.cmi : \ - typing/path.cmi \ - typing/ident.cmi \ - middle_end/debuginfo.cmi asmcomp/branch_relaxation.cmo : \ utils/misc.cmi \ asmcomp/mach.cmi \ @@ -2570,221 +2158,100 @@ asmcomp/branch_relaxation_intf.cmx : \ asmcomp/linearize.cmx \ asmcomp/cmm.cmx \ asmcomp/arch.cmx -asmcomp/build_export_info.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - asmcomp/traverse_for_exported_symbols.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - utils/misc.cmi \ - middle_end/invariant_params.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/find_recursive_functions.cmi \ - asmcomp/export_info.cmi \ - middle_end/base_types/export_id.cmi \ - asmcomp/compilenv.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi \ - utils/clflags.cmi \ - middle_end/backend_intf.cmi \ - middle_end/allocated_const.cmi \ - asmcomp/build_export_info.cmi -asmcomp/build_export_info.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - asmcomp/traverse_for_exported_symbols.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - utils/misc.cmx \ - middle_end/invariant_params.cmx \ - middle_end/inline_and_simplify_aux.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/find_recursive_functions.cmx \ - asmcomp/export_info.cmx \ - middle_end/base_types/export_id.cmx \ - asmcomp/compilenv.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_id.cmx \ - utils/clflags.cmx \ - middle_end/backend_intf.cmi \ - middle_end/allocated_const.cmx \ - asmcomp/build_export_info.cmi -asmcomp/build_export_info.cmi : \ - middle_end/flambda.cmi \ - asmcomp/export_info.cmi \ - middle_end/backend_intf.cmi -asmcomp/clambda.cmo : \ - typing/path.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - middle_end/debuginfo.cmi \ - asmcomp/backend_var.cmi \ - parsing/asttypes.cmi \ - asmcomp/clambda.cmi -asmcomp/clambda.cmx : \ - typing/path.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - middle_end/debuginfo.cmx \ - asmcomp/backend_var.cmx \ - parsing/asttypes.cmi \ - asmcomp/clambda.cmi -asmcomp/clambda.cmi : \ - typing/path.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - middle_end/debuginfo.cmi \ - asmcomp/backend_var.cmi \ - parsing/asttypes.cmi -asmcomp/closure.cmo : \ - utils/warnings.cmi \ - bytecomp/switch.cmi \ - bytecomp/simplif.cmi \ - bytecomp/semantics_of_primitives.cmi \ - typing/primitive.cmi \ - utils/numbers.cmi \ - utils/misc.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - middle_end/debuginfo.cmi \ - utils/config.cmi \ - asmcomp/compilenv.cmi \ - utils/clflags.cmi \ - asmcomp/clambda.cmi \ - asmcomp/backend_var.cmi \ - parsing/asttypes.cmi \ - asmcomp/arch.cmo \ - asmcomp/closure.cmi -asmcomp/closure.cmx : \ - utils/warnings.cmx \ - bytecomp/switch.cmx \ - bytecomp/simplif.cmx \ - bytecomp/semantics_of_primitives.cmx \ - typing/primitive.cmx \ - utils/numbers.cmx \ - utils/misc.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - typing/env.cmx \ - middle_end/debuginfo.cmx \ - utils/config.cmx \ - asmcomp/compilenv.cmx \ - utils/clflags.cmx \ - asmcomp/clambda.cmx \ - asmcomp/backend_var.cmx \ - parsing/asttypes.cmi \ - asmcomp/arch.cmx \ - asmcomp/closure.cmi -asmcomp/closure.cmi : \ - bytecomp/lambda.cmi \ - asmcomp/clambda.cmi -asmcomp/closure_offsets.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - utils/misc.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi \ - asmcomp/closure_offsets.cmi -asmcomp/closure_offsets.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - utils/misc.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/closure_id.cmx \ - asmcomp/closure_offsets.cmi -asmcomp/closure_offsets.cmi : \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi asmcomp/cmm.cmo : \ utils/targetint.cmi \ - bytecomp/lambda.cmi \ - middle_end/debuginfo.cmi \ - asmcomp/backend_var.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/backend_var.cmi \ parsing/asttypes.cmi \ asmcomp/arch.cmo \ asmcomp/cmm.cmi asmcomp/cmm.cmx : \ utils/targetint.cmx \ - bytecomp/lambda.cmx \ - middle_end/debuginfo.cmx \ - asmcomp/backend_var.cmx \ + lambda/lambda.cmx \ + lambda/debuginfo.cmx \ + middle_end/backend_var.cmx \ parsing/asttypes.cmi \ asmcomp/arch.cmx \ asmcomp/cmm.cmi asmcomp/cmm.cmi : \ utils/targetint.cmi \ - bytecomp/lambda.cmi \ - middle_end/debuginfo.cmi \ - asmcomp/backend_var.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/backend_var.cmi \ parsing/asttypes.cmi asmcomp/cmmgen.cmo : \ - asmcomp/un_anf.cmi \ + middle_end/flambda/un_anf.cmi \ typing/types.cmi \ utils/targetint.cmi \ - bytecomp/switch.cmi \ + lambda/switch.cmi \ asmcomp/strmatch.cmi \ asmcomp/proc.cmi \ - bytecomp/printlambda.cmi \ + middle_end/printclambda_primitives.cmi \ typing/primitive.cmi \ utils/numbers.cmi \ utils/misc.cmi \ - bytecomp/lambda.cmi \ - middle_end/debuginfo.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ utils/config.cmi \ - asmcomp/compilenv.cmi \ - asmcomp/cmx_format.cmi \ + middle_end/compilenv.cmi \ + file_formats/cmxs_format.cmi \ + file_formats/cmx_format.cmi \ + asmcomp/cmmgen_state.cmi \ asmcomp/cmm.cmi \ utils/clflags.cmi \ - asmcomp/clambda.cmi \ - asmcomp/backend_var.cmi \ + middle_end/clambda_primitives.cmi \ + middle_end/clambda.cmi \ + middle_end/backend_var.cmi \ parsing/asttypes.cmi \ asmcomp/arch.cmo \ asmcomp/afl_instrument.cmi \ asmcomp/cmmgen.cmi asmcomp/cmmgen.cmx : \ - asmcomp/un_anf.cmx \ + middle_end/flambda/un_anf.cmx \ typing/types.cmx \ utils/targetint.cmx \ - bytecomp/switch.cmx \ + lambda/switch.cmx \ asmcomp/strmatch.cmx \ asmcomp/proc.cmx \ - bytecomp/printlambda.cmx \ + middle_end/printclambda_primitives.cmx \ typing/primitive.cmx \ utils/numbers.cmx \ utils/misc.cmx \ - bytecomp/lambda.cmx \ - middle_end/debuginfo.cmx \ + lambda/lambda.cmx \ + lambda/debuginfo.cmx \ utils/config.cmx \ - asmcomp/compilenv.cmx \ - asmcomp/cmx_format.cmi \ + middle_end/compilenv.cmx \ + file_formats/cmxs_format.cmi \ + file_formats/cmx_format.cmi \ + asmcomp/cmmgen_state.cmx \ asmcomp/cmm.cmx \ utils/clflags.cmx \ - asmcomp/clambda.cmx \ - asmcomp/backend_var.cmx \ + middle_end/clambda_primitives.cmx \ + middle_end/clambda.cmx \ + middle_end/backend_var.cmx \ parsing/asttypes.cmi \ asmcomp/arch.cmx \ asmcomp/afl_instrument.cmx \ asmcomp/cmmgen.cmi asmcomp/cmmgen.cmi : \ - asmcomp/cmx_format.cmi \ + file_formats/cmx_format.cmi \ + asmcomp/cmm.cmi \ + middle_end/clambda.cmi +asmcomp/cmmgen_state.cmo : \ + utils/misc.cmi \ + asmcomp/cmm.cmi \ + middle_end/clambda.cmi \ + asmcomp/cmmgen_state.cmi +asmcomp/cmmgen_state.cmx : \ + utils/misc.cmx \ + asmcomp/cmm.cmx \ + middle_end/clambda.cmx \ + asmcomp/cmmgen_state.cmi +asmcomp/cmmgen_state.cmi : \ + utils/misc.cmi \ asmcomp/cmm.cmi \ - asmcomp/clambda.cmi -asmcomp/cmx_format.cmi : \ - asmcomp/export_info.cmi \ - asmcomp/clambda.cmi + middle_end/clambda.cmi asmcomp/coloring.cmo : \ asmcomp/reg.cmi \ asmcomp/proc.cmi \ @@ -2808,57 +2275,6 @@ asmcomp/comballoc.cmx : \ asmcomp/comballoc.cmi asmcomp/comballoc.cmi : \ asmcomp/mach.cmi -asmcomp/compilenv.cmo : \ - utils/warnings.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - typing/path.cmi \ - utils/misc.cmi \ - parsing/location.cmi \ - utils/load_path.cmi \ - middle_end/base_types/linkage_name.cmi \ - typing/ident.cmi \ - asmcomp/export_info.cmi \ - typing/env.cmi \ - utils/config.cmi \ - middle_end/base_types/compilation_unit.cmi \ - asmcomp/cmx_format.cmi \ - middle_end/base_types/closure_id.cmi \ - utils/clflags.cmi \ - asmcomp/clambda.cmi \ - asmcomp/compilenv.cmi -asmcomp/compilenv.cmx : \ - utils/warnings.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - typing/path.cmx \ - utils/misc.cmx \ - parsing/location.cmx \ - utils/load_path.cmx \ - middle_end/base_types/linkage_name.cmx \ - typing/ident.cmx \ - asmcomp/export_info.cmx \ - typing/env.cmx \ - utils/config.cmx \ - middle_end/base_types/compilation_unit.cmx \ - asmcomp/cmx_format.cmi \ - middle_end/base_types/closure_id.cmx \ - utils/clflags.cmx \ - asmcomp/clambda.cmx \ - asmcomp/compilenv.cmi -asmcomp/compilenv.cmi : \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/base_types/linkage_name.cmi \ - typing/ident.cmi \ - asmcomp/export_info.cmi \ - middle_end/base_types/compilation_unit.cmi \ - asmcomp/cmx_format.cmi \ - middle_end/base_types/closure_id.cmi \ - asmcomp/clambda.cmi asmcomp/deadcode.cmo : \ asmcomp/reg.cmi \ asmcomp/proc.cmi \ @@ -2885,9 +2301,9 @@ asmcomp/emit.cmo : \ asmcomp/mach.cmi \ asmcomp/linearize.cmi \ asmcomp/emitaux.cmi \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ utils/config.cmi \ - asmcomp/compilenv.cmi \ + middle_end/compilenv.cmi \ asmcomp/cmm.cmi \ utils/clflags.cmi \ asmcomp/branch_relaxation.cmi \ @@ -2905,9 +2321,9 @@ asmcomp/emit.cmx : \ asmcomp/mach.cmx \ asmcomp/linearize.cmx \ asmcomp/emitaux.cmx \ - middle_end/debuginfo.cmx \ + lambda/debuginfo.cmx \ utils/config.cmx \ - asmcomp/compilenv.cmx \ + middle_end/compilenv.cmx \ asmcomp/cmm.cmx \ utils/clflags.cmx \ asmcomp/branch_relaxation.cmx \ @@ -2917,185 +2333,21 @@ asmcomp/emit.cmi : \ asmcomp/linearize.cmi \ asmcomp/cmm.cmi asmcomp/emitaux.cmo : \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ utils/config.cmi \ asmcomp/cmm.cmi \ utils/clflags.cmi \ asmcomp/arch.cmo \ asmcomp/emitaux.cmi asmcomp/emitaux.cmx : \ - middle_end/debuginfo.cmx \ + lambda/debuginfo.cmx \ utils/config.cmx \ asmcomp/cmm.cmx \ utils/clflags.cmx \ asmcomp/arch.cmx \ asmcomp/emitaux.cmi asmcomp/emitaux.cmi : \ - middle_end/debuginfo.cmi -asmcomp/export_info.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/export_id.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi \ - asmcomp/export_info.cmi -asmcomp/export_info.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/export_id.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_id.cmx \ - asmcomp/export_info.cmi -asmcomp/export_info.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/export_id.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi -asmcomp/export_info_for_pack.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_origin.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - utils/misc.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - asmcomp/export_info.cmi \ - middle_end/base_types/export_id.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi \ - asmcomp/export_info_for_pack.cmi -asmcomp/export_info_for_pack.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/base_types/set_of_closures_origin.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - utils/misc.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - asmcomp/export_info.cmx \ - middle_end/base_types/export_id.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_id.cmx \ - asmcomp/export_info_for_pack.cmi -asmcomp/export_info_for_pack.cmi : \ - asmcomp/export_info.cmi \ - middle_end/base_types/compilation_unit.cmi -asmcomp/flambda_to_clambda.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - typing/primitive.cmi \ - middle_end/parameter.cmi \ - utils/numbers.cmi \ - middle_end/base_types/mutable_variable.cmi \ - utils/misc.cmi \ - middle_end/base_types/linkage_name.cmi \ - bytecomp/lambda.cmi \ - middle_end/initialize_symbol_to_let_symbol.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - asmcomp/export_info.cmi \ - middle_end/debuginfo.cmi \ - asmcomp/compilenv.cmi \ - asmcomp/closure_offsets.cmi \ - middle_end/base_types/closure_id.cmi \ - utils/clflags.cmi \ - asmcomp/clambda.cmi \ - asmcomp/backend_var.cmi \ - middle_end/allocated_const.cmi \ - asmcomp/flambda_to_clambda.cmi -asmcomp/flambda_to_clambda.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/static_exception.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - typing/primitive.cmx \ - middle_end/parameter.cmx \ - utils/numbers.cmx \ - middle_end/base_types/mutable_variable.cmx \ - utils/misc.cmx \ - middle_end/base_types/linkage_name.cmx \ - bytecomp/lambda.cmx \ - middle_end/initialize_symbol_to_let_symbol.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - asmcomp/export_info.cmx \ - middle_end/debuginfo.cmx \ - asmcomp/compilenv.cmx \ - asmcomp/closure_offsets.cmx \ - middle_end/base_types/closure_id.cmx \ - utils/clflags.cmx \ - asmcomp/clambda.cmx \ - asmcomp/backend_var.cmx \ - middle_end/allocated_const.cmx \ - asmcomp/flambda_to_clambda.cmi -asmcomp/flambda_to_clambda.cmi : \ - middle_end/base_types/symbol.cmi \ - middle_end/flambda.cmi \ - asmcomp/export_info.cmi \ - asmcomp/clambda.cmi -asmcomp/import_approx.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - utils/misc.cmi \ - middle_end/freshening.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - asmcomp/export_info.cmi \ - middle_end/base_types/export_id.cmi \ - asmcomp/compilenv.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi \ - asmcomp/import_approx.cmi -asmcomp/import_approx.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - utils/misc.cmx \ - middle_end/freshening.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - asmcomp/export_info.cmx \ - middle_end/base_types/export_id.cmx \ - asmcomp/compilenv.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_id.cmx \ - asmcomp/import_approx.cmi -asmcomp/import_approx.cmi : \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi + lambda/debuginfo.cmi asmcomp/interf.cmo : \ asmcomp/reg.cmi \ asmcomp/proc.cmi \ @@ -3128,7 +2380,7 @@ asmcomp/linearize.cmo : \ asmcomp/proc.cmi \ utils/misc.cmi \ asmcomp/mach.cmi \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ utils/config.cmi \ asmcomp/cmm.cmi \ asmcomp/linearize.cmi @@ -3137,14 +2389,14 @@ asmcomp/linearize.cmx : \ asmcomp/proc.cmx \ utils/misc.cmx \ asmcomp/mach.cmx \ - middle_end/debuginfo.cmx \ + lambda/debuginfo.cmx \ utils/config.cmx \ asmcomp/cmm.cmx \ asmcomp/linearize.cmi asmcomp/linearize.cmi : \ asmcomp/reg.cmi \ asmcomp/mach.cmi \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ asmcomp/cmm.cmi asmcomp/linscan.cmo : \ asmcomp/reg.cmi \ @@ -3181,77 +2433,59 @@ asmcomp/mach.cmo : \ asmcomp/debug/reg_with_debug_info.cmi \ asmcomp/debug/reg_availability_set.cmi \ asmcomp/reg.cmi \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ asmcomp/cmm.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ asmcomp/arch.cmo \ asmcomp/mach.cmi asmcomp/mach.cmx : \ asmcomp/debug/reg_with_debug_info.cmx \ asmcomp/debug/reg_availability_set.cmx \ asmcomp/reg.cmx \ - middle_end/debuginfo.cmx \ + lambda/debuginfo.cmx \ asmcomp/cmm.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ asmcomp/arch.cmx \ asmcomp/mach.cmi asmcomp/mach.cmi : \ asmcomp/debug/reg_availability_set.cmi \ asmcomp/reg.cmi \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ asmcomp/cmm.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ asmcomp/arch.cmo -asmcomp/printclambda.cmo : \ - bytecomp/printlambda.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - asmcomp/clambda.cmi \ - asmcomp/backend_var.cmi \ - parsing/asttypes.cmi \ - asmcomp/printclambda.cmi -asmcomp/printclambda.cmx : \ - bytecomp/printlambda.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - asmcomp/clambda.cmx \ - asmcomp/backend_var.cmx \ - parsing/asttypes.cmi \ - asmcomp/printclambda.cmi -asmcomp/printclambda.cmi : \ - asmcomp/clambda.cmi asmcomp/printcmm.cmo : \ utils/targetint.cmi \ - bytecomp/lambda.cmi \ - middle_end/debuginfo.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ asmcomp/cmm.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ parsing/asttypes.cmi \ asmcomp/printcmm.cmi asmcomp/printcmm.cmx : \ utils/targetint.cmx \ - bytecomp/lambda.cmx \ - middle_end/debuginfo.cmx \ + lambda/lambda.cmx \ + lambda/debuginfo.cmx \ asmcomp/cmm.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ parsing/asttypes.cmi \ asmcomp/printcmm.cmi asmcomp/printcmm.cmi : \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ asmcomp/cmm.cmi asmcomp/printlinear.cmo : \ asmcomp/printmach.cmi \ asmcomp/printcmm.cmi \ asmcomp/mach.cmi \ asmcomp/linearize.cmi \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ asmcomp/printlinear.cmi asmcomp/printlinear.cmx : \ asmcomp/printmach.cmx \ asmcomp/printcmm.cmx \ asmcomp/mach.cmx \ asmcomp/linearize.cmx \ - middle_end/debuginfo.cmx \ + lambda/debuginfo.cmx \ asmcomp/printlinear.cmi asmcomp/printlinear.cmi : \ asmcomp/linearize.cmi @@ -3262,11 +2496,11 @@ asmcomp/printmach.cmo : \ asmcomp/printcmm.cmi \ asmcomp/mach.cmi \ asmcomp/interval.cmi \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ utils/config.cmi \ asmcomp/cmm.cmi \ utils/clflags.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ asmcomp/arch.cmo \ asmcomp/printmach.cmi asmcomp/printmach.cmx : \ @@ -3276,11 +2510,11 @@ asmcomp/printmach.cmx : \ asmcomp/printcmm.cmx \ asmcomp/mach.cmx \ asmcomp/interval.cmx \ - middle_end/debuginfo.cmx \ + lambda/debuginfo.cmx \ utils/config.cmx \ asmcomp/cmm.cmx \ utils/clflags.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ asmcomp/arch.cmx \ asmcomp/printmach.cmi asmcomp/printmach.cmi : \ @@ -3309,15 +2543,15 @@ asmcomp/proc.cmi : \ asmcomp/mach.cmi asmcomp/reg.cmo : \ asmcomp/cmm.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ asmcomp/reg.cmi asmcomp/reg.cmx : \ asmcomp/cmm.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ asmcomp/reg.cmi asmcomp/reg.cmi : \ asmcomp/cmm.cmi \ - asmcomp/backend_var.cmi + middle_end/backend_var.cmi asmcomp/reload.cmo : \ asmcomp/reloadgen.cmi \ asmcomp/reg.cmi \ @@ -3355,6 +2589,7 @@ asmcomp/schedgen.cmo : \ asmcomp/mach.cmi \ asmcomp/linearize.cmi \ asmcomp/cmm.cmi \ + utils/clflags.cmi \ asmcomp/arch.cmo \ asmcomp/schedgen.cmi asmcomp/schedgen.cmx : \ @@ -3363,6 +2598,7 @@ asmcomp/schedgen.cmx : \ asmcomp/mach.cmx \ asmcomp/linearize.cmx \ asmcomp/cmm.cmx \ + utils/clflags.cmx \ asmcomp/arch.cmx \ asmcomp/schedgen.cmi asmcomp/schedgen.cmi : \ @@ -3377,41 +2613,41 @@ asmcomp/scheduling.cmx : \ asmcomp/scheduling.cmi : \ asmcomp/linearize.cmi asmcomp/selectgen.cmo : \ - bytecomp/simplif.cmi \ + lambda/simplif.cmi \ asmcomp/reg.cmi \ asmcomp/proc.cmi \ utils/numbers.cmi \ utils/misc.cmi \ asmcomp/mach.cmi \ - bytecomp/lambda.cmi \ - middle_end/debuginfo.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ utils/config.cmi \ asmcomp/cmm.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ parsing/asttypes.cmi \ asmcomp/arch.cmo \ asmcomp/selectgen.cmi asmcomp/selectgen.cmx : \ - bytecomp/simplif.cmx \ + lambda/simplif.cmx \ asmcomp/reg.cmx \ asmcomp/proc.cmx \ utils/numbers.cmx \ utils/misc.cmx \ asmcomp/mach.cmx \ - bytecomp/lambda.cmx \ - middle_end/debuginfo.cmx \ + lambda/lambda.cmx \ + lambda/debuginfo.cmx \ utils/config.cmx \ asmcomp/cmm.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ parsing/asttypes.cmi \ asmcomp/arch.cmx \ asmcomp/selectgen.cmi asmcomp/selectgen.cmi : \ asmcomp/reg.cmi \ asmcomp/mach.cmi \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ asmcomp/cmm.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ asmcomp/arch.cmo asmcomp/selection.cmo : \ asmcomp/spacetime_profiling.cmi \ @@ -3441,11 +2677,11 @@ asmcomp/spacetime_profiling.cmo : \ asmcomp/proc.cmi \ utils/misc.cmi \ asmcomp/mach.cmi \ - bytecomp/lambda.cmi \ - middle_end/debuginfo.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ utils/config.cmi \ asmcomp/cmm.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ parsing/asttypes.cmi \ asmcomp/arch.cmo \ asmcomp/spacetime_profiling.cmi @@ -3454,11 +2690,11 @@ asmcomp/spacetime_profiling.cmx : \ asmcomp/proc.cmx \ utils/misc.cmx \ asmcomp/mach.cmx \ - bytecomp/lambda.cmx \ - middle_end/debuginfo.cmx \ + lambda/lambda.cmx \ + lambda/debuginfo.cmx \ utils/config.cmx \ asmcomp/cmm.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ parsing/asttypes.cmi \ asmcomp/arch.cmx \ asmcomp/spacetime_profiling.cmi @@ -3476,1804 +2712,2704 @@ asmcomp/spill.cmx : \ asmcomp/reg.cmx \ asmcomp/proc.cmx \ utils/misc.cmx \ - asmcomp/mach.cmx \ - asmcomp/cmm.cmx \ + asmcomp/mach.cmx \ + asmcomp/cmm.cmx \ + utils/clflags.cmx \ + asmcomp/spill.cmi +asmcomp/spill.cmi : \ + asmcomp/mach.cmi +asmcomp/split.cmo : \ + asmcomp/reg.cmi \ + utils/misc.cmi \ + asmcomp/mach.cmi \ + asmcomp/split.cmi +asmcomp/split.cmx : \ + asmcomp/reg.cmx \ + utils/misc.cmx \ + asmcomp/mach.cmx \ + asmcomp/split.cmi +asmcomp/split.cmi : \ + asmcomp/mach.cmi +asmcomp/strmatch.cmo : \ + parsing/location.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ + asmcomp/cmm.cmi \ + middle_end/backend_var.cmi \ + parsing/asttypes.cmi \ + asmcomp/arch.cmo \ + asmcomp/strmatch.cmi +asmcomp/strmatch.cmx : \ + parsing/location.cmx \ + lambda/lambda.cmx \ + lambda/debuginfo.cmx \ + asmcomp/cmm.cmx \ + middle_end/backend_var.cmx \ + parsing/asttypes.cmi \ + asmcomp/arch.cmx \ + asmcomp/strmatch.cmi +asmcomp/strmatch.cmi : \ + parsing/location.cmi \ + lambda/debuginfo.cmi \ + asmcomp/cmm.cmi +asmcomp/x86_ast.cmi : +asmcomp/x86_dsl.cmo : \ + asmcomp/x86_proc.cmi \ + asmcomp/x86_ast.cmi \ + asmcomp/x86_dsl.cmi +asmcomp/x86_dsl.cmx : \ + asmcomp/x86_proc.cmx \ + asmcomp/x86_ast.cmi \ + asmcomp/x86_dsl.cmi +asmcomp/x86_dsl.cmi : \ + asmcomp/x86_ast.cmi +asmcomp/x86_gas.cmo : \ + asmcomp/x86_proc.cmi \ + asmcomp/x86_ast.cmi \ + utils/misc.cmi \ + asmcomp/x86_gas.cmi +asmcomp/x86_gas.cmx : \ + asmcomp/x86_proc.cmx \ + asmcomp/x86_ast.cmi \ + utils/misc.cmx \ + asmcomp/x86_gas.cmi +asmcomp/x86_gas.cmi : \ + asmcomp/x86_ast.cmi +asmcomp/x86_masm.cmo : \ + asmcomp/x86_proc.cmi \ + asmcomp/x86_ast.cmi \ + asmcomp/x86_masm.cmi +asmcomp/x86_masm.cmx : \ + asmcomp/x86_proc.cmx \ + asmcomp/x86_ast.cmi \ + asmcomp/x86_masm.cmi +asmcomp/x86_masm.cmi : \ + asmcomp/x86_ast.cmi +asmcomp/x86_proc.cmo : \ + asmcomp/x86_ast.cmi \ + utils/misc.cmi \ + utils/config.cmi \ + utils/clflags.cmi \ + utils/ccomp.cmi \ + asmcomp/x86_proc.cmi +asmcomp/x86_proc.cmx : \ + asmcomp/x86_ast.cmi \ + utils/misc.cmx \ + utils/config.cmx \ + utils/clflags.cmx \ + utils/ccomp.cmx \ + asmcomp/x86_proc.cmi +asmcomp/x86_proc.cmi : \ + asmcomp/x86_ast.cmi +middle_end/backend_intf.cmi : \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + typing/ident.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/backend_var.cmo : \ + typing/path.cmi \ + typing/ident.cmi \ + lambda/debuginfo.cmi \ + middle_end/backend_var.cmi +middle_end/backend_var.cmx : \ + typing/path.cmx \ + typing/ident.cmx \ + lambda/debuginfo.cmx \ + middle_end/backend_var.cmi +middle_end/backend_var.cmi : \ + typing/path.cmi \ + typing/ident.cmi \ + lambda/debuginfo.cmi +middle_end/clambda.cmo : \ + typing/path.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + lambda/debuginfo.cmi \ + middle_end/clambda_primitives.cmi \ + middle_end/backend_var.cmi \ + parsing/asttypes.cmi \ + middle_end/clambda.cmi +middle_end/clambda.cmx : \ + typing/path.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + lambda/debuginfo.cmx \ + middle_end/clambda_primitives.cmx \ + middle_end/backend_var.cmx \ + parsing/asttypes.cmi \ + middle_end/clambda.cmi +middle_end/clambda.cmi : \ + typing/path.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + lambda/debuginfo.cmi \ + middle_end/clambda_primitives.cmi \ + middle_end/backend_var.cmi \ + parsing/asttypes.cmi +middle_end/clambda_primitives.cmo : \ + typing/types.cmi \ + typing/primitive.cmi \ + lambda/lambda.cmi \ + parsing/asttypes.cmi \ + middle_end/clambda_primitives.cmi +middle_end/clambda_primitives.cmx : \ + typing/types.cmx \ + typing/primitive.cmx \ + lambda/lambda.cmx \ + parsing/asttypes.cmi \ + middle_end/clambda_primitives.cmi +middle_end/clambda_primitives.cmi : \ + typing/types.cmi \ + typing/primitive.cmi \ + lambda/lambda.cmi \ + parsing/asttypes.cmi +middle_end/compilation_unit.cmo : \ + utils/misc.cmi \ + middle_end/linkage_name.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + utils/identifiable.cmi \ + typing/ident.cmi \ + middle_end/compilation_unit.cmi +middle_end/compilation_unit.cmx : \ + utils/misc.cmx \ + middle_end/linkage_name.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + utils/identifiable.cmx \ + typing/ident.cmx \ + middle_end/compilation_unit.cmi +middle_end/compilation_unit.cmi : \ + middle_end/linkage_name.cmi \ + utils/identifiable.cmi \ + typing/ident.cmi +middle_end/compilenv.cmo : \ + utils/warnings.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + typing/path.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + utils/load_path.cmi \ + middle_end/linkage_name.cmi \ + typing/ident.cmi \ + middle_end/flambda/export_info.cmi \ + typing/env.cmi \ + utils/config.cmi \ + middle_end/compilation_unit.cmi \ + file_formats/cmx_format.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + utils/clflags.cmi \ + middle_end/clambda.cmi \ + middle_end/compilenv.cmi +middle_end/compilenv.cmx : \ + utils/warnings.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + typing/path.cmx \ + utils/misc.cmx \ + parsing/location.cmx \ + utils/load_path.cmx \ + middle_end/linkage_name.cmx \ + typing/ident.cmx \ + middle_end/flambda/export_info.cmx \ + typing/env.cmx \ + utils/config.cmx \ + middle_end/compilation_unit.cmx \ + file_formats/cmx_format.cmi \ + middle_end/flambda/base_types/closure_id.cmx \ + utils/clflags.cmx \ + middle_end/clambda.cmx \ + middle_end/compilenv.cmi +middle_end/compilenv.cmi : \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/linkage_name.cmi \ + typing/ident.cmi \ + middle_end/flambda/export_info.cmi \ + middle_end/compilation_unit.cmi \ + file_formats/cmx_format.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/clambda.cmi +middle_end/convert_primitives.cmo : \ + lambda/printlambda.cmi \ + utils/misc.cmi \ + lambda/lambda.cmi \ + middle_end/clambda_primitives.cmi \ + middle_end/convert_primitives.cmi +middle_end/convert_primitives.cmx : \ + lambda/printlambda.cmx \ + utils/misc.cmx \ + lambda/lambda.cmx \ + middle_end/clambda_primitives.cmx \ + middle_end/convert_primitives.cmi +middle_end/convert_primitives.cmi : \ + lambda/lambda.cmi \ + middle_end/clambda_primitives.cmi +middle_end/internal_variable_names.cmo : \ + parsing/location.cmi \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/internal_variable_names.cmi +middle_end/internal_variable_names.cmx : \ + parsing/location.cmx \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/internal_variable_names.cmi +middle_end/internal_variable_names.cmi : \ + parsing/location.cmi \ + lambda/lambda.cmi +middle_end/linkage_name.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ + utils/identifiable.cmi \ + middle_end/linkage_name.cmi +middle_end/linkage_name.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ + utils/identifiable.cmx \ + middle_end/linkage_name.cmi +middle_end/linkage_name.cmi : \ + utils/identifiable.cmi +middle_end/printclambda.cmo : \ + lambda/printlambda.cmi \ + middle_end/printclambda_primitives.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + middle_end/clambda.cmi \ + middle_end/backend_var.cmi \ + parsing/asttypes.cmi \ + middle_end/printclambda.cmi +middle_end/printclambda.cmx : \ + lambda/printlambda.cmx \ + middle_end/printclambda_primitives.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + middle_end/clambda.cmx \ + middle_end/backend_var.cmx \ + parsing/asttypes.cmi \ + middle_end/printclambda.cmi +middle_end/printclambda.cmi : \ + middle_end/clambda.cmi +middle_end/printclambda_primitives.cmo : \ + lambda/printlambda.cmi \ + typing/primitive.cmi \ + lambda/lambda.cmi \ + middle_end/clambda_primitives.cmi \ + parsing/asttypes.cmi \ + middle_end/printclambda_primitives.cmi +middle_end/printclambda_primitives.cmx : \ + lambda/printlambda.cmx \ + typing/primitive.cmx \ + lambda/lambda.cmx \ + middle_end/clambda_primitives.cmx \ + parsing/asttypes.cmi \ + middle_end/printclambda_primitives.cmi +middle_end/printclambda_primitives.cmi : \ + middle_end/clambda_primitives.cmi +middle_end/semantics_of_primitives.cmo : \ + middle_end/clambda_primitives.cmi \ + middle_end/semantics_of_primitives.cmi +middle_end/semantics_of_primitives.cmx : \ + middle_end/clambda_primitives.cmx \ + middle_end/semantics_of_primitives.cmi +middle_end/semantics_of_primitives.cmi : \ + middle_end/clambda_primitives.cmi +middle_end/symbol.cmo : \ + middle_end/variable.cmi \ + utils/misc.cmi \ + middle_end/linkage_name.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + utils/identifiable.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/symbol.cmi +middle_end/symbol.cmx : \ + middle_end/variable.cmx \ + utils/misc.cmx \ + middle_end/linkage_name.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + utils/identifiable.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/symbol.cmi +middle_end/symbol.cmi : \ + middle_end/variable.cmi \ + middle_end/linkage_name.cmi \ + utils/identifiable.cmi \ + middle_end/compilation_unit.cmi +middle_end/variable.cmo : \ + utils/misc.cmi \ + middle_end/internal_variable_names.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + utils/identifiable.cmi \ + typing/ident.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/variable.cmi +middle_end/variable.cmx : \ + utils/misc.cmx \ + middle_end/internal_variable_names.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + utils/identifiable.cmx \ + typing/ident.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/variable.cmi +middle_end/variable.cmi : \ + middle_end/internal_variable_names.cmi \ + utils/identifiable.cmi \ + typing/ident.cmi \ + middle_end/compilation_unit.cmi +lambda/debuginfo.cmo : \ + parsing/location.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + lambda/debuginfo.cmi +lambda/debuginfo.cmx : \ + parsing/location.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + lambda/debuginfo.cmi +lambda/debuginfo.cmi : \ + parsing/location.cmi +lambda/lambda.cmo : \ + typing/types.cmi \ + typing/primitive.cmi \ + typing/path.cmi \ + utils/misc.cmi \ + parsing/longident.cmi \ + parsing/location.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + parsing/asttypes.cmi \ + lambda/lambda.cmi +lambda/lambda.cmx : \ + typing/types.cmx \ + typing/primitive.cmx \ + typing/path.cmx \ + utils/misc.cmx \ + parsing/longident.cmx \ + parsing/location.cmx \ + typing/ident.cmx \ + typing/env.cmx \ + parsing/asttypes.cmi \ + lambda/lambda.cmi +lambda/lambda.cmi : \ + typing/types.cmi \ + typing/primitive.cmi \ + typing/path.cmi \ + parsing/location.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + parsing/asttypes.cmi +lambda/matching.cmo : \ + typing/types.cmi \ + typing/typeopt.cmi \ + typing/typedtree.cmi \ + lambda/switch.cmi \ + typing/printpat.cmi \ + lambda/printlambda.cmi \ + typing/primitive.cmi \ + typing/predef.cmi \ + typing/parmatch.cmi \ + utils/misc.cmi \ + parsing/longident.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + utils/clflags.cmi \ + typing/btype.cmi \ + parsing/asttypes.cmi \ + lambda/matching.cmi +lambda/matching.cmx : \ + typing/types.cmx \ + typing/typeopt.cmx \ + typing/typedtree.cmx \ + lambda/switch.cmx \ + typing/printpat.cmx \ + lambda/printlambda.cmx \ + typing/primitive.cmx \ + typing/predef.cmx \ + typing/parmatch.cmx \ + utils/misc.cmx \ + parsing/longident.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + typing/env.cmx \ + utils/clflags.cmx \ + typing/btype.cmx \ + parsing/asttypes.cmi \ + lambda/matching.cmi +lambda/matching.cmi : \ + typing/typedtree.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi +lambda/printlambda.cmo : \ + typing/types.cmi \ + typing/printtyp.cmi \ + typing/primitive.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + parsing/asttypes.cmi \ + lambda/printlambda.cmi +lambda/printlambda.cmx : \ + typing/types.cmx \ + typing/printtyp.cmx \ + typing/primitive.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + parsing/asttypes.cmi \ + lambda/printlambda.cmi +lambda/printlambda.cmi : \ + typing/types.cmi \ + lambda/lambda.cmi +lambda/runtimedef.cmo : \ + lambda/runtimedef.cmi +lambda/runtimedef.cmx : \ + lambda/runtimedef.cmi +lambda/runtimedef.cmi : +lambda/simplif.cmo : \ + utils/warnings.cmi \ + typing/stypes.cmi \ + typing/primitive.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + utils/clflags.cmi \ + parsing/asttypes.cmi \ + typing/annot.cmi \ + lambda/simplif.cmi +lambda/simplif.cmx : \ + utils/warnings.cmx \ + typing/stypes.cmx \ + typing/primitive.cmx \ + utils/misc.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + utils/clflags.cmx \ + parsing/asttypes.cmi \ + typing/annot.cmi \ + lambda/simplif.cmi +lambda/simplif.cmi : \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi +lambda/switch.cmo : \ + parsing/location.cmi \ + lambda/switch.cmi +lambda/switch.cmx : \ + parsing/location.cmx \ + lambda/switch.cmi +lambda/switch.cmi : \ + parsing/location.cmi +lambda/translattribute.cmo : \ + utils/warnings.cmi \ + typing/typedtree.cmi \ + parsing/parsetree.cmi \ + utils/misc.cmi \ + parsing/longident.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + utils/config.cmi \ + lambda/translattribute.cmi +lambda/translattribute.cmx : \ + utils/warnings.cmx \ + typing/typedtree.cmx \ + parsing/parsetree.cmi \ + utils/misc.cmx \ + parsing/longident.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + utils/config.cmx \ + lambda/translattribute.cmi +lambda/translattribute.cmi : \ + typing/typedtree.cmi \ + parsing/parsetree.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi +lambda/translclass.cmo : \ + typing/types.cmi \ + typing/typeopt.cmi \ + typing/typedtree.cmi \ + lambda/translobj.cmi \ + lambda/translcore.cmi \ + typing/path.cmi \ + lambda/matching.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + utils/clflags.cmi \ + typing/btype.cmi \ + parsing/asttypes.cmi \ + lambda/translclass.cmi +lambda/translclass.cmx : \ + typing/types.cmx \ + typing/typeopt.cmx \ + typing/typedtree.cmx \ + lambda/translobj.cmx \ + lambda/translcore.cmx \ + typing/path.cmx \ + lambda/matching.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + typing/env.cmx \ + utils/clflags.cmx \ + typing/btype.cmx \ + parsing/asttypes.cmi \ + lambda/translclass.cmi +lambda/translclass.cmi : \ + typing/typedtree.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + parsing/asttypes.cmi +lambda/translcore.cmo : \ + typing/types.cmi \ + typing/typeopt.cmi \ + typing/typedtree.cmi \ + typing/typecore.cmi \ + lambda/translprim.cmi \ + lambda/translobj.cmi \ + lambda/translattribute.cmi \ + typing/printtyp.cmi \ + typing/primitive.cmi \ + typing/predef.cmi \ + typing/path.cmi \ + parsing/parsetree.cmi \ + typing/parmatch.cmi \ + utils/misc.cmi \ + lambda/matching.cmi \ + parsing/longident.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + utils/config.cmi \ + utils/clflags.cmi \ + typing/btype.cmi \ + parsing/asttypes.cmi \ + lambda/translcore.cmi +lambda/translcore.cmx : \ + typing/types.cmx \ + typing/typeopt.cmx \ + typing/typedtree.cmx \ + typing/typecore.cmx \ + lambda/translprim.cmx \ + lambda/translobj.cmx \ + lambda/translattribute.cmx \ + typing/printtyp.cmx \ + typing/primitive.cmx \ + typing/predef.cmx \ + typing/path.cmx \ + parsing/parsetree.cmi \ + typing/parmatch.cmx \ + utils/misc.cmx \ + lambda/matching.cmx \ + parsing/longident.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + typing/env.cmx \ + utils/config.cmx \ + utils/clflags.cmx \ + typing/btype.cmx \ + parsing/asttypes.cmi \ + lambda/translcore.cmi +lambda/translcore.cmi : \ + typing/typedtree.cmi \ + typing/path.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + parsing/asttypes.cmi +lambda/translmod.cmo : \ + typing/types.cmi \ + typing/typedtree.cmi \ + lambda/translprim.cmi \ + lambda/translobj.cmi \ + lambda/translcore.cmi \ + lambda/translclass.cmi \ + lambda/translattribute.cmi \ + typing/primitive.cmi \ + typing/predef.cmi \ + typing/path.cmi \ + typing/mtype.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + typing/ctype.cmi \ + utils/clflags.cmi \ + parsing/asttypes.cmi \ + lambda/translmod.cmi +lambda/translmod.cmx : \ + typing/types.cmx \ + typing/typedtree.cmx \ + lambda/translprim.cmx \ + lambda/translobj.cmx \ + lambda/translcore.cmx \ + lambda/translclass.cmx \ + lambda/translattribute.cmx \ + typing/primitive.cmx \ + typing/predef.cmx \ + typing/path.cmx \ + typing/mtype.cmx \ + utils/misc.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + typing/env.cmx \ + typing/ctype.cmx \ + utils/clflags.cmx \ + parsing/asttypes.cmi \ + lambda/translmod.cmi +lambda/translmod.cmi : \ + typing/typedtree.cmi \ + typing/primitive.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi +lambda/translobj.cmo : \ + typing/primitive.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + utils/config.cmi \ + utils/clflags.cmi \ + typing/btype.cmi \ + parsing/asttypes.cmi \ + lambda/translobj.cmi +lambda/translobj.cmx : \ + typing/primitive.cmx \ + utils/misc.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + typing/env.cmx \ + utils/config.cmx \ + utils/clflags.cmx \ + typing/btype.cmx \ + parsing/asttypes.cmi \ + lambda/translobj.cmi +lambda/translobj.cmi : \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi +lambda/translprim.cmo : \ + typing/types.cmi \ + typing/typeopt.cmi \ + typing/typedtree.cmi \ + typing/primitive.cmi \ + typing/predef.cmi \ + typing/path.cmi \ + utils/misc.cmi \ + lambda/matching.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + utils/config.cmi \ + utils/clflags.cmi \ + parsing/asttypes.cmi \ + lambda/translprim.cmi +lambda/translprim.cmx : \ + typing/types.cmx \ + typing/typeopt.cmx \ + typing/typedtree.cmx \ + typing/primitive.cmx \ + typing/predef.cmx \ + typing/path.cmx \ + utils/misc.cmx \ + lambda/matching.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + typing/env.cmx \ + utils/config.cmx \ utils/clflags.cmx \ - asmcomp/spill.cmi -asmcomp/spill.cmi : \ - asmcomp/mach.cmi -asmcomp/split.cmo : \ - asmcomp/reg.cmi \ + parsing/asttypes.cmi \ + lambda/translprim.cmi +lambda/translprim.cmi : \ + typing/types.cmi \ + typing/typedtree.cmi \ + typing/primitive.cmi \ + typing/path.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi +file_formats/cmi_format.cmo : \ + typing/types.cmi \ utils/misc.cmi \ - asmcomp/mach.cmi \ - asmcomp/split.cmi -asmcomp/split.cmx : \ - asmcomp/reg.cmx \ - utils/misc.cmx \ - asmcomp/mach.cmx \ - asmcomp/split.cmi -asmcomp/split.cmi : \ - asmcomp/mach.cmi -asmcomp/strmatch.cmo : \ parsing/location.cmi \ - bytecomp/lambda.cmi \ - middle_end/debuginfo.cmi \ - asmcomp/cmm.cmi \ - asmcomp/backend_var.cmi \ - parsing/asttypes.cmi \ - asmcomp/arch.cmo \ - asmcomp/strmatch.cmi -asmcomp/strmatch.cmx : \ + utils/config.cmi \ + file_formats/cmi_format.cmi +file_formats/cmi_format.cmx : \ + typing/types.cmx \ + utils/misc.cmx \ parsing/location.cmx \ - bytecomp/lambda.cmx \ - middle_end/debuginfo.cmx \ - asmcomp/cmm.cmx \ - asmcomp/backend_var.cmx \ - parsing/asttypes.cmi \ - asmcomp/arch.cmx \ - asmcomp/strmatch.cmi -asmcomp/strmatch.cmi : \ + utils/config.cmx \ + file_formats/cmi_format.cmi +file_formats/cmi_format.cmi : \ + typing/types.cmi \ + utils/misc.cmi +file_formats/cmo_format.cmi : \ + utils/misc.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi +file_formats/cmt_format.cmo : \ + typing/types.cmi \ + typing/typedtree.cmi \ + typing/tast_mapper.cmi \ + utils/misc.cmi \ parsing/location.cmi \ - middle_end/debuginfo.cmi \ - asmcomp/cmm.cmi -asmcomp/traverse_for_exported_symbols.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - utils/misc.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - asmcomp/export_info.cmi \ - middle_end/base_types/export_id.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi \ - asmcomp/traverse_for_exported_symbols.cmi -asmcomp/traverse_for_exported_symbols.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - utils/misc.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - asmcomp/export_info.cmx \ - middle_end/base_types/export_id.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_id.cmx \ - asmcomp/traverse_for_exported_symbols.cmi -asmcomp/traverse_for_exported_symbols.cmi : \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/flambda.cmi \ - asmcomp/export_info.cmi \ - middle_end/base_types/export_id.cmi \ - middle_end/base_types/closure_id.cmi -asmcomp/un_anf.cmo : \ - bytecomp/semantics_of_primitives.cmi \ - asmcomp/printclambda.cmi \ - utils/misc.cmi \ - bytecomp/lambda.cmi \ - middle_end/debuginfo.cmi \ + utils/load_path.cmi \ + parsing/lexer.cmi \ + typing/env.cmi \ + utils/config.cmi \ + file_formats/cmi_format.cmi \ utils/clflags.cmi \ - asmcomp/clambda.cmi \ - asmcomp/backend_var.cmi \ - parsing/asttypes.cmi \ - asmcomp/un_anf.cmi -asmcomp/un_anf.cmx : \ - bytecomp/semantics_of_primitives.cmx \ - asmcomp/printclambda.cmx \ + file_formats/cmt_format.cmi +file_formats/cmt_format.cmx : \ + typing/types.cmx \ + typing/typedtree.cmx \ + typing/tast_mapper.cmx \ utils/misc.cmx \ - bytecomp/lambda.cmx \ - middle_end/debuginfo.cmx \ + parsing/location.cmx \ + utils/load_path.cmx \ + parsing/lexer.cmx \ + typing/env.cmx \ + utils/config.cmx \ + file_formats/cmi_format.cmx \ utils/clflags.cmx \ - asmcomp/clambda.cmx \ - asmcomp/backend_var.cmx \ - parsing/asttypes.cmi \ - asmcomp/un_anf.cmi -asmcomp/un_anf.cmi : \ - asmcomp/clambda.cmi -asmcomp/x86_ast.cmi : -asmcomp/x86_dsl.cmo : \ - asmcomp/x86_proc.cmi \ - asmcomp/x86_ast.cmi \ - asmcomp/x86_dsl.cmi -asmcomp/x86_dsl.cmx : \ - asmcomp/x86_proc.cmx \ - asmcomp/x86_ast.cmi \ - asmcomp/x86_dsl.cmi -asmcomp/x86_dsl.cmi : \ - asmcomp/x86_ast.cmi -asmcomp/x86_gas.cmo : \ - asmcomp/x86_proc.cmi \ - asmcomp/x86_ast.cmi \ + file_formats/cmt_format.cmi +file_formats/cmt_format.cmi : \ + typing/types.cmi \ + typing/typedtree.cmi \ utils/misc.cmi \ - asmcomp/x86_gas.cmi -asmcomp/x86_gas.cmx : \ - asmcomp/x86_proc.cmx \ - asmcomp/x86_ast.cmi \ - utils/misc.cmx \ - asmcomp/x86_gas.cmi -asmcomp/x86_gas.cmi : \ - asmcomp/x86_ast.cmi -asmcomp/x86_masm.cmo : \ - asmcomp/x86_proc.cmi \ - asmcomp/x86_ast.cmi \ - asmcomp/x86_masm.cmi -asmcomp/x86_masm.cmx : \ - asmcomp/x86_proc.cmx \ - asmcomp/x86_ast.cmi \ - asmcomp/x86_masm.cmi -asmcomp/x86_masm.cmi : \ - asmcomp/x86_ast.cmi -asmcomp/x86_proc.cmo : \ - asmcomp/x86_ast.cmi \ + parsing/location.cmi \ + typing/env.cmi \ + file_formats/cmi_format.cmi +file_formats/cmx_format.cmi : \ + utils/misc.cmi \ + middle_end/flambda/export_info.cmi \ + middle_end/clambda.cmi +file_formats/cmxs_format.cmi : \ + utils/misc.cmi +middle_end/closure/closure.cmo : \ + utils/warnings.cmi \ + lambda/switch.cmi \ + lambda/simplif.cmi \ + middle_end/semantics_of_primitives.cmi \ + typing/primitive.cmi \ + utils/numbers.cmi \ utils/misc.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + lambda/debuginfo.cmi \ + middle_end/convert_primitives.cmi \ utils/config.cmi \ + middle_end/compilenv.cmi \ utils/clflags.cmi \ - utils/ccomp.cmi \ - asmcomp/x86_proc.cmi -asmcomp/x86_proc.cmx : \ - asmcomp/x86_ast.cmi \ + middle_end/clambda_primitives.cmi \ + middle_end/clambda.cmi \ + middle_end/backend_var.cmi \ + middle_end/backend_intf.cmi \ + parsing/asttypes.cmi \ + middle_end/closure/closure.cmi +middle_end/closure/closure.cmx : \ + utils/warnings.cmx \ + lambda/switch.cmx \ + lambda/simplif.cmx \ + middle_end/semantics_of_primitives.cmx \ + typing/primitive.cmx \ + utils/numbers.cmx \ utils/misc.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + typing/env.cmx \ + lambda/debuginfo.cmx \ + middle_end/convert_primitives.cmx \ utils/config.cmx \ + middle_end/compilenv.cmx \ utils/clflags.cmx \ - utils/ccomp.cmx \ - asmcomp/x86_proc.cmi -asmcomp/x86_proc.cmi : \ - asmcomp/x86_ast.cmi -middle_end/alias_analysis.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - utils/misc.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda.cmi \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmi \ - middle_end/alias_analysis.cmi -middle_end/alias_analysis.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - utils/misc.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda.cmx \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmx \ - middle_end/alias_analysis.cmi -middle_end/alias_analysis.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - bytecomp/lambda.cmi \ - middle_end/flambda.cmi \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmi -middle_end/allocated_const.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/allocated_const.cmi -middle_end/allocated_const.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/allocated_const.cmi -middle_end/allocated_const.cmi : -middle_end/augment_specialised_args.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/projection.cmi \ - middle_end/pass_wrapper.cmi \ - middle_end/parameter.cmi \ + middle_end/clambda_primitives.cmx \ + middle_end/clambda.cmx \ + middle_end/backend_var.cmx \ + middle_end/backend_intf.cmi \ + parsing/asttypes.cmi \ + middle_end/closure/closure.cmi +middle_end/closure/closure.cmi : \ + lambda/lambda.cmi \ + middle_end/clambda.cmi \ + middle_end/backend_intf.cmi +middle_end/flambda/alias_analysis.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + utils/misc.cmi \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda.cmi \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmi \ + middle_end/flambda/alias_analysis.cmi +middle_end/flambda/alias_analysis.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + utils/misc.cmx \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda.cmx \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmx \ + middle_end/flambda/alias_analysis.cmi +middle_end/flambda/alias_analysis.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + lambda/lambda.cmi \ + middle_end/flambda/flambda.cmi \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmi +middle_end/flambda/allocated_const.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/allocated_const.cmi +middle_end/flambda/allocated_const.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/allocated_const.cmi +middle_end/flambda/allocated_const.cmi : +middle_end/flambda/augment_specialised_args.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/pass_wrapper.cmi \ + middle_end/flambda/parameter.cmi \ utils/misc.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ utils/identifiable.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ utils/clflags.cmi \ middle_end/backend_intf.cmi \ - middle_end/augment_specialised_args.cmi -middle_end/augment_specialised_args.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/projection.cmx \ - middle_end/pass_wrapper.cmx \ - middle_end/parameter.cmx \ + middle_end/flambda/augment_specialised_args.cmi +middle_end/flambda/augment_specialised_args.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/projection.cmx \ + middle_end/flambda/pass_wrapper.cmx \ + middle_end/flambda/parameter.cmx \ utils/misc.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/inline_and_simplify_aux.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmx \ utils/identifiable.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/debuginfo.cmx \ - middle_end/base_types/closure_origin.cmx \ - middle_end/base_types/closure_id.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + lambda/debuginfo.cmx \ + middle_end/flambda/base_types/closure_origin.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ middle_end/backend_intf.cmi \ - middle_end/augment_specialised_args.cmi -middle_end/augment_specialised_args.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/projection.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi -middle_end/backend_intf.cmi : \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - typing/ident.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/closure_conversion.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - bytecomp/simplif.cmi \ + middle_end/flambda/augment_specialised_args.cmi +middle_end/flambda/augment_specialised_args.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/build_export_info.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/traverse_for_exported_symbols.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + utils/misc.cmi \ + middle_end/flambda/invariant_params.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/find_recursive_functions.cmi \ + middle_end/flambda/export_info.cmi \ + middle_end/flambda/base_types/export_id.cmi \ + middle_end/compilenv.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + utils/clflags.cmi \ + middle_end/backend_intf.cmi \ + middle_end/flambda/allocated_const.cmi \ + middle_end/flambda/build_export_info.cmi +middle_end/flambda/build_export_info.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/traverse_for_exported_symbols.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + utils/misc.cmx \ + middle_end/flambda/invariant_params.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/find_recursive_functions.cmx \ + middle_end/flambda/export_info.cmx \ + middle_end/flambda/base_types/export_id.cmx \ + middle_end/compilenv.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + utils/clflags.cmx \ + middle_end/backend_intf.cmi \ + middle_end/flambda/allocated_const.cmx \ + middle_end/flambda/build_export_info.cmi +middle_end/flambda/build_export_info.cmi : \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/export_info.cmi \ + middle_end/backend_intf.cmi +middle_end/flambda/closure_conversion.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + lambda/simplif.cmi \ typing/predef.cmi \ - middle_end/parameter.cmi \ + middle_end/flambda/parameter.cmi \ utils/numbers.cmi \ - middle_end/base_types/mutable_variable.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ utils/misc.cmi \ - middle_end/lift_code.cmi \ - bytecomp/lambda.cmi \ + middle_end/flambda/lift_code.cmi \ + lambda/lambda.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ + utils/int_replace_polymorphic_compare.cmi \ typing/ident.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/convert_primitives.cmi \ utils/config.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ - middle_end/closure_conversion_aux.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/closure_conversion_aux.cmi \ utils/clflags.cmi \ + middle_end/clambda_primitives.cmi \ middle_end/backend_intf.cmi \ - middle_end/closure_conversion.cmi -middle_end/closure_conversion.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/static_exception.cmx \ - bytecomp/simplif.cmx \ + middle_end/flambda/closure_conversion.cmi +middle_end/flambda/closure_conversion.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/static_exception.cmx \ + lambda/simplif.cmx \ typing/predef.cmx \ - middle_end/parameter.cmx \ + middle_end/flambda/parameter.cmx \ utils/numbers.cmx \ - middle_end/base_types/mutable_variable.cmx \ + middle_end/flambda/base_types/mutable_variable.cmx \ utils/misc.cmx \ - middle_end/lift_code.cmx \ - bytecomp/lambda.cmx \ + middle_end/flambda/lift_code.cmx \ + lambda/lambda.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ + utils/int_replace_polymorphic_compare.cmx \ typing/ident.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/debuginfo.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + lambda/debuginfo.cmx \ + middle_end/convert_primitives.cmx \ utils/config.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_origin.cmx \ - middle_end/base_types/closure_id.cmx \ - middle_end/closure_conversion_aux.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_origin.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/closure_conversion_aux.cmx \ utils/clflags.cmx \ + middle_end/clambda_primitives.cmx \ middle_end/backend_intf.cmi \ - middle_end/closure_conversion.cmi -middle_end/closure_conversion.cmi : \ - bytecomp/lambda.cmi \ + middle_end/flambda/closure_conversion.cmi +middle_end/flambda/closure_conversion.cmi : \ + lambda/lambda.cmi \ typing/ident.cmi \ - middle_end/flambda.cmi \ + middle_end/flambda/flambda.cmi \ middle_end/backend_intf.cmi -middle_end/closure_conversion_aux.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ +middle_end/flambda/closure_conversion_aux.cmo : \ + middle_end/variable.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ utils/numbers.cmi \ - middle_end/base_types/mutable_variable.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ utils/misc.cmi \ parsing/location.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ typing/ident.cmi \ - middle_end/closure_conversion_aux.cmi -middle_end/closure_conversion_aux.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/static_exception.cmx \ + middle_end/flambda/closure_conversion_aux.cmi +middle_end/flambda/closure_conversion_aux.cmx : \ + middle_end/variable.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/static_exception.cmx \ utils/numbers.cmx \ - middle_end/base_types/mutable_variable.cmx \ + middle_end/flambda/base_types/mutable_variable.cmx \ utils/misc.cmx \ parsing/location.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ typing/ident.cmx \ - middle_end/closure_conversion_aux.cmi -middle_end/closure_conversion_aux.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/base_types/mutable_variable.cmi \ + middle_end/flambda/closure_conversion_aux.cmi +middle_end/flambda/closure_conversion_aux.cmi : \ + middle_end/variable.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ parsing/location.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/ident.cmi -middle_end/debuginfo.cmo : \ - parsing/location.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/debuginfo.cmi -middle_end/debuginfo.cmx : \ - parsing/location.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/debuginfo.cmi -middle_end/debuginfo.cmi : \ - parsing/location.cmi -middle_end/effect_analysis.cmo : \ - bytecomp/semantics_of_primitives.cmi \ - utils/misc.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda.cmi \ - middle_end/effect_analysis.cmi -middle_end/effect_analysis.cmx : \ - bytecomp/semantics_of_primitives.cmx \ - utils/misc.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda.cmx \ - middle_end/effect_analysis.cmi -middle_end/effect_analysis.cmi : \ - middle_end/flambda.cmi -middle_end/extract_projections.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/projection.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/freshening.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi \ - middle_end/extract_projections.cmi -middle_end/extract_projections.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/projection.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inline_and_simplify_aux.cmx \ - middle_end/freshening.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/closure_id.cmx \ - middle_end/extract_projections.cmi -middle_end/extract_projections.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/projection.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi -middle_end/find_recursive_functions.cmo : \ - middle_end/base_types/variable.cmi \ +middle_end/flambda/closure_offsets.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + utils/misc.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/closure_offsets.cmi +middle_end/flambda/closure_offsets.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + utils/misc.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/closure_offsets.cmi +middle_end/flambda/closure_offsets.cmi : \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/effect_analysis.cmo : \ + middle_end/semantics_of_primitives.cmi \ + utils/misc.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/clambda_primitives.cmi \ + middle_end/flambda/effect_analysis.cmi +middle_end/flambda/effect_analysis.cmx : \ + middle_end/semantics_of_primitives.cmx \ + utils/misc.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/clambda_primitives.cmx \ + middle_end/flambda/effect_analysis.cmi +middle_end/flambda/effect_analysis.cmi : \ + middle_end/flambda/flambda.cmi +middle_end/flambda/export_info.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/export_id.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/export_info.cmi +middle_end/flambda/export_info.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/base_types/export_id.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/export_info.cmi +middle_end/flambda/export_info.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/export_id.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/export_info_for_pack.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_origin.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + utils/misc.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/export_info.cmi \ + middle_end/flambda/base_types/export_id.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/export_info_for_pack.cmi +middle_end/flambda/export_info_for_pack.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/base_types/set_of_closures_origin.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + utils/misc.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/export_info.cmx \ + middle_end/flambda/base_types/export_id.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/export_info_for_pack.cmi +middle_end/flambda/export_info_for_pack.cmi : \ + middle_end/flambda/export_info.cmi \ + middle_end/compilation_unit.cmi +middle_end/flambda/extract_projections.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/projection.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/freshening.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/extract_projections.cmi +middle_end/flambda/extract_projections.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/projection.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmx \ + middle_end/flambda/freshening.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/extract_projections.cmi +middle_end/flambda/extract_projections.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/find_recursive_functions.cmo : \ + middle_end/variable.cmi \ utils/strongly_connected_components.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ middle_end/backend_intf.cmi \ - middle_end/find_recursive_functions.cmi -middle_end/find_recursive_functions.cmx : \ - middle_end/base_types/variable.cmx \ + middle_end/flambda/find_recursive_functions.cmi +middle_end/flambda/find_recursive_functions.cmx : \ + middle_end/variable.cmx \ utils/strongly_connected_components.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ middle_end/backend_intf.cmi \ - middle_end/find_recursive_functions.cmi -middle_end/find_recursive_functions.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/flambda.cmi \ + middle_end/flambda/find_recursive_functions.cmi +middle_end/flambda/find_recursive_functions.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/flambda.cmi \ middle_end/backend_intf.cmi -middle_end/flambda.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/base_types/set_of_closures_origin.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/projection.cmi \ - bytecomp/printlambda.cmi \ - middle_end/parameter.cmi \ +middle_end/flambda/flambda.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/base_types/set_of_closures_origin.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/projection.cmi \ + lambda/printlambda.cmi \ + middle_end/printclambda_primitives.cmi \ + middle_end/flambda/parameter.cmi \ utils/numbers.cmi \ - middle_end/base_types/mutable_variable.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ utils/misc.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ + lambda/debuginfo.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ utils/clflags.cmi \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmi \ - middle_end/flambda.cmi -middle_end/flambda.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/static_exception.cmx \ - middle_end/base_types/set_of_closures_origin.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - middle_end/projection.cmx \ - bytecomp/printlambda.cmx \ - middle_end/parameter.cmx \ + middle_end/clambda_primitives.cmi \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/flambda.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/static_exception.cmx \ + middle_end/flambda/base_types/set_of_closures_origin.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + middle_end/flambda/projection.cmx \ + lambda/printlambda.cmx \ + middle_end/printclambda_primitives.cmx \ + middle_end/flambda/parameter.cmx \ utils/numbers.cmx \ - middle_end/base_types/mutable_variable.cmx \ + middle_end/flambda/base_types/mutable_variable.cmx \ utils/misc.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ utils/identifiable.cmx \ - middle_end/debuginfo.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_origin.cmx \ - middle_end/base_types/closure_id.cmx \ + lambda/debuginfo.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_origin.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmx \ - middle_end/flambda.cmi -middle_end/flambda.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/base_types/set_of_closures_origin.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/projection.cmi \ - middle_end/parameter.cmi \ + middle_end/clambda_primitives.cmx \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmx \ + middle_end/flambda/flambda.cmi +middle_end/flambda/flambda.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/base_types/set_of_closures_origin.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/parameter.cmi \ utils/numbers.cmi \ - middle_end/base_types/mutable_variable.cmi \ - bytecomp/lambda.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ + lambda/lambda.cmi \ utils/identifiable.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmi -middle_end/flambda_invariants.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/base_types/set_of_closures_origin.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/projection.cmi \ - bytecomp/printlambda.cmi \ - middle_end/parameter.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/clambda_primitives.cmi \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmi +middle_end/flambda/flambda_invariants.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/base_types/set_of_closures_origin.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/printclambda_primitives.cmi \ + middle_end/flambda/parameter.cmi \ utils/numbers.cmi \ - middle_end/base_types/mutable_variable.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ + utils/misc.cmi \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/clambda_primitives.cmi \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmi \ + middle_end/flambda/flambda_invariants.cmi +middle_end/flambda/flambda_invariants.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/static_exception.cmx \ + middle_end/flambda/base_types/set_of_closures_origin.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + middle_end/flambda/projection.cmx \ + middle_end/printclambda_primitives.cmx \ + middle_end/flambda/parameter.cmx \ + utils/numbers.cmx \ + middle_end/flambda/base_types/mutable_variable.cmx \ + utils/misc.cmx \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + lambda/debuginfo.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/clambda_primitives.cmx \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmx \ + middle_end/flambda/flambda_invariants.cmi +middle_end/flambda/flambda_invariants.cmi : \ + middle_end/flambda/flambda.cmi +middle_end/flambda/flambda_iterators.cmo : \ + middle_end/variable.cmi \ + utils/misc.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/flambda_iterators.cmi +middle_end/flambda/flambda_iterators.cmx : \ + middle_end/variable.cmx \ + utils/misc.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/flambda_iterators.cmi +middle_end/flambda/flambda_iterators.cmi : \ + middle_end/variable.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/flambda_middle_end.cmo : \ + utils/warnings.cmi \ + middle_end/variable.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/share_constants.cmi \ + middle_end/flambda/remove_unused_program_constructs.cmi \ + middle_end/flambda/remove_unused_closure_vars.cmi \ + middle_end/flambda/ref_to_variables.cmi \ + utils/profile.cmi \ utils/misc.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ + parsing/location.cmi \ + middle_end/flambda/lift_let_to_initialize_symbol.cmi \ + middle_end/flambda/lift_constants.cmi \ + middle_end/flambda/lift_code.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify.cmi \ + middle_end/flambda/initialize_symbol_to_let_symbol.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda_invariants.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/closure_conversion.cmi \ + utils/clflags.cmi \ + middle_end/backend_intf.cmi \ + middle_end/flambda/flambda_middle_end.cmi +middle_end/flambda/flambda_middle_end.cmx : \ + utils/warnings.cmx \ + middle_end/variable.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/share_constants.cmx \ + middle_end/flambda/remove_unused_program_constructs.cmx \ + middle_end/flambda/remove_unused_closure_vars.cmx \ + middle_end/flambda/ref_to_variables.cmx \ + utils/profile.cmx \ + utils/misc.cmx \ + parsing/location.cmx \ + middle_end/flambda/lift_let_to_initialize_symbol.cmx \ + middle_end/flambda/lift_constants.cmx \ + middle_end/flambda/lift_code.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/inline_and_simplify.cmx \ + middle_end/flambda/initialize_symbol_to_let_symbol.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda_invariants.cmx \ + middle_end/flambda/flambda.cmx \ + lambda/debuginfo.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/closure_conversion.cmx \ + utils/clflags.cmx \ + middle_end/backend_intf.cmi \ + middle_end/flambda/flambda_middle_end.cmi +middle_end/flambda/flambda_middle_end.cmi : \ + lambda/lambda.cmi \ typing/ident.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmi \ - middle_end/flambda_invariants.cmi -middle_end/flambda_invariants.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/static_exception.cmx \ - middle_end/base_types/set_of_closures_origin.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - middle_end/projection.cmx \ - bytecomp/printlambda.cmx \ - middle_end/parameter.cmx \ + middle_end/flambda/flambda.cmi \ + middle_end/backend_intf.cmi +middle_end/flambda/flambda_to_clambda.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + typing/primitive.cmi \ + middle_end/flambda/parameter.cmi \ + utils/numbers.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ + utils/misc.cmi \ + middle_end/linkage_name.cmi \ + lambda/lambda.cmi \ + middle_end/flambda/initialize_symbol_to_let_symbol.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/export_info.cmi \ + lambda/debuginfo.cmi \ + middle_end/compilenv.cmi \ + middle_end/flambda/closure_offsets.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + utils/clflags.cmi \ + middle_end/clambda.cmi \ + middle_end/backend_var.cmi \ + middle_end/flambda/allocated_const.cmi \ + middle_end/flambda/flambda_to_clambda.cmi +middle_end/flambda/flambda_to_clambda.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/static_exception.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + typing/primitive.cmx \ + middle_end/flambda/parameter.cmx \ utils/numbers.cmx \ - middle_end/base_types/mutable_variable.cmx \ - utils/misc.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - typing/ident.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/debuginfo.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_id.cmx \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmx \ - middle_end/flambda_invariants.cmi -middle_end/flambda_invariants.cmi : \ - middle_end/flambda.cmi -middle_end/flambda_iterators.cmo : \ - middle_end/base_types/variable.cmi \ - utils/misc.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda.cmi \ - middle_end/flambda_iterators.cmi -middle_end/flambda_iterators.cmx : \ - middle_end/base_types/variable.cmx \ - utils/misc.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda.cmx \ - middle_end/flambda_iterators.cmi -middle_end/flambda_iterators.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/flambda.cmi -middle_end/flambda_utils.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/symbol.cmi \ - bytecomp/switch.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/projection.cmi \ - middle_end/parameter.cmi \ + middle_end/flambda/base_types/mutable_variable.cmx \ + utils/misc.cmx \ + middle_end/linkage_name.cmx \ + lambda/lambda.cmx \ + middle_end/flambda/initialize_symbol_to_let_symbol.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/export_info.cmx \ + lambda/debuginfo.cmx \ + middle_end/compilenv.cmx \ + middle_end/flambda/closure_offsets.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + utils/clflags.cmx \ + middle_end/clambda.cmx \ + middle_end/backend_var.cmx \ + middle_end/flambda/allocated_const.cmx \ + middle_end/flambda/flambda_to_clambda.cmi +middle_end/flambda/flambda_to_clambda.cmi : \ + middle_end/symbol.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/export_info.cmi \ + middle_end/clambda.cmi +middle_end/flambda/flambda_utils.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/symbol.cmi \ + lambda/switch.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/parameter.cmi \ utils/numbers.cmi \ - middle_end/base_types/mutable_variable.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ utils/misc.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmi \ - middle_end/flambda_utils.cmi -middle_end/flambda_utils.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/symbol.cmx \ - bytecomp/switch.cmx \ - middle_end/base_types/static_exception.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - middle_end/projection.cmx \ - middle_end/parameter.cmx \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/clambda_primitives.cmi \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmi \ + middle_end/flambda/flambda_utils.cmi +middle_end/flambda/flambda_utils.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/symbol.cmx \ + lambda/switch.cmx \ + middle_end/flambda/base_types/static_exception.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + middle_end/flambda/projection.cmx \ + middle_end/flambda/parameter.cmx \ utils/numbers.cmx \ - middle_end/base_types/mutable_variable.cmx \ + middle_end/flambda/base_types/mutable_variable.cmx \ utils/misc.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/debuginfo.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_origin.cmx \ - middle_end/base_types/closure_id.cmx \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmx \ - middle_end/flambda_utils.cmi -middle_end/flambda_utils.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - bytecomp/switch.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/projection.cmi \ - middle_end/parameter.cmi \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + lambda/debuginfo.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_origin.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/clambda_primitives.cmx \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmx \ + middle_end/flambda/flambda_utils.cmi +middle_end/flambda/flambda_utils.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + lambda/switch.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/parameter.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/freshening.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/projection.cmi \ - middle_end/parameter.cmi \ - middle_end/base_types/mutable_variable.cmi \ - utils/misc.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/freshening.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/parameter.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ + utils/misc.cmi \ + utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi \ - middle_end/freshening.cmi -middle_end/freshening.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/static_exception.cmx \ - middle_end/projection.cmx \ - middle_end/parameter.cmx \ - middle_end/base_types/mutable_variable.cmx \ - utils/misc.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/freshening.cmi +middle_end/flambda/freshening.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/static_exception.cmx \ + middle_end/flambda/projection.cmx \ + middle_end/flambda/parameter.cmx \ + middle_end/flambda/base_types/mutable_variable.cmx \ + utils/misc.cmx \ + utils/int_replace_polymorphic_compare.cmx \ utils/identifiable.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/closure_id.cmx \ - middle_end/freshening.cmi -middle_end/freshening.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/base_types/mutable_variable.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/inconstant_idents.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/parameter.cmi \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/freshening.cmi +middle_end/flambda/freshening.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/import_approx.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + utils/misc.cmi \ + middle_end/flambda/freshening.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/export_info.cmi \ + middle_end/flambda/base_types/export_id.cmi \ + middle_end/compilenv.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/import_approx.cmi +middle_end/flambda/import_approx.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + utils/misc.cmx \ + middle_end/flambda/freshening.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/export_info.cmx \ + middle_end/flambda/base_types/export_id.cmx \ + middle_end/compilenv.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/import_approx.cmi +middle_end/flambda/import_approx.cmi : \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi +middle_end/flambda/inconstant_idents.cmo : \ + middle_end/variable.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/parameter.cmi \ utils/numbers.cmi \ utils/misc.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ + utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ middle_end/backend_intf.cmi \ parsing/asttypes.cmi \ - middle_end/inconstant_idents.cmi -middle_end/inconstant_idents.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - middle_end/parameter.cmx \ + middle_end/flambda/inconstant_idents.cmi +middle_end/flambda/inconstant_idents.cmx : \ + middle_end/variable.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + middle_end/flambda/parameter.cmx \ utils/numbers.cmx \ utils/misc.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ + utils/int_replace_polymorphic_compare.cmx \ utils/identifiable.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_id.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ middle_end/backend_intf.cmi \ parsing/asttypes.cmi \ - middle_end/inconstant_idents.cmi -middle_end/inconstant_idents.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/compilation_unit.cmi \ + middle_end/flambda/inconstant_idents.cmi +middle_end/flambda/inconstant_idents.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/compilation_unit.cmi \ middle_end/backend_intf.cmi -middle_end/initialize_symbol_to_let_symbol.cmo : \ - middle_end/base_types/variable.cmi \ - utils/misc.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda.cmi \ - middle_end/initialize_symbol_to_let_symbol.cmi -middle_end/initialize_symbol_to_let_symbol.cmx : \ - middle_end/base_types/variable.cmx \ - utils/misc.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda.cmx \ - middle_end/initialize_symbol_to_let_symbol.cmi -middle_end/initialize_symbol_to_let_symbol.cmi : \ - middle_end/flambda.cmi -middle_end/inline_and_simplify.cmo : \ +middle_end/flambda/initialize_symbol_to_let_symbol.cmo : \ + middle_end/variable.cmi \ + utils/misc.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/initialize_symbol_to_let_symbol.cmi +middle_end/flambda/initialize_symbol_to_let_symbol.cmx : \ + middle_end/variable.cmx \ + utils/misc.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/initialize_symbol_to_let_symbol.cmi +middle_end/flambda/initialize_symbol_to_let_symbol.cmi : \ + middle_end/flambda/flambda.cmi +middle_end/flambda/inline_and_simplify.cmo : \ utils/warnings.cmi \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/unbox_specialised_args.cmi \ - middle_end/unbox_free_vars_of_closures.cmi \ - middle_end/unbox_closures.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/simplify_primitives.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/remove_unused_arguments.cmi \ - middle_end/remove_free_vars_equal_to_args.cmi \ - middle_end/projection.cmi \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/unbox_specialised_args.cmi \ + middle_end/flambda/unbox_free_vars_of_closures.cmi \ + middle_end/flambda/unbox_closures.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/simplify_primitives.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/remove_unused_arguments.cmi \ + middle_end/flambda/remove_free_vars_equal_to_args.cmi \ + middle_end/flambda/projection.cmi \ typing/predef.cmi \ - middle_end/parameter.cmi \ + middle_end/flambda/parameter.cmi \ utils/misc.cmi \ parsing/location.cmi \ - middle_end/lift_code.cmi \ - bytecomp/lambda.cmi \ - middle_end/invariant_params.cmi \ + middle_end/flambda/lift_code.cmi \ + lambda/lambda.cmi \ + middle_end/flambda/invariant_params.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_stats.cmi \ - middle_end/inlining_decision.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_stats.cmi \ + middle_end/flambda/inlining_decision.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ typing/ident.cmi \ - middle_end/freshening.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/find_recursive_functions.cmi \ - middle_end/effect_analysis.cmi \ - middle_end/debuginfo.cmi \ + middle_end/flambda/freshening.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/find_recursive_functions.cmi \ + middle_end/flambda/effect_analysis.cmi \ + lambda/debuginfo.cmi \ utils/config.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ utils/clflags.cmi \ + middle_end/clambda_primitives.cmi \ middle_end/backend_intf.cmi \ - middle_end/allocated_const.cmi \ - middle_end/inline_and_simplify.cmi -middle_end/inline_and_simplify.cmx : \ + middle_end/flambda/allocated_const.cmi \ + middle_end/flambda/inline_and_simplify.cmi +middle_end/flambda/inline_and_simplify.cmx : \ utils/warnings.cmx \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/unbox_specialised_args.cmx \ - middle_end/unbox_free_vars_of_closures.cmx \ - middle_end/unbox_closures.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/static_exception.cmx \ - middle_end/simplify_primitives.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/remove_unused_arguments.cmx \ - middle_end/remove_free_vars_equal_to_args.cmx \ - middle_end/projection.cmx \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/unbox_specialised_args.cmx \ + middle_end/flambda/unbox_free_vars_of_closures.cmx \ + middle_end/flambda/unbox_closures.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/static_exception.cmx \ + middle_end/flambda/simplify_primitives.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/remove_unused_arguments.cmx \ + middle_end/flambda/remove_free_vars_equal_to_args.cmx \ + middle_end/flambda/projection.cmx \ typing/predef.cmx \ - middle_end/parameter.cmx \ + middle_end/flambda/parameter.cmx \ utils/misc.cmx \ parsing/location.cmx \ - middle_end/lift_code.cmx \ - bytecomp/lambda.cmx \ - middle_end/invariant_params.cmx \ + middle_end/flambda/lift_code.cmx \ + lambda/lambda.cmx \ + middle_end/flambda/invariant_params.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_stats.cmx \ - middle_end/inlining_decision.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/inline_and_simplify_aux.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_stats.cmx \ + middle_end/flambda/inlining_decision.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmx \ typing/ident.cmx \ - middle_end/freshening.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/find_recursive_functions.cmx \ - middle_end/effect_analysis.cmx \ - middle_end/debuginfo.cmx \ + middle_end/flambda/freshening.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/find_recursive_functions.cmx \ + middle_end/flambda/effect_analysis.cmx \ + lambda/debuginfo.cmx \ utils/config.cmx \ - middle_end/base_types/closure_origin.cmx \ - middle_end/base_types/closure_id.cmx \ + middle_end/flambda/base_types/closure_origin.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ + middle_end/clambda_primitives.cmx \ middle_end/backend_intf.cmi \ - middle_end/allocated_const.cmx \ - middle_end/inline_and_simplify.cmi -middle_end/inline_and_simplify.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi \ + middle_end/flambda/allocated_const.cmx \ + middle_end/flambda/inline_and_simplify.cmi +middle_end/flambda/inline_and_simplify.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi \ middle_end/backend_intf.cmi -middle_end/inline_and_simplify_aux.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_origin.cmi \ - middle_end/projection.cmi \ - middle_end/parameter.cmi \ - middle_end/base_types/mutable_variable.cmi \ - utils/misc.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_stats.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/freshening.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ +middle_end/flambda/inline_and_simplify_aux.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_origin.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/parameter.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ + utils/misc.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_stats.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/freshening.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ utils/clflags.cmi \ middle_end/backend_intf.cmi \ - middle_end/inline_and_simplify_aux.cmi -middle_end/inline_and_simplify_aux.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/static_exception.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/base_types/set_of_closures_origin.cmx \ - middle_end/projection.cmx \ - middle_end/parameter.cmx \ - middle_end/base_types/mutable_variable.cmx \ - utils/misc.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_stats.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/freshening.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/debuginfo.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_origin.cmx \ - middle_end/base_types/closure_id.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmi +middle_end/flambda/inline_and_simplify_aux.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/static_exception.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/base_types/set_of_closures_origin.cmx \ + middle_end/flambda/projection.cmx \ + middle_end/flambda/parameter.cmx \ + middle_end/flambda/base_types/mutable_variable.cmx \ + utils/misc.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_stats.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/freshening.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + lambda/debuginfo.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_origin.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ middle_end/backend_intf.cmi \ - middle_end/inline_and_simplify_aux.cmi -middle_end/inline_and_simplify_aux.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_origin.cmi \ - middle_end/projection.cmi \ - middle_end/base_types/mutable_variable.cmi \ - middle_end/inlining_stats_types.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/freshening.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi +middle_end/flambda/inline_and_simplify_aux.cmi : \ + middle_end/variable.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_origin.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ + middle_end/flambda/inlining_stats_types.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/freshening.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ middle_end/backend_intf.cmi -middle_end/inlining_cost.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/projection.cmi \ +middle_end/flambda/inlining_cost.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/projection.cmi \ typing/primitive.cmi \ utils/misc.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ utils/clflags.cmi \ - middle_end/inlining_cost.cmi -middle_end/inlining_cost.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/projection.cmx \ + middle_end/clambda_primitives.cmi \ + middle_end/flambda/inlining_cost.cmi +middle_end/flambda/inlining_cost.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/projection.cmx \ typing/primitive.cmx \ utils/misc.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ utils/clflags.cmx \ - middle_end/inlining_cost.cmi -middle_end/inlining_cost.cmi : \ - middle_end/projection.cmi \ - middle_end/flambda.cmi -middle_end/inlining_decision.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/parameter.cmi \ - utils/misc.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_transforms.cmi \ - middle_end/inlining_stats_types.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi \ + middle_end/clambda_primitives.cmx \ + middle_end/flambda/inlining_cost.cmi +middle_end/flambda/inlining_cost.cmi : \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/inlining_decision.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/parameter.cmi \ + utils/misc.cmi \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_transforms.cmi \ + middle_end/flambda/inlining_stats_types.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ utils/clflags.cmi \ - middle_end/inlining_decision.cmi -middle_end/inlining_decision.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/parameter.cmx \ - utils/misc.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_transforms.cmx \ - middle_end/inlining_stats_types.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/inline_and_simplify_aux.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/closure_id.cmx \ + middle_end/flambda/inlining_decision.cmi +middle_end/flambda/inlining_decision.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/parameter.cmx \ + utils/misc.cmx \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_transforms.cmx \ + middle_end/flambda/inlining_stats_types.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ - middle_end/inlining_decision.cmi -middle_end/inlining_decision.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/simple_value_approx.cmi \ - bytecomp/lambda.cmi \ - middle_end/inlining_decision_intf.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/inlining_decision_intf.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/inlining_stats.cmo : \ - utils/misc.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_stats_types.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_id.cmi \ + middle_end/flambda/inlining_decision.cmi +middle_end/flambda/inlining_decision.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + lambda/lambda.cmi \ + middle_end/flambda/inlining_decision_intf.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/inlining_decision_intf.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/inlining_stats.cmo : \ + utils/misc.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_stats_types.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ utils/clflags.cmi \ - middle_end/inlining_stats.cmi -middle_end/inlining_stats.cmx : \ + middle_end/flambda/inlining_stats.cmi +middle_end/flambda/inlining_stats.cmx : \ utils/misc.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_stats_types.cmx \ - middle_end/debuginfo.cmx \ - middle_end/base_types/closure_id.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_stats_types.cmx \ + lambda/debuginfo.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ - middle_end/inlining_stats.cmi -middle_end/inlining_stats.cmi : \ - middle_end/inlining_stats_types.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/inlining_stats_types.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inlining_stats_types.cmi -middle_end/inlining_stats_types.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/inlining_stats_types.cmi -middle_end/inlining_stats_types.cmi : \ - middle_end/inlining_cost.cmi -middle_end/inlining_transforms.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/projection.cmi \ - middle_end/parameter.cmi \ - bytecomp/lambda.cmi \ + middle_end/flambda/inlining_stats.cmi +middle_end/flambda/inlining_stats.cmi : \ + middle_end/flambda/inlining_stats_types.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/inlining_stats_types.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inlining_stats_types.cmi +middle_end/flambda/inlining_stats_types.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/inlining_stats_types.cmi +middle_end/flambda/inlining_stats_types.cmi : \ + middle_end/flambda/inlining_cost.cmi +middle_end/flambda/inlining_transforms.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/parameter.cmi \ + lambda/lambda.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_decision_intf.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ - middle_end/inlining_transforms.cmi -middle_end/inlining_transforms.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/projection.cmx \ - middle_end/parameter.cmx \ - bytecomp/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_decision_intf.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/inlining_transforms.cmi +middle_end/flambda/inlining_transforms.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/projection.cmx \ + middle_end/flambda/parameter.cmx \ + lambda/lambda.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_decision_intf.cmi \ - middle_end/inlining_cost.cmx \ - middle_end/inline_and_simplify_aux.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/debuginfo.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_origin.cmx \ - middle_end/base_types/closure_id.cmx \ - middle_end/inlining_transforms.cmi -middle_end/inlining_transforms.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/simple_value_approx.cmi \ - bytecomp/lambda.cmi \ - middle_end/inlining_decision_intf.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/int_replace_polymorphic_compare.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi -middle_end/int_replace_polymorphic_compare.cmx : \ - middle_end/int_replace_polymorphic_compare.cmi -middle_end/int_replace_polymorphic_compare.cmi : -middle_end/internal_variable_names.cmo : \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/internal_variable_names.cmi -middle_end/internal_variable_names.cmx : \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/internal_variable_names.cmi -middle_end/internal_variable_names.cmi : \ - parsing/location.cmi \ - bytecomp/lambda.cmi -middle_end/invariant_params.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/parameter.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_decision_intf.cmi \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + lambda/debuginfo.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_origin.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/inlining_transforms.cmi +middle_end/flambda/inlining_transforms.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + lambda/lambda.cmi \ + middle_end/flambda/inlining_decision_intf.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/invariant_params.cmo : \ + middle_end/variable.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/parameter.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ utils/clflags.cmi \ middle_end/backend_intf.cmi \ - middle_end/invariant_params.cmi -middle_end/invariant_params.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/parameter.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/closure_id.cmx \ + middle_end/flambda/invariant_params.cmi +middle_end/flambda/invariant_params.cmx : \ + middle_end/variable.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/parameter.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ middle_end/backend_intf.cmi \ - middle_end/invariant_params.cmi -middle_end/invariant_params.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/flambda.cmi \ + middle_end/flambda/invariant_params.cmi +middle_end/flambda/invariant_params.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/flambda.cmi \ middle_end/backend_intf.cmi -middle_end/lift_code.cmo : \ - middle_end/base_types/variable.cmi \ +middle_end/flambda/lift_code.cmo : \ + middle_end/variable.cmi \ utils/strongly_connected_components.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/lift_code.cmi -middle_end/lift_code.cmx : \ - middle_end/base_types/variable.cmx \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/lift_code.cmi +middle_end/flambda/lift_code.cmx : \ + middle_end/variable.cmx \ utils/strongly_connected_components.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/lift_code.cmi -middle_end/lift_code.cmi : \ - middle_end/base_types/variable.cmi \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/lift_code.cmi +middle_end/flambda/lift_code.cmi : \ + middle_end/variable.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/flambda.cmi -middle_end/lift_constants.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/lift_constants.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ utils/strongly_connected_components.cmi \ - middle_end/simple_value_approx.cmi \ + middle_end/flambda/simple_value_approx.cmi \ utils/misc.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inconstant_idents.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inconstant_idents.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ middle_end/backend_intf.cmi \ parsing/asttypes.cmi \ - middle_end/allocated_const.cmi \ - middle_end/alias_analysis.cmi \ - middle_end/lift_constants.cmi -middle_end/lift_constants.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ + middle_end/flambda/allocated_const.cmi \ + middle_end/flambda/alias_analysis.cmi \ + middle_end/flambda/lift_constants.cmi +middle_end/flambda/lift_constants.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ utils/strongly_connected_components.cmx \ - middle_end/simple_value_approx.cmx \ + middle_end/flambda/simple_value_approx.cmx \ utils/misc.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inconstant_idents.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_id.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inconstant_idents.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ middle_end/backend_intf.cmi \ parsing/asttypes.cmi \ - middle_end/allocated_const.cmx \ - middle_end/alias_analysis.cmx \ - middle_end/lift_constants.cmi -middle_end/lift_constants.cmi : \ - middle_end/flambda.cmi \ + middle_end/flambda/allocated_const.cmx \ + middle_end/flambda/alias_analysis.cmx \ + middle_end/flambda/lift_constants.cmi +middle_end/flambda/lift_constants.cmi : \ + middle_end/flambda/flambda.cmi \ middle_end/backend_intf.cmi -middle_end/lift_let_to_initialize_symbol.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ +middle_end/flambda/lift_let_to_initialize_symbol.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - parsing/asttypes.cmi \ - middle_end/lift_let_to_initialize_symbol.cmi -middle_end/lift_let_to_initialize_symbol.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + parsing/asttypes.cmi \ + middle_end/flambda/lift_let_to_initialize_symbol.cmi +middle_end/flambda/lift_let_to_initialize_symbol.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/debuginfo.cmx \ - parsing/asttypes.cmi \ - middle_end/lift_let_to_initialize_symbol.cmi -middle_end/lift_let_to_initialize_symbol.cmi : \ - middle_end/flambda.cmi \ - middle_end/backend_intf.cmi -middle_end/middle_end.cmo : \ - utils/warnings.cmi \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/share_constants.cmi \ - middle_end/remove_unused_program_constructs.cmi \ - middle_end/remove_unused_closure_vars.cmi \ - middle_end/ref_to_variables.cmi \ - utils/profile.cmi \ - utils/misc.cmi \ - parsing/location.cmi \ - middle_end/lift_let_to_initialize_symbol.cmi \ - middle_end/lift_constants.cmi \ - middle_end/lift_code.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify.cmi \ - middle_end/initialize_symbol_to_let_symbol.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda_invariants.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_id.cmi \ - middle_end/closure_conversion.cmi \ - utils/clflags.cmi \ - middle_end/backend_intf.cmi \ - middle_end/middle_end.cmi -middle_end/middle_end.cmx : \ - utils/warnings.cmx \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/share_constants.cmx \ - middle_end/remove_unused_program_constructs.cmx \ - middle_end/remove_unused_closure_vars.cmx \ - middle_end/ref_to_variables.cmx \ - utils/profile.cmx \ - utils/misc.cmx \ - parsing/location.cmx \ - middle_end/lift_let_to_initialize_symbol.cmx \ - middle_end/lift_constants.cmx \ - middle_end/lift_code.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/inline_and_simplify.cmx \ - middle_end/initialize_symbol_to_let_symbol.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda_invariants.cmx \ - middle_end/flambda.cmx \ - middle_end/debuginfo.cmx \ - middle_end/base_types/closure_id.cmx \ - middle_end/closure_conversion.cmx \ - utils/clflags.cmx \ - middle_end/backend_intf.cmi \ - middle_end/middle_end.cmi -middle_end/middle_end.cmi : \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - middle_end/flambda.cmi \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + lambda/debuginfo.cmx \ + parsing/asttypes.cmi \ + middle_end/flambda/lift_let_to_initialize_symbol.cmi +middle_end/flambda/lift_let_to_initialize_symbol.cmi : \ + middle_end/flambda/flambda.cmi \ middle_end/backend_intf.cmi -middle_end/parameter.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ +middle_end/flambda/parameter.cmo : \ + middle_end/variable.cmi \ + utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ - middle_end/parameter.cmi -middle_end/parameter.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/parameter.cmi +middle_end/flambda/parameter.cmx : \ + middle_end/variable.cmx \ + utils/int_replace_polymorphic_compare.cmx \ utils/identifiable.cmx \ - middle_end/parameter.cmi -middle_end/parameter.cmi : \ - middle_end/base_types/variable.cmi \ + middle_end/flambda/parameter.cmi +middle_end/flambda/parameter.cmi : \ + middle_end/variable.cmi \ utils/identifiable.cmi \ - middle_end/base_types/compilation_unit.cmi -middle_end/pass_wrapper.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ + middle_end/compilation_unit.cmi +middle_end/flambda/pass_wrapper.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ utils/clflags.cmi \ - middle_end/pass_wrapper.cmi -middle_end/pass_wrapper.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/pass_wrapper.cmi +middle_end/flambda/pass_wrapper.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ utils/clflags.cmx \ - middle_end/pass_wrapper.cmi -middle_end/pass_wrapper.cmi : -middle_end/projection.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/pass_wrapper.cmi +middle_end/flambda/pass_wrapper.cmi : +middle_end/flambda/projection.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ - middle_end/base_types/closure_id.cmi \ - middle_end/projection.cmi -middle_end/projection.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/projection.cmi +middle_end/flambda/projection.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + utils/int_replace_polymorphic_compare.cmx \ utils/identifiable.cmx \ - middle_end/base_types/closure_id.cmx \ - middle_end/projection.cmi -middle_end/projection.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/projection.cmi +middle_end/flambda/projection.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ utils/identifiable.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/ref_to_variables.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/mutable_variable.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/ref_to_variables.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ utils/misc.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ parsing/asttypes.cmi \ - middle_end/ref_to_variables.cmi -middle_end/ref_to_variables.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/mutable_variable.cmx \ + middle_end/flambda/ref_to_variables.cmi +middle_end/flambda/ref_to_variables.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/mutable_variable.cmx \ utils/misc.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - parsing/asttypes.cmi \ - middle_end/ref_to_variables.cmi -middle_end/ref_to_variables.cmi : \ - middle_end/flambda.cmi -middle_end/remove_free_vars_equal_to_args.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/pass_wrapper.cmi \ - middle_end/parameter.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/remove_free_vars_equal_to_args.cmi -middle_end/remove_free_vars_equal_to_args.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/pass_wrapper.cmx \ - middle_end/parameter.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/remove_free_vars_equal_to_args.cmi -middle_end/remove_free_vars_equal_to_args.cmi : \ - middle_end/flambda.cmi -middle_end/remove_unused_arguments.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/projection.cmi \ - middle_end/parameter.cmi \ - middle_end/invariant_params.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/find_recursive_functions.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + parsing/asttypes.cmi \ + middle_end/flambda/ref_to_variables.cmi +middle_end/flambda/ref_to_variables.cmi : \ + middle_end/flambda/flambda.cmi +middle_end/flambda/remove_free_vars_equal_to_args.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/pass_wrapper.cmi \ + middle_end/flambda/parameter.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/remove_free_vars_equal_to_args.cmi +middle_end/flambda/remove_free_vars_equal_to_args.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/pass_wrapper.cmx \ + middle_end/flambda/parameter.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/remove_free_vars_equal_to_args.cmi +middle_end/flambda/remove_free_vars_equal_to_args.cmi : \ + middle_end/flambda/flambda.cmi +middle_end/flambda/remove_unused_arguments.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/parameter.cmi \ + middle_end/flambda/invariant_params.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/find_recursive_functions.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ utils/clflags.cmi \ - middle_end/remove_unused_arguments.cmi -middle_end/remove_unused_arguments.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/projection.cmx \ - middle_end/parameter.cmx \ - middle_end/invariant_params.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/find_recursive_functions.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_origin.cmx \ - middle_end/base_types/closure_id.cmx \ + middle_end/flambda/remove_unused_arguments.cmi +middle_end/flambda/remove_unused_arguments.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/projection.cmx \ + middle_end/flambda/parameter.cmx \ + middle_end/flambda/invariant_params.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/find_recursive_functions.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_origin.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ - middle_end/remove_unused_arguments.cmi -middle_end/remove_unused_arguments.cmi : \ - middle_end/flambda.cmi \ + middle_end/flambda/remove_unused_arguments.cmi +middle_end/flambda/remove_unused_arguments.cmi : \ + middle_end/flambda/flambda.cmi \ middle_end/backend_intf.cmi -middle_end/remove_unused_closure_vars.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/parameter.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi \ - middle_end/remove_unused_closure_vars.cmi -middle_end/remove_unused_closure_vars.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/parameter.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/closure_id.cmx \ - middle_end/remove_unused_closure_vars.cmi -middle_end/remove_unused_closure_vars.cmi : \ - middle_end/flambda.cmi -middle_end/remove_unused_program_constructs.cmo : \ - middle_end/base_types/symbol.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda.cmi \ - middle_end/effect_analysis.cmi \ - middle_end/remove_unused_program_constructs.cmi -middle_end/remove_unused_program_constructs.cmx : \ - middle_end/base_types/symbol.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda.cmx \ - middle_end/effect_analysis.cmx \ - middle_end/remove_unused_program_constructs.cmi -middle_end/remove_unused_program_constructs.cmi : \ - middle_end/flambda.cmi -middle_end/share_constants.cmo : \ - middle_end/base_types/symbol.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/share_constants.cmi -middle_end/share_constants.cmx : \ - middle_end/base_types/symbol.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/share_constants.cmi -middle_end/share_constants.cmi : \ - middle_end/flambda.cmi -middle_end/simple_value_approx.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/set_of_closures_origin.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/parameter.cmi \ - utils/misc.cmi \ - bytecomp/lambda.cmi \ +middle_end/flambda/remove_unused_closure_vars.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/parameter.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/remove_unused_closure_vars.cmi +middle_end/flambda/remove_unused_closure_vars.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/parameter.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/remove_unused_closure_vars.cmi +middle_end/flambda/remove_unused_closure_vars.cmi : \ + middle_end/flambda/flambda.cmi +middle_end/flambda/remove_unused_program_constructs.cmo : \ + middle_end/symbol.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/effect_analysis.cmi \ + middle_end/flambda/remove_unused_program_constructs.cmi +middle_end/flambda/remove_unused_program_constructs.cmx : \ + middle_end/symbol.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/effect_analysis.cmx \ + middle_end/flambda/remove_unused_program_constructs.cmi +middle_end/flambda/remove_unused_program_constructs.cmi : \ + middle_end/flambda/flambda.cmi +middle_end/flambda/share_constants.cmo : \ + middle_end/symbol.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/share_constants.cmi +middle_end/flambda/share_constants.cmx : \ + middle_end/symbol.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/share_constants.cmi +middle_end/flambda/share_constants.cmi : \ + middle_end/flambda/flambda.cmi +middle_end/flambda/simple_value_approx.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/set_of_closures_origin.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/parameter.cmi \ + utils/misc.cmi \ + lambda/lambda.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/freshening.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/export_id.cmi \ - middle_end/effect_analysis.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ - middle_end/allocated_const.cmi \ - middle_end/simple_value_approx.cmi -middle_end/simple_value_approx.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/set_of_closures_origin.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - middle_end/parameter.cmx \ - utils/misc.cmx \ - bytecomp/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/freshening.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/export_id.cmi \ + middle_end/flambda/effect_analysis.cmi \ + lambda/debuginfo.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/allocated_const.cmi \ + middle_end/flambda/simple_value_approx.cmi +middle_end/flambda/simple_value_approx.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/set_of_closures_origin.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + middle_end/flambda/parameter.cmx \ + utils/misc.cmx \ + lambda/lambda.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/freshening.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/export_id.cmx \ - middle_end/effect_analysis.cmx \ - middle_end/debuginfo.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_origin.cmx \ - middle_end/base_types/closure_id.cmx \ - middle_end/allocated_const.cmx \ - middle_end/simple_value_approx.cmi -middle_end/simple_value_approx.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/set_of_closures_origin.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/parameter.cmi \ - bytecomp/lambda.cmi \ - middle_end/freshening.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/export_id.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/simplify_boxed_integer_ops.cmo : \ - middle_end/simplify_common.cmi \ - middle_end/simplify_boxed_integer_ops_intf.cmi \ - middle_end/simple_value_approx.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/simplify_boxed_integer_ops.cmi -middle_end/simplify_boxed_integer_ops.cmx : \ - middle_end/simplify_common.cmx \ - middle_end/simplify_boxed_integer_ops_intf.cmi \ - middle_end/simple_value_approx.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/simplify_boxed_integer_ops.cmi -middle_end/simplify_boxed_integer_ops.cmi : \ - middle_end/simplify_boxed_integer_ops_intf.cmi -middle_end/simplify_boxed_integer_ops_intf.cmi : \ - middle_end/simple_value_approx.cmi \ - bytecomp/lambda.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/flambda.cmi -middle_end/simplify_common.cmo : \ - middle_end/simple_value_approx.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/effect_analysis.cmi \ - middle_end/simplify_common.cmi -middle_end/simplify_common.cmx : \ - middle_end/simple_value_approx.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/effect_analysis.cmx \ - middle_end/simplify_common.cmi -middle_end/simplify_common.cmi : \ - middle_end/simple_value_approx.cmi \ - bytecomp/lambda.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/flambda.cmi -middle_end/simplify_primitives.cmo : \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/simplify_common.cmi \ - middle_end/simplify_boxed_integer_ops.cmi \ - middle_end/simple_value_approx.cmi \ - bytecomp/semantics_of_primitives.cmi \ - utils/misc.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/flambda.cmi \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/freshening.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/base_types/export_id.cmx \ + middle_end/flambda/effect_analysis.cmx \ + lambda/debuginfo.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_origin.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/allocated_const.cmx \ + middle_end/flambda/simple_value_approx.cmi +middle_end/flambda/simple_value_approx.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/set_of_closures_origin.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/parameter.cmi \ + lambda/lambda.cmi \ + middle_end/flambda/freshening.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/export_id.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/simplify_boxed_integer_ops.cmo : \ + middle_end/flambda/simplify_common.cmi \ + middle_end/flambda/simplify_boxed_integer_ops_intf.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/clambda_primitives.cmi \ + middle_end/flambda/simplify_boxed_integer_ops.cmi +middle_end/flambda/simplify_boxed_integer_ops.cmx : \ + middle_end/flambda/simplify_common.cmx \ + middle_end/flambda/simplify_boxed_integer_ops_intf.cmi \ + middle_end/flambda/simple_value_approx.cmx \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/clambda_primitives.cmx \ + middle_end/flambda/simplify_boxed_integer_ops.cmi +middle_end/flambda/simplify_boxed_integer_ops.cmi : \ + middle_end/flambda/simplify_boxed_integer_ops_intf.cmi +middle_end/flambda/simplify_boxed_integer_ops_intf.cmi : \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/clambda_primitives.cmi +middle_end/flambda/simplify_common.cmo : \ + middle_end/flambda/simple_value_approx.cmi \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/effect_analysis.cmi \ + middle_end/flambda/simplify_common.cmi +middle_end/flambda/simplify_common.cmx : \ + middle_end/flambda/simple_value_approx.cmx \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/effect_analysis.cmx \ + middle_end/flambda/simplify_common.cmi +middle_end/flambda/simplify_common.cmi : \ + middle_end/flambda/simple_value_approx.cmi \ + lambda/lambda.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/simplify_primitives.cmo : \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/simplify_common.cmi \ + middle_end/flambda/simplify_boxed_integer_ops.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/semantics_of_primitives.cmi \ + utils/misc.cmi \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/flambda.cmi \ utils/clflags.cmi \ - parsing/asttypes.cmi \ - middle_end/simplify_primitives.cmi -middle_end/simplify_primitives.cmx : \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/simplify_common.cmx \ - middle_end/simplify_boxed_integer_ops.cmx \ - middle_end/simple_value_approx.cmx \ - bytecomp/semantics_of_primitives.cmx \ - utils/misc.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/flambda.cmx \ + middle_end/clambda_primitives.cmi \ + parsing/asttypes.cmi \ + middle_end/flambda/simplify_primitives.cmi +middle_end/flambda/simplify_primitives.cmx : \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/simplify_common.cmx \ + middle_end/flambda/simplify_boxed_integer_ops.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/semantics_of_primitives.cmx \ + utils/misc.cmx \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/flambda.cmx \ utils/clflags.cmx \ + middle_end/clambda_primitives.cmx \ + parsing/asttypes.cmi \ + middle_end/flambda/simplify_primitives.cmi +middle_end/flambda/simplify_primitives.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/clambda_primitives.cmi +middle_end/flambda/traverse_for_exported_symbols.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + utils/misc.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/export_info.cmi \ + middle_end/flambda/base_types/export_id.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/traverse_for_exported_symbols.cmi +middle_end/flambda/traverse_for_exported_symbols.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + utils/misc.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/export_info.cmx \ + middle_end/flambda/base_types/export_id.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/traverse_for_exported_symbols.cmi +middle_end/flambda/traverse_for_exported_symbols.cmi : \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/export_info.cmi \ + middle_end/flambda/base_types/export_id.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/un_anf.cmo : \ + middle_end/semantics_of_primitives.cmi \ + middle_end/printclambda.cmi \ + utils/misc.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ + utils/clflags.cmi \ + middle_end/clambda_primitives.cmi \ + middle_end/clambda.cmi \ + middle_end/backend_var.cmi \ parsing/asttypes.cmi \ - middle_end/simplify_primitives.cmi -middle_end/simplify_primitives.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/simple_value_approx.cmi \ - bytecomp/lambda.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi -middle_end/unbox_closures.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi \ + middle_end/flambda/un_anf.cmi +middle_end/flambda/un_anf.cmx : \ + middle_end/semantics_of_primitives.cmx \ + middle_end/printclambda.cmx \ + utils/misc.cmx \ + lambda/lambda.cmx \ + lambda/debuginfo.cmx \ + utils/clflags.cmx \ + middle_end/clambda_primitives.cmx \ + middle_end/clambda.cmx \ + middle_end/backend_var.cmx \ + parsing/asttypes.cmi \ + middle_end/flambda/un_anf.cmi +middle_end/flambda/un_anf.cmi : \ + middle_end/clambda.cmi +middle_end/flambda/unbox_closures.cmo : \ + middle_end/variable.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ utils/clflags.cmi \ - middle_end/augment_specialised_args.cmi \ - middle_end/unbox_closures.cmi -middle_end/unbox_closures.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/inline_and_simplify_aux.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/closure_id.cmx \ + middle_end/flambda/augment_specialised_args.cmi \ + middle_end/flambda/unbox_closures.cmi +middle_end/flambda/unbox_closures.cmx : \ + middle_end/variable.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ - middle_end/augment_specialised_args.cmx \ - middle_end/unbox_closures.cmi -middle_end/unbox_closures.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi -middle_end/unbox_free_vars_of_closures.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/projection.cmi \ - middle_end/pass_wrapper.cmi \ + middle_end/flambda/augment_specialised_args.cmx \ + middle_end/flambda/unbox_closures.cmi +middle_end/flambda/unbox_closures.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/unbox_free_vars_of_closures.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/pass_wrapper.cmi \ utils/misc.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/extract_projections.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/extract_projections.cmi \ utils/clflags.cmi \ - middle_end/unbox_free_vars_of_closures.cmi -middle_end/unbox_free_vars_of_closures.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/projection.cmx \ - middle_end/pass_wrapper.cmx \ + middle_end/flambda/unbox_free_vars_of_closures.cmi +middle_end/flambda/unbox_free_vars_of_closures.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/projection.cmx \ + middle_end/flambda/pass_wrapper.cmx \ utils/misc.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/inline_and_simplify_aux.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/extract_projections.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/extract_projections.cmx \ utils/clflags.cmx \ - middle_end/unbox_free_vars_of_closures.cmi -middle_end/unbox_free_vars_of_closures.cmi : \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi -middle_end/unbox_specialised_args.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/projection.cmi \ - middle_end/invariant_params.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi \ - middle_end/extract_projections.cmi \ + middle_end/flambda/unbox_free_vars_of_closures.cmi +middle_end/flambda/unbox_free_vars_of_closures.cmi : \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/unbox_specialised_args.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/invariant_params.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/extract_projections.cmi \ utils/clflags.cmi \ - middle_end/augment_specialised_args.cmi \ - middle_end/unbox_specialised_args.cmi -middle_end/unbox_specialised_args.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/projection.cmx \ - middle_end/invariant_params.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inline_and_simplify_aux.cmx \ - middle_end/flambda.cmx \ - middle_end/extract_projections.cmx \ + middle_end/flambda/augment_specialised_args.cmi \ + middle_end/flambda/unbox_specialised_args.cmi +middle_end/flambda/unbox_specialised_args.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/projection.cmx \ + middle_end/flambda/invariant_params.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/extract_projections.cmx \ utils/clflags.cmx \ - middle_end/augment_specialised_args.cmx \ - middle_end/unbox_specialised_args.cmi -middle_end/unbox_specialised_args.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi -middle_end/base_types/closure_element.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/base_types/closure_element.cmi -middle_end/base_types/closure_element.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/base_types/closure_element.cmi -middle_end/base_types/closure_element.cmi : \ - middle_end/base_types/variable.cmi \ - utils/identifiable.cmi \ - middle_end/base_types/compilation_unit.cmi -middle_end/base_types/closure_id.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/base_types/closure_element.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/base_types/closure_id.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/base_types/closure_element.cmx \ - middle_end/base_types/closure_id.cmi -middle_end/base_types/closure_id.cmi : \ - middle_end/base_types/closure_element.cmi -middle_end/base_types/closure_origin.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/base_types/closure_id.cmi \ - middle_end/base_types/closure_origin.cmi -middle_end/base_types/closure_origin.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/base_types/closure_id.cmx \ - middle_end/base_types/closure_origin.cmi -middle_end/base_types/closure_origin.cmi : \ + middle_end/flambda/augment_specialised_args.cmx \ + middle_end/flambda/unbox_specialised_args.cmi +middle_end/flambda/unbox_specialised_args.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/base_types/closure_element.cmo : \ + middle_end/variable.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/base_types/closure_element.cmi +middle_end/flambda/base_types/closure_element.cmx : \ + middle_end/variable.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/closure_element.cmi +middle_end/flambda/base_types/closure_element.cmi : \ + middle_end/variable.cmi \ utils/identifiable.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/base_types/compilation_unit.cmo : \ - utils/misc.cmi \ - middle_end/base_types/linkage_name.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - utils/identifiable.cmi \ - typing/ident.cmi \ - middle_end/base_types/compilation_unit.cmi -middle_end/base_types/compilation_unit.cmx : \ - utils/misc.cmx \ - middle_end/base_types/linkage_name.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - utils/identifiable.cmx \ - typing/ident.cmx \ - middle_end/base_types/compilation_unit.cmi -middle_end/base_types/compilation_unit.cmi : \ - middle_end/base_types/linkage_name.cmi \ + middle_end/compilation_unit.cmi +middle_end/flambda/base_types/closure_id.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/base_types/closure_element.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/base_types/closure_id.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/closure_element.cmx \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/base_types/closure_id.cmi : \ + middle_end/flambda/base_types/closure_element.cmi +middle_end/flambda/base_types/closure_origin.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/base_types/closure_origin.cmi +middle_end/flambda/base_types/closure_origin.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/base_types/closure_origin.cmi +middle_end/flambda/base_types/closure_origin.cmi : \ utils/identifiable.cmi \ - typing/ident.cmi -middle_end/base_types/export_id.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/base_types/export_id.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ - middle_end/base_types/id_types.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/export_id.cmi -middle_end/base_types/export_id.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/id_types.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/export_id.cmi +middle_end/flambda/base_types/export_id.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ utils/identifiable.cmx \ - middle_end/base_types/id_types.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/export_id.cmi -middle_end/base_types/export_id.cmi : \ - utils/identifiable.cmi \ - middle_end/base_types/compilation_unit.cmi -middle_end/base_types/id_types.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/base_types/id_types.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/export_id.cmi +middle_end/flambda/base_types/export_id.cmi : \ utils/identifiable.cmi \ - middle_end/base_types/id_types.cmi -middle_end/base_types/id_types.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ - utils/identifiable.cmx \ - middle_end/base_types/id_types.cmi -middle_end/base_types/id_types.cmi : \ - utils/identifiable.cmi -middle_end/base_types/linkage_name.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ + middle_end/compilation_unit.cmi +middle_end/flambda/base_types/id_types.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ - middle_end/base_types/linkage_name.cmi -middle_end/base_types/linkage_name.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/id_types.cmi +middle_end/flambda/base_types/id_types.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ utils/identifiable.cmx \ - middle_end/base_types/linkage_name.cmi -middle_end/base_types/linkage_name.cmi : \ + middle_end/flambda/base_types/id_types.cmi +middle_end/flambda/base_types/id_types.cmi : \ utils/identifiable.cmi -middle_end/base_types/mutable_variable.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/base_types/mutable_variable.cmi -middle_end/base_types/mutable_variable.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/base_types/mutable_variable.cmi -middle_end/base_types/mutable_variable.cmi : \ - middle_end/base_types/variable.cmi \ +middle_end/flambda/base_types/mutable_variable.cmo : \ + middle_end/variable.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi +middle_end/flambda/base_types/mutable_variable.cmx : \ + middle_end/variable.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/mutable_variable.cmi +middle_end/flambda/base_types/mutable_variable.cmi : \ + middle_end/variable.cmi \ middle_end/internal_variable_names.cmi \ utils/identifiable.cmi \ typing/ident.cmi \ - middle_end/base_types/compilation_unit.cmi -middle_end/base_types/set_of_closures_id.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ + middle_end/compilation_unit.cmi +middle_end/flambda/base_types/set_of_closures_id.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ - middle_end/base_types/id_types.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/set_of_closures_id.cmi -middle_end/base_types/set_of_closures_id.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/id_types.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi +middle_end/flambda/base_types/set_of_closures_id.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ utils/identifiable.cmx \ - middle_end/base_types/id_types.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/set_of_closures_id.cmi -middle_end/base_types/set_of_closures_id.cmi : \ + middle_end/flambda/base_types/id_types.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmi +middle_end/flambda/base_types/set_of_closures_id.cmi : \ utils/identifiable.cmi \ - middle_end/base_types/compilation_unit.cmi -middle_end/base_types/set_of_closures_origin.cmo : \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/base_types/set_of_closures_origin.cmi -middle_end/base_types/set_of_closures_origin.cmx : \ - middle_end/base_types/set_of_closures_id.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/base_types/set_of_closures_origin.cmi -middle_end/base_types/set_of_closures_origin.cmi : \ - middle_end/base_types/set_of_closures_id.cmi \ + middle_end/compilation_unit.cmi +middle_end/flambda/base_types/set_of_closures_origin.cmo : \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/base_types/set_of_closures_origin.cmi +middle_end/flambda/base_types/set_of_closures_origin.cmx : \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/set_of_closures_origin.cmi +middle_end/flambda/base_types/set_of_closures_origin.cmi : \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ utils/identifiable.cmi \ - middle_end/base_types/compilation_unit.cmi -middle_end/base_types/static_exception.cmo : \ + middle_end/compilation_unit.cmi +middle_end/flambda/base_types/static_exception.cmo : \ utils/numbers.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/base_types/static_exception.cmi -middle_end/base_types/static_exception.cmx : \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/base_types/static_exception.cmi +middle_end/flambda/base_types/static_exception.cmx : \ utils/numbers.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/base_types/static_exception.cmi -middle_end/base_types/static_exception.cmi : \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/static_exception.cmi +middle_end/flambda/base_types/static_exception.cmi : \ utils/identifiable.cmi -middle_end/base_types/symbol.cmo : \ - middle_end/base_types/variable.cmi \ - utils/misc.cmi \ - middle_end/base_types/linkage_name.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - utils/identifiable.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/symbol.cmi -middle_end/base_types/symbol.cmx : \ - middle_end/base_types/variable.cmx \ - utils/misc.cmx \ - middle_end/base_types/linkage_name.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - utils/identifiable.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/symbol.cmi -middle_end/base_types/symbol.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/linkage_name.cmi \ - utils/identifiable.cmi \ - middle_end/base_types/compilation_unit.cmi -middle_end/base_types/tag.cmo : \ +middle_end/flambda/base_types/tag.cmo : \ utils/numbers.cmi \ utils/misc.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ + utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ - middle_end/base_types/tag.cmi -middle_end/base_types/tag.cmx : \ + middle_end/flambda/base_types/tag.cmi +middle_end/flambda/base_types/tag.cmx : \ utils/numbers.cmx \ utils/misc.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ + utils/int_replace_polymorphic_compare.cmx \ utils/identifiable.cmx \ - middle_end/base_types/tag.cmi -middle_end/base_types/tag.cmi : \ + middle_end/flambda/base_types/tag.cmi +middle_end/flambda/base_types/tag.cmi : \ utils/identifiable.cmi -middle_end/base_types/var_within_closure.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/base_types/closure_element.cmi \ - middle_end/base_types/var_within_closure.cmi -middle_end/base_types/var_within_closure.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/base_types/closure_element.cmx \ - middle_end/base_types/var_within_closure.cmi -middle_end/base_types/var_within_closure.cmi : \ - middle_end/base_types/closure_element.cmi -middle_end/base_types/variable.cmo : \ - utils/misc.cmi \ - middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - utils/identifiable.cmi \ - typing/ident.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/variable.cmi -middle_end/base_types/variable.cmx : \ - utils/misc.cmx \ - middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - utils/identifiable.cmx \ - typing/ident.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/variable.cmi -middle_end/base_types/variable.cmi : \ - middle_end/internal_variable_names.cmi \ - utils/identifiable.cmi \ - typing/ident.cmi \ - middle_end/base_types/compilation_unit.cmi +middle_end/flambda/base_types/var_within_closure.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/base_types/closure_element.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi +middle_end/flambda/base_types/var_within_closure.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/closure_element.cmx \ + middle_end/flambda/base_types/var_within_closure.cmi +middle_end/flambda/base_types/var_within_closure.cmi : \ + middle_end/flambda/base_types/closure_element.cmi asmcomp/debug/available_regs.cmo : \ asmcomp/debug/reg_with_debug_info.cmi \ asmcomp/debug/reg_availability_set.cmi \ @@ -5283,7 +5419,7 @@ asmcomp/debug/available_regs.cmo : \ utils/misc.cmi \ asmcomp/mach.cmi \ utils/clflags.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ asmcomp/debug/available_regs.cmi asmcomp/debug/available_regs.cmx : \ asmcomp/debug/reg_with_debug_info.cmx \ @@ -5294,56 +5430,60 @@ asmcomp/debug/available_regs.cmx : \ utils/misc.cmx \ asmcomp/mach.cmx \ utils/clflags.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ asmcomp/debug/available_regs.cmi asmcomp/debug/available_regs.cmi : \ asmcomp/mach.cmi +asmcomp/debug/compute_ranges.cmo : \ + asmcomp/printlinear.cmi \ + utils/numbers.cmi \ + utils/misc.cmi \ + asmcomp/linearize.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + asmcomp/debug/compute_ranges_intf.cmo \ + asmcomp/cmm.cmi \ + asmcomp/debug/compute_ranges.cmi +asmcomp/debug/compute_ranges.cmx : \ + asmcomp/printlinear.cmx \ + utils/numbers.cmx \ + utils/misc.cmx \ + asmcomp/linearize.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + asmcomp/debug/compute_ranges_intf.cmx \ + asmcomp/cmm.cmx \ + asmcomp/debug/compute_ranges.cmi +asmcomp/debug/compute_ranges.cmi : \ + asmcomp/debug/compute_ranges_intf.cmo +asmcomp/debug/compute_ranges_intf.cmo : \ + utils/numbers.cmi \ + asmcomp/linearize.cmi \ + utils/identifiable.cmi +asmcomp/debug/compute_ranges_intf.cmx : \ + utils/numbers.cmx \ + asmcomp/linearize.cmx \ + utils/identifiable.cmx asmcomp/debug/reg_availability_set.cmo : \ asmcomp/debug/reg_with_debug_info.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ asmcomp/debug/reg_availability_set.cmi asmcomp/debug/reg_availability_set.cmx : \ asmcomp/debug/reg_with_debug_info.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ asmcomp/debug/reg_availability_set.cmi asmcomp/debug/reg_availability_set.cmi : \ asmcomp/debug/reg_with_debug_info.cmi \ asmcomp/reg.cmi asmcomp/debug/reg_with_debug_info.cmo : \ asmcomp/reg.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ asmcomp/debug/reg_with_debug_info.cmi asmcomp/debug/reg_with_debug_info.cmx : \ asmcomp/reg.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ asmcomp/debug/reg_with_debug_info.cmi asmcomp/debug/reg_with_debug_info.cmi : \ asmcomp/reg.cmi \ - asmcomp/backend_var.cmi -driver/compdynlink.cmi : -driver/compdynlink_common.cmo : \ - driver/compdynlink_types.cmi \ - driver/compdynlink_platform_intf.cmi \ - driver/compdynlink_common.cmi -driver/compdynlink_common.cmx : \ - driver/compdynlink_types.cmx \ - driver/compdynlink_platform_intf.cmx \ - driver/compdynlink_common.cmi -driver/compdynlink_common.cmi : \ - driver/compdynlink_platform_intf.cmi -driver/compdynlink_platform_intf.cmo : \ - driver/compdynlink_types.cmi \ - driver/compdynlink_platform_intf.cmi -driver/compdynlink_platform_intf.cmx : \ - driver/compdynlink_types.cmx \ - driver/compdynlink_platform_intf.cmi -driver/compdynlink_platform_intf.cmi : \ - driver/compdynlink_types.cmi -driver/compdynlink_types.cmo : \ - driver/compdynlink_types.cmi -driver/compdynlink_types.cmx : \ - driver/compdynlink_types.cmi -driver/compdynlink_types.cmi : + middle_end/backend_var.cmi driver/compenv.cmo : \ utils/warnings.cmi \ utils/profile.cmi \ @@ -5364,26 +5504,26 @@ driver/compenv.cmx : \ driver/compenv.cmi driver/compenv.cmi : driver/compile.cmo : \ - bytecomp/translmod.cmi \ - bytecomp/simplif.cmi \ + lambda/translmod.cmi \ + lambda/simplif.cmi \ utils/profile.cmi \ - bytecomp/printlambda.cmi \ + lambda/printlambda.cmi \ bytecomp/printinstr.cmi \ utils/misc.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ bytecomp/emitcode.cmi \ driver/compile_common.cmi \ utils/clflags.cmi \ bytecomp/bytegen.cmi \ driver/compile.cmi driver/compile.cmx : \ - bytecomp/translmod.cmx \ - bytecomp/simplif.cmx \ + lambda/translmod.cmx \ + lambda/simplif.cmx \ utils/profile.cmx \ - bytecomp/printlambda.cmx \ + lambda/printlambda.cmx \ bytecomp/printinstr.cmx \ utils/misc.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ bytecomp/emitcode.cmx \ driver/compile_common.cmx \ utils/clflags.cmx \ @@ -5467,23 +5607,6 @@ driver/compmisc.cmx : \ driver/compmisc.cmi : \ typing/env.cmi \ utils/clflags.cmi -driver/compplugin.cmo : \ - parsing/location.cmi \ - utils/load_path.cmi \ - driver/compmisc.cmi \ - driver/compenv.cmi \ - driver/compdynlink.cmi \ - utils/clflags.cmi \ - driver/compplugin.cmi -driver/compplugin.cmx : \ - parsing/location.cmx \ - utils/load_path.cmx \ - driver/compmisc.cmx \ - driver/compenv.cmx \ - driver/compdynlink.cmi \ - utils/clflags.cmx \ - driver/compplugin.cmi -driver/compplugin.cmi : driver/errors.cmo : \ parsing/location.cmi \ driver/errors.cmi @@ -5499,7 +5622,6 @@ driver/main.cmo : \ driver/main_args.cmi \ parsing/location.cmi \ utils/config.cmi \ - driver/compplugin.cmi \ driver/compmisc.cmi \ driver/compile.cmi \ driver/compenv.cmi \ @@ -5516,7 +5638,6 @@ driver/main.cmx : \ driver/main_args.cmx \ parsing/location.cmx \ utils/config.cmx \ - driver/compplugin.cmx \ driver/compmisc.cmx \ driver/compile.cmx \ driver/compenv.cmx \ @@ -5550,7 +5671,6 @@ driver/makedepend.cmo : \ parsing/lexer.cmi \ parsing/depend.cmi \ utils/config.cmi \ - driver/compplugin.cmi \ driver/compenv.cmi \ utils/clflags.cmi \ driver/makedepend.cmi @@ -5565,35 +5685,34 @@ driver/makedepend.cmx : \ parsing/lexer.cmx \ parsing/depend.cmx \ utils/config.cmx \ - driver/compplugin.cmx \ driver/compenv.cmx \ utils/clflags.cmx \ driver/makedepend.cmi driver/makedepend.cmi : driver/optcompile.cmo : \ - bytecomp/translmod.cmi \ - bytecomp/simplif.cmi \ + lambda/translmod.cmi \ + lambda/simplif.cmi \ utils/profile.cmi \ - bytecomp/printlambda.cmi \ + lambda/printlambda.cmi \ utils/misc.cmi \ - middle_end/middle_end.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ + middle_end/flambda/flambda_middle_end.cmi \ utils/config.cmi \ - asmcomp/compilenv.cmi \ + middle_end/compilenv.cmi \ driver/compile_common.cmi \ utils/clflags.cmi \ asmcomp/asmgen.cmi \ driver/optcompile.cmi driver/optcompile.cmx : \ - bytecomp/translmod.cmx \ - bytecomp/simplif.cmx \ + lambda/translmod.cmx \ + lambda/simplif.cmx \ utils/profile.cmx \ - bytecomp/printlambda.cmx \ + lambda/printlambda.cmx \ utils/misc.cmx \ - middle_end/middle_end.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ + middle_end/flambda/flambda_middle_end.cmx \ utils/config.cmx \ - asmcomp/compilenv.cmx \ + middle_end/compilenv.cmx \ driver/compile_common.cmx \ utils/clflags.cmx \ asmcomp/asmgen.cmx \ @@ -5619,11 +5738,10 @@ driver/optmain.cmo : \ driver/makedepend.cmi \ driver/main_args.cmi \ parsing/location.cmi \ - asmcomp/import_approx.cmi \ + middle_end/flambda/import_approx.cmi \ utils/config.cmi \ - driver/compplugin.cmi \ driver/compmisc.cmi \ - asmcomp/compilenv.cmi \ + middle_end/compilenv.cmi \ driver/compenv.cmi \ utils/clflags.cmi \ middle_end/backend_intf.cmi \ @@ -5642,11 +5760,10 @@ driver/optmain.cmx : \ driver/makedepend.cmx \ driver/main_args.cmx \ parsing/location.cmx \ - asmcomp/import_approx.cmx \ + middle_end/flambda/import_approx.cmx \ utils/config.cmx \ - driver/compplugin.cmx \ driver/compmisc.cmx \ - asmcomp/compilenv.cmx \ + middle_end/compilenv.cmx \ driver/compenv.cmx \ utils/clflags.cmx \ middle_end/backend_intf.cmi \ @@ -5683,17 +5800,16 @@ driver/pparse.cmx : \ parsing/ast_invariants.cmx \ driver/pparse.cmi driver/pparse.cmi : \ - parsing/parsetree.cmi \ - utils/misc.cmi + parsing/parsetree.cmi toplevel/expunge.cmo : \ bytecomp/symtable.cmi \ - bytecomp/runtimedef.cmi \ + lambda/runtimedef.cmi \ utils/misc.cmi \ typing/ident.cmi \ bytecomp/bytesections.cmi toplevel/expunge.cmx : \ bytecomp/symtable.cmx \ - bytecomp/runtimedef.cmx \ + lambda/runtimedef.cmx \ utils/misc.cmx \ typing/ident.cmx \ bytecomp/bytesections.cmx @@ -5744,7 +5860,6 @@ toplevel/opttopdirs.cmo : \ typing/env.cmi \ typing/ctype.cmi \ utils/config.cmi \ - driver/compdynlink.cmi \ utils/clflags.cmi \ asmcomp/asmlink.cmi \ toplevel/opttopdirs.cmi @@ -5760,7 +5875,6 @@ toplevel/opttopdirs.cmx : \ typing/env.cmx \ typing/ctype.cmx \ utils/config.cmx \ - driver/compdynlink.cmi \ utils/clflags.cmx \ asmcomp/asmlink.cmx \ toplevel/opttopdirs.cmi @@ -5772,12 +5886,12 @@ toplevel/opttoploop.cmo : \ typing/typemod.cmi \ typing/typedtree.cmi \ typing/typecore.cmi \ - bytecomp/translmod.cmi \ - bytecomp/simplif.cmi \ + lambda/translmod.cmi \ + lambda/simplif.cmi \ asmcomp/proc.cmi \ typing/printtyped.cmi \ typing/printtyp.cmi \ - bytecomp/printlambda.cmi \ + lambda/printlambda.cmi \ parsing/printast.cmi \ typing/predef.cmi \ parsing/pprintast.cmi \ @@ -5788,20 +5902,20 @@ toplevel/opttoploop.cmo : \ typing/outcometree.cmi \ typing/oprint.cmi \ utils/misc.cmi \ - middle_end/middle_end.cmi \ parsing/longident.cmi \ parsing/location.cmi \ utils/load_path.cmi \ parsing/lexer.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/includemod.cmi \ - asmcomp/import_approx.cmi \ + middle_end/flambda/import_approx.cmi \ typing/ident.cmi \ toplevel/genprintval.cmi \ + middle_end/flambda/flambda_middle_end.cmi \ typing/env.cmi \ utils/config.cmi \ driver/compmisc.cmi \ - asmcomp/compilenv.cmi \ + middle_end/compilenv.cmi \ driver/compenv.cmi \ utils/clflags.cmi \ typing/btype.cmi \ @@ -5818,12 +5932,12 @@ toplevel/opttoploop.cmx : \ typing/typemod.cmx \ typing/typedtree.cmx \ typing/typecore.cmx \ - bytecomp/translmod.cmx \ - bytecomp/simplif.cmx \ + lambda/translmod.cmx \ + lambda/simplif.cmx \ asmcomp/proc.cmx \ typing/printtyped.cmx \ typing/printtyp.cmx \ - bytecomp/printlambda.cmx \ + lambda/printlambda.cmx \ parsing/printast.cmx \ typing/predef.cmx \ parsing/pprintast.cmx \ @@ -5834,20 +5948,20 @@ toplevel/opttoploop.cmx : \ typing/outcometree.cmi \ typing/oprint.cmx \ utils/misc.cmx \ - middle_end/middle_end.cmx \ parsing/longident.cmx \ parsing/location.cmx \ utils/load_path.cmx \ parsing/lexer.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ typing/includemod.cmx \ - asmcomp/import_approx.cmx \ + middle_end/flambda/import_approx.cmx \ typing/ident.cmx \ toplevel/genprintval.cmx \ + middle_end/flambda/flambda_middle_end.cmx \ typing/env.cmx \ utils/config.cmx \ driver/compmisc.cmx \ - asmcomp/compilenv.cmx \ + middle_end/compilenv.cmx \ driver/compenv.cmx \ utils/clflags.cmx \ typing/btype.cmx \ @@ -5905,9 +6019,10 @@ toplevel/topdirs.cmo : \ bytecomp/symtable.cmi \ typing/printtyp.cmi \ typing/predef.cmi \ + typing/persistent_env.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ - bytecomp/opcodes.cmo \ + bytecomp/opcodes.cmi \ utils/misc.cmi \ bytecomp/meta.cmi \ parsing/longident.cmi \ @@ -5917,9 +6032,8 @@ toplevel/topdirs.cmo : \ typing/env.cmi \ bytecomp/dll.cmi \ typing/ctype.cmi \ - utils/consistbl.cmi \ utils/config.cmi \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmi \ typing/btype.cmi \ parsing/asttypes.cmi \ @@ -5934,6 +6048,7 @@ toplevel/topdirs.cmx : \ bytecomp/symtable.cmx \ typing/printtyp.cmx \ typing/predef.cmx \ + typing/persistent_env.cmx \ typing/path.cmx \ parsing/parsetree.cmi \ bytecomp/opcodes.cmx \ @@ -5946,9 +6061,8 @@ toplevel/topdirs.cmx : \ typing/env.cmx \ bytecomp/dll.cmx \ typing/ctype.cmx \ - utils/consistbl.cmx \ utils/config.cmx \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmx \ typing/btype.cmx \ parsing/asttypes.cmi \ @@ -5963,12 +6077,12 @@ toplevel/toploop.cmo : \ typing/typemod.cmi \ typing/typedtree.cmi \ typing/typecore.cmi \ - bytecomp/translmod.cmi \ + lambda/translmod.cmi \ bytecomp/symtable.cmi \ - bytecomp/simplif.cmi \ + lambda/simplif.cmi \ typing/printtyped.cmi \ typing/printtyp.cmi \ - bytecomp/printlambda.cmi \ + lambda/printlambda.cmi \ bytecomp/printinstr.cmi \ parsing/printast.cmi \ typing/predef.cmi \ @@ -5991,7 +6105,6 @@ toplevel/toploop.cmo : \ typing/env.cmi \ bytecomp/emitcode.cmi \ bytecomp/dll.cmi \ - utils/consistbl.cmi \ utils/config.cmi \ driver/compmisc.cmi \ driver/compenv.cmi \ @@ -6008,12 +6121,12 @@ toplevel/toploop.cmx : \ typing/typemod.cmx \ typing/typedtree.cmx \ typing/typecore.cmx \ - bytecomp/translmod.cmx \ + lambda/translmod.cmx \ bytecomp/symtable.cmx \ - bytecomp/simplif.cmx \ + lambda/simplif.cmx \ typing/printtyped.cmx \ typing/printtyp.cmx \ - bytecomp/printlambda.cmx \ + lambda/printlambda.cmx \ bytecomp/printinstr.cmx \ parsing/printast.cmx \ typing/predef.cmx \ @@ -6036,7 +6149,6 @@ toplevel/toploop.cmx : \ typing/env.cmx \ bytecomp/emitcode.cmx \ bytecomp/dll.cmx \ - utils/consistbl.cmx \ utils/config.cmx \ driver/compmisc.cmx \ driver/compenv.cmx \ @@ -6113,20 +6225,3 @@ toplevel/trace.cmi : \ typing/path.cmi \ parsing/longident.cmi \ typing/env.cmi -driver/compdynlink.cmx : \ - driver/compdynlink_types.cmx \ - driver/compdynlink_common.cmx \ - asmcomp/cmx_format.cmi \ - driver/compdynlink.cmi -driver/compdynlink.cmo : \ - bytecomp/symtable.cmi \ - bytecomp/opcodes.cmo \ - utils/misc.cmi \ - bytecomp/meta.cmi \ - typing/ident.cmi \ - bytecomp/dll.cmi \ - utils/config.cmi \ - driver/compdynlink_types.cmi \ - driver/compdynlink_common.cmi \ - bytecomp/cmo_format.cmi \ - driver/compdynlink.cmi diff --git a/.gitattributes b/.gitattributes index ceac151d..ce51bd79 100644 --- a/.gitattributes +++ b/.gitattributes @@ -27,6 +27,10 @@ *.png binary *.tfm binary +# configure is declared as binary so that it doesn't get included in diffs. +# This also means it will have the correct Unix line-endings, even on Windows. +/configure binary + # 'union' merge driver just unions textual content in case of conflict # http://krlmlr.github.io/using-gitattributes-to-avoid-merge-conflicts/ /.mailmap merge=union @@ -41,6 +45,7 @@ README* typo.missing-header *.adoc typo.missing-header stdlib/*.mld typo.missing-header +tools/mantis2gh_stripped.csv typo.missing-header *.adoc typo.long-line=may @@ -55,7 +60,7 @@ stdlib/*.mld typo.missing-header /tools/ci/appveyor/appveyor_build.cmd typo.very-long-line typo.missing-header typo.non-ascii /tools/ci/appveyor/appveyor_build.sh typo.non-ascii /tools/ci/inria/remove-sinh-primitive.patch typo.white-at-eol typo.missing-header typo.long-line -/tools/release-checklist typo.missing-header +/tools/release-checklist typo.missing-header typo.very-long-line # ignore auto-generated .depend files .depend typo.prune @@ -69,9 +74,6 @@ asmcomp/*/emit.mlp typo.tab=may typo.long-line=may # The build-aux directory contains bundled files so do not check it build-aux typo.prune -/config/gnu typo.prune -/config/gnu/** typo.prune - /manual typo.prune /manual/** typo.prune @@ -94,8 +96,6 @@ otherlibs/win32unix/readlink.c typo.long-line otherlibs/win32unix/stat.c typo.long-line otherlibs/win32unix/symlink.c typo.long-line -runtime/i386.S typo.long-line - stdlib/hashbang typo.white-at-eol typo.missing-lf testsuite/tests/** typo.missing-header typo.long-line=may @@ -139,7 +139,6 @@ menhir-bench.bash typo.missing-header typo.utf8 /tools/ci/appveyor/appveyor_build.cmd text eol=crlf -configure text eol=lf configure.ac text eol=lf autogen text eol=lf build-aux/compile text eol=lf @@ -147,15 +146,6 @@ build-aux/config.guess text eol=lf build-aux/config.sub text eol=lf build-aux/install text eol=lf build-aux/missing text eol=lf -config/auto-aux/hasgot text eol=lf -config/auto-aux/hasgot2 text eol=lf -config/auto-aux/runtest text eol=lf -config/auto-aux/searchpath text eol=lf -config/auto-aux/solaris-ld text eol=lf -config/auto-aux/tryassemble text eol=lf -config/auto-aux/trycompile text eol=lf -config/gnu/config.guess text eol=lf -config/gnu/config.sub text eol=lf ocamldoc/remove_DEBUG text eol=lf ocamltest/getocamloptdefaultflags text eol=lf stdlib/Compflags text eol=lf @@ -176,11 +166,7 @@ tools/markdown-add-pr-links.sh text eol=lf runtime/caml/m.h.in text eol=lf runtime/caml/s.h.in text eol=lf -# These two are cat scripts, so may not actually require this -config/auto-aux/sharpbang text eol=lf -config/auto-aux/sharpbang2 text eol=lf - -# Similarly, these are all Perl scripts, so may not actually require this +# These are all Perl scripts, so may not actually require this manual/tools/caml-tex text eol=lf manual/tools/format-intf text eol=lf manual/tools/htmlcut text eol=lf diff --git a/.gitignore b/.gitignore index 1f324126..04ddcaa0 100644 --- a/.gitignore +++ b/.gitignore @@ -67,27 +67,22 @@ _build /boot/ocamlrun /boot/camlheader +/boot/ocamlc.opt /bytecomp/runtimedef.ml /bytecomp/opcodes.ml +/bytecomp/opcodes.mli /debugger/lexer.ml /debugger/parser.ml /debugger/parser.mli /debugger/ocamldebug -/driver/compdynlink.mlopt -/driver/compdynlink.mlbyte -/driver/compdynlink.mli -/driver/compdynlink_common.ml -/driver/compdynlink_common.mli -/driver/compdynlink_platform_intf.ml -/driver/compdynlink_platform_intf.mli -/driver/compdynlink_types.ml -/driver/compdynlink_types.mli /emacs/ocamltags /emacs/*.elc +/lambda/runtimedef.ml + /lex/parser.ml /lex/parser.mli /lex/lexer.ml @@ -128,11 +123,15 @@ _build /otherlibs/dynlink/extract_crc /otherlibs/dynlink/dynlink_platform_intf.mli +/otherlibs/dynlink/byte/dynlink.mli +/otherlibs/dynlink/native/dynlink.mli +/otherlibs/dynlink/dynlink_compilerlibs/Makefile +/otherlibs/dynlink/dynlink_compilerlibs/*.ml +/otherlibs/dynlink/dynlink_compilerlibs/*.mli +/otherlibs/dynlink/dynlink_compilerlibs/.depend /otherlibs/threads/marshal.mli /otherlibs/threads/stdlib.mli /otherlibs/threads/unix.mli -/otherlibs/win32graph/graphics.ml -/otherlibs/win32graph/graphics.mli /otherlibs/win32unix/unixLabels.ml* /otherlibs/win32unix/unix.mli /otherlibs/win32unix/access.c diff --git a/.mailmap b/.mailmap index 6959fe22..d83748cc 100644 --- a/.mailmap +++ b/.mailmap @@ -47,6 +47,8 @@ Nicolás Ojeda Bär # Preferred Name Gabriel Radanne +Vincent Laviron +Jeremy Yallop ### Remembering naming preferences for contributors diff --git a/.travis.yml b/.travis.yml index 60b2d7ab..da9f2a3c 100644 --- a/.travis.yml +++ b/.travis.yml @@ -13,6 +13,7 @@ #* * #************************************************************************** +dist: xenial sudo: false language: c git: @@ -35,9 +36,9 @@ matrix: - env: CI_KIND=changes - env: CI_KIND=manual - env: CI_KIND=check-typo - - env: CI_KIND=tests - allow_failures: - - env: CI_KIND=tests +# - env: CI_KIND=tests +# allow_failures: +# - env: CI_KIND=tests addons: apt: packages: diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 7cfbf6b2..b60089b2 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -139,6 +139,56 @@ you only see a transient failure once and your change has no reason to affect threading, it's probably not your fault. +### Benchmarking + +If your contribution can impact the performance of the code generated +by the native compiler, you can use the infrastructure that the +flambda team put together to benchmark the compiler to assess the +consequences of your contribution. It has two main accessible parts: + +- The website that hosts benchmarks results, at +[http://bench.flambda.ocamlpro.com/](http://bench.flambda.ocamlpro.com/). +It exposes two ways to compare compilers: the first, under the header +`Plot a given benchmark`, allows to select a benchmark and +see graphs plotting the evolution of the performance of the different +compilers over time. The second, under `Compare two runs`, allows +to get an overview of the differences between a reference compiler +(selected using the `ref` button) and a compiler under test (using +the `tst` button). Clicking on the `Compare` button at the bottom +right of the page will create a new page containing summaries and +raw data comparing the selected runs. + +- The git repository containing the data about which benchmarks +to run, on which compilers, at [https://github.com/OCamlPro/ocamlbench-repo]( +https://github.com/OCamlPro/ocamlbench-repo). This needs to be a valid +opam 2.0 repository, and contains the benchmarks as normal packages +and the compilers as versions of the package `ocaml-variants`. +To add a compiler to the list, you must have a publicly accessible +version of your branch (if you're making a pull request again the +compiler, you should have a branch on github that was used to make +the pull request, that you can use for this purpose). +Then, you should make a pull request against `ocamlbench-repo` +that adds a repertory in the `packages/ocaml-variants` sub-folder +which contains a single `opam` file. The contents of the file +should be inspired from the other files already present, with +the main points of interest being the `url` field, which should +point to your branch, the `build` field that should be adapted +if the features that you want to benchmark depend on configure-time +options, and the `setenv` field that can be used to pass compiler +options via the `OCAMLPARAM` environment variable. +The `trunk+flambda+opt` compiler, for instance, both uses a +`configure` option and sets the `OCAMLPARAM` variable. +The folder you add has to be named `ocaml-variants.%VERSION%+%DESCR%`, +where `%VERSION%` is the version that will be used by opam to +check compatibility with the opam packages that are needed for the +benchmarks, and `%DESCR%` should be a short description of the feature +you're benchmarking (if you're making a pull request against `ocaml`, +you can use the PR number in the description, e.g. `+gpr0000`). +Once your pull request is merged, it will likely take a few hours +until the benchmark server picks up the new definition and again +up to a few hours before the results are available on the results page. + + ## Description of the proposed change ### In the merge request interface @@ -193,12 +243,11 @@ Any user-visible change should have a `Changes` entry: - using the label "`*`" if it breaks existing programs, "`-`" otherwise -- with the issue number `PR#{N}` if from mantis, `GPR#{N}` if from github - (several numbers separated by commas can be used) +- with all relevant issue and PR numbers `#{N}`, in ascending numerical order + (separated by commas if necessary) -- maintaining the order: each section lists Mantis PRs first in ascending - numerical order, followed by Github PRs in ascending numerical order, - followed by changes that are not related to a PR. +- maintaining the order: the entries in each section should be sorted by + issue/PR number (the first of each entry, if more than one is available) - with a concise readable description of the change (possibly taken from a commit message, but it should make sense to end-users diff --git a/Changes b/Changes index 670abe75..d4b8a994 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,283 @@ +OCaml 4.09.0 +------------ + +(Changes that can break existing programs are marked with a "*") + +### Runtime system: + +* #1725, #2279: Deprecate Obj.set_tag and Obj.truncate + (Stephen Dolan, review by Gabriel Scherer, Damien Doligez and Xavier Leroy) + +* #2240: Constify "identifier" in struct custom_operations + (Cedric Cellier, review by Xavier Leroy) + +* #2293: Constify "caml_named_value" + (Stephen Dolan, review by Xavier Leroy) + +- #8787, #8788: avoid integer overflow in caml_output_value_to_bytes + (Jeremy Yallop, report by Marcello Seri) + + +- #2075, #7729: rename _T macro used to support Unicode in the (Windows) runtime + in order to avoid compiler warning + (Nicolás Ojeda Bär, review by Gabriel Scherer and David Allsopp) + +- #2250: Remove extra integer sign-extension in compare functions + (Stefan Muenzel, review by Xavier Leroy) + +- #8607: Remove obsolete macros for pre-2002 MSVC support + (Stephen Dolan, review by Nicolás Ojeda Bär and David Allsopp) + +- #8656: Fix a bug in [caml_modify_generational_global_root] + (Jacques-Henri Jourdan, review by Gabriel Scherer) + +### Standard library: + +- #2262: take precision (.) and flags ('+' and ' ') into account + in printf %F + (Pierre Roux, review by Gabriel Scherer) + +- #6148, #8596: optimize some buffer operations + (Damien Doligez, reports by John Whitington and Alain Frisch, + review by Jeremy Yallop and Gabriel Scherer) + +### Other libraries: + +* #2318: Delete the graphics library. This library is now available + as a separate "graphics" package in opam. Its new home is: + https://github.com/ocaml/graphics + (Jérémie Dimino, review by Nicolas Ojeda Bar, Xavier Leroy and + Sébastien Hinderer) + +* #2289: Delete the vmthreads library. This library was deprecated in 4.08.0. + (Jérémie Dimino) + +- #2112: Fix Thread.yield unfairness with busy threads yielding to each + other. + (Andrew Hunter, review by Jacques-Henri Jourdan, Spiros Eliopoulos, Stephen + Weeks, & Mark Shinwell) + +- #7903, #2306: Make Thread.delay interruptible by signals again + (Xavier Leroy, review by Jacques-Henri Jourdan and Edwin Török) + +- #2248: Unix alloc_sockaddr: Fix read of uninitialized memory for an + unbound Unix socket. Add support for receiving abstract (Linux) socket paths. + (Tim Cuthbertson, review by Sébastien Hinderer and Jérémie Dimino) + +### Compiler user-interface and warnings: + +* #2276: Remove support for compiler plugins and hooks (also adds + [Dynlink.unsafe_get_global_value]) + (Mark Shinwell, Xavier Clerc, review by Nicolás Ojeda Bär, + Florian Angeletti, David Allsopp and Xavier Leroy) + +- #2301: Hint on type error on int literal + (Jules Aguillon, review by Nicolás Ojeda Bär , Florian Angeletti, + Gabriel Scherer and Armaël Guéneau) + +* #2314: Remove support for gprof profiling. + (Mark Shinwell, review by Xavier Clerc and Stephen Dolan) + +- #2190: fix pretty printing (using Pprintast) of "lazy ..." patterns and + "fun (type t) -> ..." expressions. + (Nicolás Ojeda Bär, review by Gabriel Scherer) + +- #2277: Use newtype names as type variable names + The inferred type of (fun (type t) (x : t) -> x) + is now printed as ('t -> 't) rather than ('a -> 'a). + (Matthew Ryan) + + +- #2309: New options -with-runtime and -without-runtime in ocamlopt/ocamlc + that control the inclusion of the runtime system in the generated program. + (Lucas Pluvinage, review by Daniel Bünzli, Damien Doligez, David Allsopp + and Florian Angeletti) + +- #3819, #8546 more explanations and tests for illegal permutation + (Florian Angeletti, review by Gabriel Scherer) + +- #8537: fix the -runtime-variant option for bytecode + (Damien Doligez, review by David Allsopp) + +- #8541: Correctly print multi-lines locations + (Louis Roché, review by Gabriel Scherer) + +- #8579: Better error message for private constructors + of an extensible variant type + (Guillaume Bury, review by many fine eyes) + +### Code generation and optimizations: + +- #2278: Remove native code generation support for 32-bit Intel macOS, + iOS and other Darwin targets. + (Mark Shinwell, review by Nicolas Ojeda Bar and Xavier Leroy) + +- #8547: Optimize matches that are an affine function of the input. + (Stefan Muenzel, review by Alain Frisch, Gabriel Scherer) + + +- #1904, #7931: Add FreeBSD/aarch64 support + (Greg V, review by Sébastien Hinderer, Stephen Dolan, Damien Doligez + and Xavier Leroy) + +- #8507: Shorten symbol names of anonymous functions in Flambda mode + (the directory portions are now hidden) + (Mark Shinwell, review by Nicolás Ojeda Bär) + +- #8681, #8699, #8712: Fix code generation with nested let rec of functions. + (Stephen Dolan, Leo White, Gabriel Scherer and Pierre Chambart, + review by Gabriel Scherer, reports by Alexey Solovyev and Jonathan French) + +### Manual and documentation: + +- #7584, #8538: Document .cmt* files in the "overview" of ocaml{c,opt} + (Oxana Kostikova, rewiew by Florian Angeletti) + + +- #8757: Rename Pervasives to Stdlib in core library documentation. + (Ian Zimmerman, review by David Allsopp) + +- #8515: manual, precise constraints on reexported types + (Florian Angeletti, review by Gabriel Scherer) + +### Tools: + +- #2221: ocamldep will now correctly allow a .ml file in an include directory + that appears first in the search order to shadow a .mli appearing in a later + include directory. + (Nicolás Ojeda Bär, review by Florian Angeletti) + +### Internal/compiler-libs changes: + +- #1579: Add a separate types for clambda primitives + (Pierre Chambart, review by Vincent Laviron and Mark Shinwell) + +- #1965: remove loop constructors in Cmm and Mach + (Vincent Laviron) + +- #1973: fix compilation of catches with multiple handlers + (Vincent Laviron) + +- #2228, #8545: refactoring the handling of .cmi files + by moving the logic from Env to a new module Persistent_env + (Gabriel Scherer, review by Jérémie Dimino and Thomas Refis) + +- #2229: Env: remove prefix_idents cache + (Thomas Refis, review by Frédéric Bour and Gabriel Scherer) + +- #2237, #8582: Reorder linearisation of Trywith to avoid a call instruction + (Vincent Laviron and Greta Yorsh, additional review by Mark Shinwell; + fix in #8582 by Mark Shinwell, Xavier Leroy and Anil Madhavapeddy) + +- #2265: Add bytecomp/opcodes.mli + (Mark Shinwell, review by Nicolas Ojeda Bar) + +- #2268: Improve packing mechanism used for building compilerlibs modules + into the Dynlink libraries + (Mark Shinwell, Stephen Dolan, review by David Allsopp) + +- #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, review by Pierre Chambart and Vincent Laviron) + +- #2283: Add [is_prefix] and [find_and_chop_longest_common_prefix] to + [Misc.Stdlib.List] + (Mark Shinwell, review by Alain Frisch and Stephen Dolan) + +- #2284: Add various utility functions to [Misc] and remove functions + from [Misc.Stdlib.Option] that are now in [Stdlib.Option] + (Mark Shinwell, review by Thomas Refis) + +- #2286: Functorise [Consistbl] + (Mark Shinwell, review by Gabriel Radanne) + +- #2291: Add [Compute_ranges] pass + (Mark Shinwell, review by Vincent Laviron) + +- #2292: Add [Proc.frame_required] and [Proc.prologue_required]. + Move tail recursion label creation to [Linearize]. Correctly position + [Lprologue] relative to [Iname_for_debugger] operations. + (Mark Shinwell, review by Vincent Laviron) + +- #2308: More debugging information on [Cmm] terms + (Mark Shinwell, review by Stephen Dolan) + +- #7878, #8542: Replaced TypedtreeIter with tast_iterator + (Isaac "Izzy" Avram, review by Gabriel Scherer and Nicolás Ojeda Bär) + +- #8598: Replace "not is_nonexpansive" by "maybe_expansive". + (Thomas Refis, review by David Allsopp, Florian Angeletti, Gabriel Radanne, + Gabriel Scherer and Xavier Leroy) + +### Compiler distribution build system: + +- #2267: merge generation of header programs, also fixing parallel build on + Cygwin. + (David Allsopp, review by Sébastien Hinderer) + +- #8514: Use boot/ocamlc.opt for building, if available. + (Stephen Dolan, review by Gabriel Scherer) + +### Bug fixes: + +- #8864, #8865: Fix native compilation of left shift by (word_size - 1) + (Vincent Laviron, report by Murilo Giacometti Rocha, review by Xavier Leroy) + +- #2296: Fix parsing of hexadecimal floats with underscores in the exponent. + (Hugo Heuzard and Xavier Leroy, review by Gabriel Scherer) + +- #8800: Fix soundness bug in extension constructor inclusion + (Leo White, review by Jacques Garrigue) + +- #8848: Fix x86 stack probe CFI information in caml_c_call and + caml_call_gc + (Tom Kelly, review by Xavier Leroy) + + +- #7156, #8594: make top level use custom printers if they are available + (Andrew Litteken, report by Martin Jambon, review by Nicolás Ojeda Bär, + Thomas Refis, Armaël Guéneau, Gabriel Scherer, David Allsopp) + +- #3249: ocamlmklib should reject .cmxa files + (Xavier Leroy) + +- #7937, #2287: fix uncaught Unify exception when looking for type + declaration + (Florian Angeletti, review by Jacques Garrigue) + +- #8610, #8613: toplevel printing, consistent deduplicated name for types + (Florian Angeletti, review by Thomas Refis and Gabriel Scherer, + reported by Xavier Clerc) + +- #8635, #8636: Fix a bad side-effect of the -allow-approx option of + ocamldep. It used to turn some errors into successes + (Jérémie Dimino) + +- #8701, #8725: Variance of constrained parameters causes principality issues + (Jacques Garrigue, report by Leo White, review by Gabriel Scherer) + +- #8777(partial): fix position information in some polymorphic variant + error messages about missing tags + (Florian Angeletti, review by Thomas Refis) + +- #8779, more cautious variance computation to avoid missing cmis + (Florian Angeletti, report by Antonio Nuno Monteiro, review by Leo White) + +- #8810: Env.lookup_module: don't allow creating loops + (Thomas Refis, report by Leo White, review by Jacques Garrigue) + +- #8862, #8871: subst: preserve scopes + (Thomas Refis, report by Leo White, review by Jacques Garrigue) + +- #8921, #8924: Fix stack overflow with Flambda + (Vincent Laviron, review by Pierre Chambart and Leo White, + report by Aleksandr Kuzmenko) + +- #8944: Fix "open struct .. end" on clambda backend + (Thomas Refis, review by Leo White, report by Damon Wang and Mark Shinwell) + OCaml 4.08.1 (5 August 2019) ---------------------------- @@ -28,8 +308,6 @@ OCaml 4.08.1 (5 August 2019) OCaml 4.08.0 (13 June 2019) --------------------------- -(Changes that can break existing programs are marked with a "*") - ### Language features: - #1947: Introduce binding operators (let*, let+, and* etc.) diff --git a/HACKING.adoc b/HACKING.adoc index 3941a6f3..2958e851 100644 --- a/HACKING.adoc +++ b/HACKING.adoc @@ -124,7 +124,7 @@ link:driver/pparse.ml[]. ==== Typing -- link:typing/[] Type-checks the AST and produces a typed representation of the program -(link:parsing/typedtree.mli[] has some helpful comments). See +(link:typing/typedtree.mli[] has some helpful comments). See link:typing/HACKING.adoc[]. ==== The bytecode compiler -- link:bytecomp/[] @@ -179,13 +179,13 @@ has excellent documentation. VERSION:: version string asmcomp/:: native-code compiler and linker boot/:: bootstrap compiler + build-aux/: autotools support scripts bytecomp/:: bytecode compiler and linker compilerlibs/:: the OCaml compiler as a library - config/:: configuration files configure:: configure script + configure.ac: autoconf input file debugger/:: source-level replay debugger driver/:: driver code for the compilers - emacs/:: editing mode and debugger interface for GNU Emacs flexdll/:: git submodule -- see link:README.win32.adoc[] lex/:: lexer generator man/:: man pages @@ -243,6 +243,19 @@ bytecode runtime (which is written in C) has been built to compile the standard library and then to build a fresh compiler. Details can be found in link:BOOTSTRAP.adoc[]. +=== Speeding up builds + +Once you've built a natively-compiled `ocamlc.opt`, you can use it to +speed up future builds by copying it to `boot`: + +---- +cp ocamlc.opt boot/ +---- + +If `boot/ocamlc` changes (e.g. because you ran `make bootstrap`), then +the build will revert to the slower bytecode-compiled `ocamlc` until +you do the above step again. + === Continuous integration ==== Github's CI: Travis and AppVeyor diff --git a/INSTALL.adoc b/INSTALL.adoc index c281eeb8..2643c6f2 100644 --- a/INSTALL.adoc +++ b/INSTALL.adoc @@ -48,10 +48,6 @@ Examples: CC='gcc -m32' AS='as --32' ASPP='gcc -m32 -c' \ PARTIALLD='ld -r -melf_i386' -* For AIX 4.3 with the IBM compiler `xlc`: - - ./configure -cc "xlc_r -D_AIX43 -Wl,-bexpall,-brtl -qmaxmem=8192" - * For AIX 7.x with the IBM compiler `xlc`: ./configure CC=xlc @@ -63,9 +59,10 @@ By default, build is 32-bit. For 64-bit build, please set environment variable ` If something goes wrong during the automatic configuration, or if the generated files cause errors later on, then look at the template files: - config/Makefile-templ - config/m-templ.h - config/s-templ.h + Makefile.config.in + Makefile.common.in + runtime/caml/m.h.in + runtime/caml/s.h.in + for guidance on how to edit the generated files by hand. @@ -131,7 +128,7 @@ After installation, do *not* strip the `ocamldebug` executables. code and OCaml bytecode) and stripping erases the bytecode! Other executables such as `ocamlrun` can safely be stripped. -== If something goes wwong +== If something goes wrong Read the "common problems" and "machine-specific hints" section at the end of this file. diff --git a/Makefile b/Makefile index 83598d6c..47548c79 100644 --- a/Makefile +++ b/Makefile @@ -41,14 +41,15 @@ else LN = ln -sf endif -CAMLRUN ?= boot/ocamlrun include stdlib/StdlibModules -CAMLC=$(CAMLRUN) 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 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-40-41-42-44-45-48-66 \ @@ -77,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 \ @@ -92,12 +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/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/typedtreeIter.cmo typing/tast_mapper.cmo \ - typing/cmt_format.cmo typing/untypeast.cmo \ + typing/tast_iterator.cmo typing/tast_mapper.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 \ @@ -106,25 +109,24 @@ 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/semantics_of_primitives.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 \ driver/pparse.cmo driver/main_args.cmo \ driver/compenv.cmo driver/compmisc.cmo \ - driver/compdynlink_types.cmo driver/compdynlink_platform_intf.cmo \ - driver/compdynlink_common.cmo driver/compdynlink.cmo \ - driver/compplugin.cmo driver/makedepend.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 \ @@ -152,24 +154,14 @@ 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.cmo \ + asmcomp/strmatch.cmo \ + asmcomp/cmmgen_state.cmo \ + asmcomp/cmmgen.cmo \ asmcomp/interval.cmo \ asmcomp/printmach.cmo asmcomp/selectgen.cmo \ asmcomp/spacetime_profiling.cmo asmcomp/selection.cmo \ @@ -183,6 +175,8 @@ ASMCOMP=\ asmcomp/deadcode.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ asmcomp/debug/available_regs.cmo \ + asmcomp/debug/compute_ranges_intf.cmo \ + asmcomp/debug/compute_ranges.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ asmcomp/branch_relaxation_intf.cmo \ asmcomp/branch_relaxation.cmo \ @@ -190,68 +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 \ - 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) @@ -323,7 +345,7 @@ coldstart: $(MAKE) -C runtime $(BOOT_FLEXLINK_CMD) all cp runtime/ocamlrun$(EXE) boot/ocamlrun$(EXE) $(MAKE) -C stdlib $(BOOT_FLEXLINK_CMD) \ - COMPILER="../boot/ocamlc -use-prims ../runtime/primitives" all + CAMLC='$$(BOOT_OCAMLC) -use-prims ../runtime/primitives' all cd stdlib; cp $(LIBFILES) ../boot cd boot; $(LN) ../runtime/libcamlrun.$(A) . @@ -474,11 +496,12 @@ flexdll: flexdll/Makefile flexlink flexlink: flexdll/Makefile $(MAKE) -C runtime BOOTSTRAPPING_FLEXLINK=yes ocamlrun$(EXE) cp runtime/ocamlrun$(EXE) boot/ocamlrun$(EXE) - $(MAKE) -C stdlib COMPILER=../boot/ocamlc stdlib.cma std_exit.cmo - cd stdlib && cp stdlib.cma std_exit.cmo *.cmi ../boot + $(MAKE) -C stdlib COMPILER=../boot/ocamlc \ + $(filter-out *.cmi,$(LIBFILES)) + cd stdlib && cp $(LIBFILES) ../boot/ $(MAKE) -C flexdll MSVC_DETECT=0 OCAML_CONFIG_FILE=../Makefile.config \ CHAINS=$(FLEXDLL_CHAIN) NATDYNLINK=false \ - OCAMLOPT="../boot/ocamlrun ../boot/ocamlc -I ../boot" \ + OCAMLOPT="../boot/ocamlrun ../boot/ocamlc -nostdlib -I ../boot" \ flexlink.exe $(MAKE) -C runtime clean $(MAKE) partialclean @@ -489,7 +512,8 @@ flexlink.opt: mv flexlink.exe flexlink && \ ($(MAKE) OCAML_FLEXLINK="../boot/ocamlrun ./flexlink" MSVC_DETECT=0 \ OCAML_CONFIG_FILE=../Makefile.config \ - OCAMLOPT="../ocamlopt.opt -I ../stdlib" flexlink.exe || \ + OCAMLOPT="../ocamlopt.opt -nostdlib -I ../stdlib" \ + flexlink.exe || \ (mv flexlink flexlink.exe && false)) && \ mv flexlink.exe flexlink.opt && \ mv flexlink flexlink.exe @@ -499,8 +523,7 @@ INSTALL_FLEXDLLDIR=$(INSTALL_LIBDIR)/flexdll .PHONY: install-flexdll install-flexdll: - cat stdlib/camlheader flexdll/flexlink.exe > \ - "$(INSTALL_BINDIR)/flexlink.exe" + $(INSTALL_PROG) flexdll/flexlink.exe "$(INSTALL_BINDIR)/flexlink$(EXE)" ifneq "$(filter-out mingw,$(TOOLCHAIN))" "" $(INSTALL_DATA) flexdll/default$(filter-out _i386,_$(ARCH)).manifest \ "$(INSTALL_BINDIR)/" @@ -535,6 +558,8 @@ endif parsing/*.cmi \ typing/*.cmi \ bytecomp/*.cmi \ + file_formats/*.cmi \ + lambda/*.cmi \ driver/*.cmi \ toplevel/*.cmi \ "$(INSTALL_COMPLIBDIR)" @@ -543,6 +568,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 \ @@ -608,24 +635,46 @@ 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 \ "$(INSTALL_COMPLIBDIR)" + $(INSTALL_DATA) \ + asmcomp/debug/*.cmi \ + "$(INSTALL_COMPLIBDIR)" ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true" $(INSTALL_DATA) \ middle_end/*.cmt middle_end/*.cmti \ 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 \ asmcomp/*.mli \ "$(INSTALL_COMPLIBDIR)" + $(INSTALL_DATA) \ + asmcomp/debug/*.cmt asmcomp/debug/*.cmti \ + asmcomp/debug/*.mli \ + "$(INSTALL_COMPLIBDIR)" endif $(INSTALL_DATA) \ compilerlibs/ocamloptcomp.cma $(OPTSTART) \ @@ -664,8 +713,14 @@ 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 \ + asmcomp/debug/*.cmx \ + "$(INSTALL_COMPLIBDIR)" $(INSTALL_DATA) \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \ compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \ @@ -694,8 +749,12 @@ 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 \ + asmcmp/debug/*.ml \ "$(INSTALL_COMPLIBDIR)" endif @@ -796,7 +855,7 @@ natruntop: # Native dynlink -otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml +otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/native/dynlink.ml $(MAKE) -C otherlibs/dynlink allopt # The lexer @@ -851,14 +910,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 @@ -919,8 +978,8 @@ clean:: $(MAKE) -C runtime clean rm -f stdlib/libcamlrun.$(A) -otherlibs_all := bigarray dynlink graph raw_spacetime_lib \ - str systhreads threads unix win32graph win32unix +otherlibs_all := bigarray dynlink raw_spacetime_lib \ + str systhreads unix win32unix subdirs := debugger lex ocamldoc ocamltest runtime stdlib tools \ $(addprefix otherlibs/, $(otherlibs_all)) \ @@ -1103,10 +1162,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 $@ $^ @@ -1120,9 +1176,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 @@ -1130,9 +1184,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:: @@ -1168,78 +1220,6 @@ else @echo "Architecture tests are disabled on 32-bit platforms." endif -# Compiler Plugins - -DYNLINK_DIR=otherlibs/dynlink - -driver/compdynlink.mlbyte: $(DYNLINK_DIR)/dynlink.ml driver/compdynlink.mli \ - driver/compify_dynlink.sh - driver/compify_dynlink.sh $< $@ - -driver/compdynlink_common.ml: $(DYNLINK_DIR)/dynlink_common.ml \ - driver/compify_dynlink.sh - driver/compify_dynlink.sh $< $@ - -driver/compdynlink_common.mli: $(DYNLINK_DIR)/dynlink_common.mli \ - driver/compify_dynlink.sh - driver/compify_dynlink.sh $< $@ - -driver/compdynlink_types.mli: $(DYNLINK_DIR)/dynlink_types.mli - cp $(DYNLINK_DIR)/dynlink_types.mli driver/compdynlink_types.mli - -driver/compdynlink_types.ml: $(DYNLINK_DIR)/dynlink_types.ml - cp $(DYNLINK_DIR)/dynlink_types.ml driver/compdynlink_types.ml - -driver/compdynlink_platform_intf.ml: $(DYNLINK_DIR)/dynlink_platform_intf.ml \ - driver/compify_dynlink.sh - driver/compify_dynlink.sh $< $@ - -ifeq ($(NATDYNLINK),true) -driver/compdynlink.mlopt: $(DYNLINK_DIR)/natdynlink.ml driver/compdynlink.mli - cat $(DYNLINK_DIR)/natdynlink.ml | \ - sed 's/Dynlink_/Compdynlink_/g' \ - > driver/compdynlink.mlopt -else -driver/compdynlink.mlopt: $(DYNLINK_DIR)/nodynlink.ml driver/compdynlink.mli - cat $(DYNLINK_DIR)/nodynlink.ml | \ - sed 's/Dynlink_/Compdynlink_/g' \ - > driver/compdynlink.mlopt -endif - -driver/compdynlink.mli: $(DYNLINK_DIR)/dynlink.mli \ - driver/compify_dynlink.sh - driver/compify_dynlink.sh $< $@ - -# See comment in otherlibs/dynlink/Makefile about these two rules. -driver/compdynlink_platform_intf.mli: driver/compdynlink_platform_intf.ml - cp $< $@ - -driver/compdynlink.cmo: driver/compdynlink.mlbyte - $(CAMLC) $(COMPFLAGS) -c -impl $< - -driver/compdynlink.cmx: driver/compdynlink.mlopt - $(CAMLOPT) $(COMPFLAGS) -c -impl $< - -beforedepend:: driver/compdynlink.mlbyte \ - driver/compdynlink.mlopt \ - driver/compdynlink_platform_intf.ml \ - driver/compdynlink_platform_intf.mli \ - driver/compdynlink_types.ml \ - driver/compdynlink_types.mli \ - driver/compdynlink.mli \ - driver/compdynlink_common.ml \ - driver/compdynlink_common.mli -partialclean:: - rm -f driver/compdynlink.mlbyte - rm -f driver/compdynlink.mlopt - rm -f driver/compdynlink.mli - rm -f driver/compdynlink_platform_intf.ml - rm -f driver/compdynlink_platform_intf.mli - rm -f driver/compdynlink_common.ml - rm -f driver/compdynlink_common.mli - rm -f driver/compdynlink_types.mli - rm -f driver/compdynlink_types.ml - # The native toplevel compilerlibs/ocamlopttoplevel.cmxa: $(OPTTOPLEVEL:.cmo=.cmx) @@ -1257,6 +1237,7 @@ endif ocamlnat$(EXE): compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ compilerlibs/ocamlbytecomp.cmxa \ + otherlibs/dynlink/dynlink.cmxa \ compilerlibs/ocamlopttoplevel.cmxa \ $(OPTTOPLEVELSTART:.cmo=.cmx) $(CAMLOPT_CMD) $(LINKFLAGS) -linkall -o $@ $^ @@ -1271,13 +1252,17 @@ toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa bytecomp/opcodes.ml: runtime/caml/instruct.h tools/make_opcodes runtime/ocamlrun tools/make_opcodes -opcodes < $< > $@ +bytecomp/opcodes.mli: bytecomp/opcodes.ml + $(CAMLC) -i $< > $@ + tools/make_opcodes: tools/make_opcodes.mll $(MAKE) -C tools make_opcodes partialclean:: rm -f bytecomp/opcodes.ml + rm -f bytecomp/opcodes.mli -beforedepend:: bytecomp/opcodes.ml +beforedepend:: bytecomp/opcodes.ml bytecomp/opcodes.mli ifneq "$(wildcard .git)" "" include Makefile.dev @@ -1297,30 +1282,28 @@ endif $(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/*~; \ + $$d/*.$(O) $$d/*.$(SO); \ done - rm -f *~ .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 - $(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) -native \ - -impl driver/compdynlink.mlopt >> .depend - $(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) -bytecode \ - -impl driver/compdynlink.mlbyte >> .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 rm -f boot/ocamlrun boot/ocamlrun$(EXE) boot/camlheader \ - boot/*.cm* boot/libcamlrun.$(A) + boot/*.cm* boot/libcamlrun.$(A) boot/ocamlc.opt rm -f Makefile.config runtime/caml/m.h runtime/caml/s.h - rm -f Makefile.common config.log config.status libtool rm -f tools/*.bak rm -f ocaml ocamlc rm -f testsuite/_log* diff --git a/Makefile.common.in b/Makefile.common.in index 585aab9d..acd48010 100644 --- a/Makefile.common.in +++ b/Makefile.common.in @@ -35,6 +35,16 @@ else FLEXDLL_SUBMODULE_PRESENT = endif +# Use boot/ocamlc.opt if available +CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun +ifeq (0,$(shell \ + test $(ROOTDIR)/boot/ocamlc.opt -nt $(ROOTDIR)/boot/ocamlc; \ + echo $$?)) + BOOT_OCAMLC = $(ROOTDIR)/boot/ocamlc.opt +else + BOOT_OCAMLC = $(CAMLRUN) $(ROOTDIR)/boot/ocamlc +endif + ifeq "$(FLEXDLL_SUBMODULE_PRESENT)" "" FLEXLINK_ENV = CAMLOPT_CMD = $(CAMLOPT) diff --git a/Makefile.config.in b/Makefile.config.in index 391e469a..3e0bedf7 100644 --- a/Makefile.config.in +++ b/Makefile.config.in @@ -146,24 +146,13 @@ ASPP=@ASPP@ ### Set to "true" to install ".byte" executables (ocamlc.byte, etc.) INSTALL_BYTECODE_PROGRAMS=@install_bytecode_programs@ -### Extra flags to use for assembling .S files in profiling mode -ASPPPROFFLAGS=@asppprofflags@ - -### true if profiling with gprof is supported, false otherwise -PROFILING=@profiling@ - -### Option to give to the C compiler for profiling -CC_PROFILE=@cc_profile@ - ############# Configuration for the contributed libraries ### Which libraries to compile and install # Currently available: # unix Unix system calls # str Regular expressions and high-level string processing -# threads Lightweight concurrent processes # systhreads Same as threads, requires POSIX threads -# graph Portable drawing primitives for X11 # dynlink Dynamic linking of bytecode # bigarray Large, multidimensional numerical arrays OTHERLIBRARIES=@otherlibraries@ @@ -173,18 +162,8 @@ OTHERLIBRARIES=@otherlibraries@ PTHREAD_LINK=@pthread_link@ PTHREAD_CAML_LINK=$(addprefix -cclib ,$(PTHREAD_LINK)) -### -I options for finding the X11/*.h includes -# Needed for the "graph" package -X11_INCDDIR=@x_includes@ -X11_INCLUDES=$(addprefix -I,$(X11_INCDDIR)) - -### Link-time options to ocamlc or ocamlopt for linking with X11 libraries -# Needed for the "graph" package -X11_LINK=@x_libraries@ - UNIX_OR_WIN32=@unix_or_win32@ UNIXLIB=@unixlib@ -GRAPHLIB=@graphlib@ LIBBFD_LINK=@libbfd_link@ LIBBFD_INCLUDE=@libbfd_include@ INSTALL_SOURCE_ARTIFACTS=@install_source_artifacts@ @@ -251,7 +230,20 @@ MAX_TESTSUITE_DIR_RETRIES=@max_testsuite_dir_retries@ FLAT_FLOAT_ARRAY=@flat_float_array@ AWK=@AWK@ -# The following variables were defined only in the config/Makefile.* files. + +### Native command to build ocamlrun.exe + +ifeq "$(TOOLCHAIN)" "msvc" + MERGEMANIFESTEXE=test ! -f $(1).manifest \ + || mt -nologo -outputresource:$(1) -manifest $(1).manifest \ + && rm -f $(1).manifest + MKEXE_BOOT=$(CC) $(OC_CFLAGS) $(OUTPUTEXE)$(1) $(2) \ + /link /subsystem:console $(OC_LDFLAGS) && ($(MERGEMANIFESTEXE)) +else + MKEXE_BOOT=$(CC) $(OC_CFLAGS) $(OC_LDFLAGS) $(OUTPUTEXE)$(1) $(2) +endif # ifeq "$(TOOLCHAIN)" "msvc" + +# The following variables were defined only in the Windows-specific makefiles. # They were not defined by the configure script used on Unix systems, # so we also make sure to provide them only under Windows # User code should absolutely not rely on their presence because @@ -273,18 +265,4 @@ ifeq "$(UNIX_OR_WIN32)" "win32" # (see ocamlmklibconfig.ml in tools/Makefile) FLEXLINK_FLAGS=@flexlink_flags@ FLEXLINK=$(FLEXLINK_CMD) $(FLEXLINK_FLAGS) - - ### Native command to build ocamlrun.exe - - ifeq "$(TOOLCHAIN)" "mingw" - MKEXE_BOOT=$(CC) $(OC_CFLAGS) $(OC_LDFLAGS) $(OUTPUTEXE)$(1) $(2) - endif # ifeq "$(TOOLCHAIN)" "mingw" - - ifeq "$(TOOLCHAIN)" "msvc" - MERGEMANIFESTEXE=test ! -f $(1).manifest \ - || mt -nologo -outputresource:$(1) -manifest $(1).manifest \ - && rm -f $(1).manifest - MKEXE_BOOT=$(CC) $(OC_CFLAGS) $(OUTPUTEXE)$(1) $(2) \ - /link /subsystem:console $(OC_LDFLAGS) && ($(MERGEMANIFESTEXE)) - endif # ifeq "$(TOOLCHAIN)" "msvc" endif # ifeq "$(UNIX_OR_WIN32)" "win32" diff --git a/README.adoc b/README.adoc index 53cd4512..504c7a70 100644 --- a/README.adoc +++ b/README.adoc @@ -1,10 +1,18 @@ |===== -| Branch `trunk` | Branch `4.06` | Branch `4.05` | Branch `4.04` +| Branch `trunk` | Branch `4.08` | Branch `4.07` | Branch `4.06` | Branch `4.05` | image:https://travis-ci.org/ocaml/ocaml.svg?branch=trunk["TravisCI Build Status (trunk branch)", link="https://travis-ci.org/ocaml/ocaml"] image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=trunk&svg=true["AppVeyor Build Status (trunk branch)", link="https://ci.appveyor.com/project/avsm/ocaml"] +| image:https://travis-ci.org/ocaml/ocaml.svg?branch=4.08["TravisCI Build Status (4.08 branch)", + link="https://travis-ci.org/ocaml/ocaml"] + image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=4.08&svg=true["AppVeyor Build Status (4.08 branch)", + link="https://ci.appveyor.com/project/avsm/ocaml"] +| image:https://travis-ci.org/ocaml/ocaml.svg?branch=4.07["TravisCI Build Status (4.07 branch)", + link="https://travis-ci.org/ocaml/ocaml"] + image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=4.07&svg=true["AppVeyor Build Status (4.07 branch)", + link="https://ci.appveyor.com/project/avsm/ocaml"] | image:https://travis-ci.org/ocaml/ocaml.svg?branch=4.06["TravisCI Build Status (4.06 branch)", link="https://travis-ci.org/ocaml/ocaml"] image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=4.06&svg=true["AppVeyor Build Status (4.06 branch)", @@ -13,11 +21,6 @@ link="https://travis-ci.org/ocaml/ocaml"] image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=4.05&svg=true["AppVeyor Build Status (4.05 branch)", link="https://ci.appveyor.com/project/avsm/ocaml"] -| image:https://travis-ci.org/ocaml/ocaml.svg?branch=4.04["TravisCI Build Status (4.04 branch)", - link="https://travis-ci.org/ocaml/ocaml"] - image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=4.04&svg=true["AppVeyor Build Status (4.04 branch)", - link="https://ci.appveyor.com/project/avsm/ocaml"] - |===== = README = @@ -42,35 +45,29 @@ generated programs deliver excellent performance, while retaining the moderate memory requirements of the bytecode compiler. The native-code compiler currently runs on the following platforms: -Tier 1 (actively used and maintained by the core OCaml team): - -AMD64 (Opteron):: Linux, OS X, MS Windows -IA32 (Pentium):: Linux, FreeBSD, OS X, MS Windows -PowerPC:: Linux, OS X -ARM:: Linux +|==== +| | Tier 1 (actively maintained) | Tier 2 (maintained when possible) -Tier 2 (maintained when possible, with help from users): - -AMD64:: FreeBSD, OpenBSD, NetBSD -IA32 (Pentium):: NetBSD, OpenBSD, Solaris 9 -PowerPC:: NetBSD -ARM:: NetBSD +| x86 64 bits | Linux, macOS, Windows, FreeBSD | NetBSD, OpenBSD +| x86 32 bits | Linux, Windows | FreeBSD, NetBSD, OpenBSD +| ARM 64 bits | Linux | FreeBSD +| ARM 32 bits | Linux | FreeBSD, NetBSD, OpenBSD +| Power 64 bits | Linux | +| Power 32 bits | | Linux +| IBM Z (s390x) | Linux | +|==== Other operating systems for the processors above have not been tested, but the compiler may work under other operating systems with little work. -Before the introduction of objects, OCaml was known as Caml Special Light. -OCaml is almost upwards compatible with Caml Special Light, except for a few -additional reserved keywords that have forced some renaming of standard -library functions. == Copyright All files marked "Copyright INRIA" in this distribution are copyright 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 Institut National de -Recherche en Informatique et en Automatique (INRIA) and distributed under -the conditions stated in file LICENSE. +2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 +Institut National de Recherche en Informatique et en Automatique (INRIA) +and distributed under the conditions stated in file LICENSE. == Installation @@ -80,7 +77,7 @@ Windows, see link:README.win32.adoc[]. == Documentation -The OCaml manual is distributed in HTML, PDF, Postscript, DVI, and Emacs +The OCaml manual is distributed in HTML, PDF, and Emacs Info files. It is available at http://caml.inria.fr/pub/docs/manual-ocaml/ @@ -117,14 +114,12 @@ long history and welcomes questions. == Bug Reports and User Feedback -Please report bugs using the Web interface to the bug-tracking system at -http://caml.inria.fr/bin/caml-bugs +Please report bugs using the issue tracker at +https://github.com/ocaml/ocaml/issues To be effective, bug reports should include a complete program (preferably small) that exhibits the unexpected behavior, and the configuration you are using (machine type, etc). -You can also contact the implementors directly at mailto:caml@inria.fr[]. - For information on contributing to OCaml, see link:HACKING.adoc[] and link:CONTRIBUTING.md[]. diff --git a/README.win32.adoc b/README.win32.adoc index 8ad56c88..c8ab81c4 100644 --- a/README.win32.adoc +++ b/README.win32.adoc @@ -21,7 +21,6 @@ Here is a summary of the main differences between these ports: | Replay debugger | yes <> | yes <> | yes | The Unix library | partial | partial | full | The Threads library | yes | yes | yes -| The Graphics library | yes | yes | no | Restrictions on generated executables? | none | none | yes <> |===== @@ -103,6 +102,7 @@ Visual C/C++ Compiler as well as the Build Tools for Visual Studio. | Visual Studio 2013 | 18.00.x.x | 32/64-bit | | Visual Studio 2015 | 19.00.x.x | 32/64-bit | Build Tools for Visual Studio 2015 also provides 32/64-bit compilers | Visual Studio 2017 | 19.10.x.x | 32/64-bit | Build Tools for Visual Studio 2017 also provides 32/64-bit compilers +| Visual Studio 2019 | 19.20.x.x | 32/64-bit | Build Tools for Visual Studio 2019 also provides 32/64-bit compilers |===== [[vs1]] @@ -226,7 +226,7 @@ your `~/.bashrc` file. the performance of bytecode programs is about 2/3 of that obtained under Unix/GCC, Cygwin or Mingw-w64 on similar hardware. -* Libraries available in this port: `bigarray`, `dynlink`, `graphics`, `num`, +* Libraries available in this port: `bigarray`, `dynlink`, `num`, `str`, `threads`, and large parts of `unix`. * The replay debugger is partially supported (no reverse execution). @@ -282,7 +282,7 @@ After installing, you will need to ensure that `ocamlopt` (or `ocamlc -custom`) can access the C compiler. You can do this either by using OCaml from Cygwin's bash or by adding Cygwin's bin directory (e.g. `C:\cygwin\bin`) to your `PATH`. -* Libraries available in this port: `bigarray`, `dynlink`, `graphics`, `num`, +* Libraries available in this port: `bigarray`, `dynlink`, `num`, `str`, `threads`, and large parts of `unix`. * The replay debugger is partially supported (no reverse execution). diff --git a/VERSION b/VERSION index 2c3d7f94..7128cac1 100644 --- a/VERSION +++ b/VERSION @@ -1,4 +1,4 @@ -4.08.1 +4.09.0 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli diff --git a/aclocal.m4 b/aclocal.m4 index 543fff72..ff12869a 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -69,7 +69,6 @@ AC_DEFUN([OCAML_SIGNAL_HANDLERS_SEMANTICS], [ [AC_DEFINE([POSIX_SIGNALS]) AC_MSG_NOTICE([POSIX signal handling found.])], [AC_MSG_NOTICE([assuming signals have the System V semantics.]) - AC_CHECK_FUNCS([sigsetmask], [AC_DEFINE([HAS_SIGSETMASK])]) ] ) ]) diff --git a/asmcomp/CSEgen.ml b/asmcomp/CSEgen.ml index 09ecca70..d71198ad 100644 --- a/asmcomp/CSEgen.ml +++ b/asmcomp/CSEgen.ml @@ -347,9 +347,6 @@ method private cse n i = let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in {i with desc = Iswitch(index, Array.map (self#cse n1) cases); next = self#cse empty_numbering i.next} - | Iloop(body) -> - {i with desc = Iloop(self#cse empty_numbering body); - next = self#cse empty_numbering i.next} | Icatch(rec_flag, handlers, body) -> let aux (nfail, handler) = nfail, self#cse empty_numbering handler diff --git a/asmcomp/afl_instrument.ml b/asmcomp/afl_instrument.ml index 8397c30d..9e008411 100644 --- a/asmcomp/afl_instrument.ml +++ b/asmcomp/afl_instrument.ml @@ -20,11 +20,11 @@ open Cmm module V = Backend_var module VP = Backend_var.With_provenance -let afl_area_ptr = Cconst_symbol "caml_afl_area_ptr" -let afl_prev_loc = Cconst_symbol "caml_afl_prev_loc" +let afl_area_ptr dbg = Cconst_symbol ("caml_afl_area_ptr", dbg) +let afl_prev_loc dbg = Cconst_symbol ("caml_afl_prev_loc", dbg) let afl_map_size = 1 lsl 16 -let rec with_afl_logging b = +let rec with_afl_logging b dbg = if !Clflags.afl_inst_ratio < 100 && Random.int 100 >= !Clflags.afl_inst_ratio then instrument b else let instrumentation = @@ -40,31 +40,36 @@ let rec with_afl_logging b = let cur_location = Random.int afl_map_size in let cur_pos = V.create_local "pos" in let afl_area = V.create_local "shared_mem" in - let op oper args = Cop (oper, args, Debuginfo.none) in + let op oper args = Cop (oper, args, dbg) in Clet(VP.create afl_area, - op (Cload (Word_int, Asttypes.Mutable)) [afl_area_ptr], + op (Cload (Word_int, Asttypes.Mutable)) [afl_area_ptr dbg], Clet(VP.create cur_pos, op Cxor [op (Cload (Word_int, Asttypes.Mutable)) - [afl_prev_loc]; Cconst_int cur_location], + [afl_prev_loc dbg]; Cconst_int (cur_location, dbg)], Csequence( op (Cstore(Byte_unsigned, Assignment)) [op Cadda [Cvar afl_area; Cvar cur_pos]; op Cadda [op (Cload (Byte_unsigned, Asttypes.Mutable)) [op Cadda [Cvar afl_area; Cvar cur_pos]]; - Cconst_int 1]], + Cconst_int (1, dbg)]], op (Cstore(Word_int, Assignment)) - [afl_prev_loc; Cconst_int (cur_location lsr 1)]))) in + [afl_prev_loc dbg; Cconst_int (cur_location lsr 1, dbg)]))) in Csequence(instrumentation, instrument b) and instrument = function (* these cases add logging, as they may be targets of conditional branches *) - | Cifthenelse (cond, t, f) -> - Cifthenelse (instrument cond, with_afl_logging t, with_afl_logging f) - | Cloop e -> - Cloop (with_afl_logging e) - | Ctrywith (e, ex, handler) -> - Ctrywith (instrument e, ex, with_afl_logging handler) + | Cifthenelse (cond, t_dbg, t, f_dbg, f, dbg) -> + Cifthenelse (instrument cond, t_dbg, with_afl_logging t t_dbg, + f_dbg, with_afl_logging f f_dbg, dbg) + | Ctrywith (e, ex, handler, dbg) -> + Ctrywith (instrument e, ex, with_afl_logging handler dbg, dbg) | Cswitch (e, cases, handlers, dbg) -> - Cswitch (instrument e, cases, Array.map with_afl_logging handlers, dbg) + let handlers = + Array.map (fun (handler, handler_dbg) -> + let handler = with_afl_logging handler handler_dbg in + handler, handler_dbg) + handlers + in + Cswitch (instrument e, cases, handlers, dbg) (* these cases add no logging, but instrument subexpressions *) | Clet (v, e, body) -> Clet (v, instrument e, instrument body) @@ -75,9 +80,11 @@ and instrument = function | Cop (op, es, dbg) -> Cop (op, List.map instrument es, dbg) | Csequence (e1, e2) -> Csequence (instrument e1, instrument e2) | Ccatch (isrec, cases, body) -> - Ccatch (isrec, - List.map (fun (nfail, ids, e) -> nfail, ids, instrument e) cases, - instrument body) + let cases = + List.map (fun (nfail, ids, e, dbg) -> nfail, ids, instrument e, dbg) + cases + in + Ccatch (isrec, cases, instrument body) | Cexit (ex, args) -> Cexit (ex, List.map instrument args) (* these are base cases and have no logging *) @@ -85,16 +92,17 @@ and instrument = function | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ | Cblockheader _ | Cvar _ as c -> c -let instrument_function c = - with_afl_logging c +let instrument_function c dbg = + with_afl_logging c dbg -let instrument_initialiser c = +let instrument_initialiser c dbg = (* Each instrumented module calls caml_setup_afl at initialisation, which is a no-op on the second and subsequent calls *) with_afl_logging (Csequence (Cop (Cextcall ("caml_setup_afl", typ_int, false, None), - [Cconst_int 0], - Debuginfo.none), + [Cconst_int (0, dbg ())], + dbg ()), c)) + (dbg ()) diff --git a/asmcomp/afl_instrument.mli b/asmcomp/afl_instrument.mli index 1eb439b2..c98cbcd1 100644 --- a/asmcomp/afl_instrument.mli +++ b/asmcomp/afl_instrument.mli @@ -1,4 +1,21 @@ -(* Instrumentation for afl-fuzz *) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Stephen Dolan, University of Cambridge *) +(* *) +(* Copyright 2016 Stephen Dolan. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) -val instrument_function : Cmm.expression -> Cmm.expression -val instrument_initialiser : Cmm.expression -> Cmm.expression +(** Instrumentation for afl-fuzz. *) + +val instrument_function : Cmm.expression -> Debuginfo.t -> Cmm.expression +val instrument_initialiser + : Cmm.expression + -> (unit -> Debuginfo.t) + -> Cmm.expression diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 4acbd694..e5b42b83 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -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 @@ -73,9 +74,6 @@ let stack_offset = ref 0 (* Layout of the stack frame *) -let frame_required () = - fp || !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0 - let frame_size () = (* includes return address *) if frame_required() then begin let sz = @@ -473,23 +471,6 @@ let emit_global_label s = D.global lbl; _label lbl -(* Emission of the profiling prelude *) - -let emit_profile () = - if system = S_gnu || system = S_linux then begin - (* mcount preserves rax, rcx, rdx, rsi, rdi, r8, r9 explicitly - and rbx, rbp, r12-r15 like all C functions. This includes - all the registers used for argument passing, so we don't - need to preserve other regs. We do need to initialize rbp - like mcount expects it, though. *) - I.push r10; - if not fp then I.mov rsp rbp; - (* No Spacetime instrumentation needed: [mcount] cannot call anything - OCaml-related. *) - emit_call "mcount"; - I.pop r10 - end - (* Output the assembly code for an instruction *) (* Name of current function *) @@ -503,12 +484,12 @@ let emit_instr fallthrough i = match i.desc with | Lend -> () | Lprologue -> + assert (Proc.prologue_required ()); if fp then begin I.push rbp; cfi_adjust_cfa_offset 8; I.mov rsp rbp; end; - if !Clflags.gprofile then emit_profile(); if frame_required() then begin let n = frame_size() - 8 - (if fp then 8 else 0) in if n <> 0 @@ -516,8 +497,7 @@ let emit_instr fallthrough i = I.sub (int n) rsp; cfi_adjust_cfa_offset n; end; - end; - def_label !tailrec_entry_point + end | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in if src.loc <> dst.loc then @@ -865,14 +845,22 @@ let emit_instr fallthrough i = ConstLabel lbl)) done; D.text () - | Lsetuptrap lbl -> - I.call (label lbl) - | Lpushtrap -> - cfi_adjust_cfa_offset 8; - I.push r14; - cfi_adjust_cfa_offset 8; - I.mov rsp r14; - stack_offset := !stack_offset + 16 + | Lentertrap -> + () + | Lpushtrap { lbl_handler; } -> + let load_label_addr s arg = + if !Clflags.pic_code then + I.lea (mem64_rip NONE (emit_label s)) arg + else + I.mov (sym (emit_label s)) arg + in + cfi_adjust_cfa_offset 16; + I.sub (int 16) rsp; + stack_offset := !stack_offset + 16; + I.mov r14 (mem64 QWORD 0 RSP); + load_label_addr lbl_handler r14; + I.mov r14 (mem64 QWORD 8 RSP); + I.mov rsp r14 | Lpoptrap -> I.pop r14; cfi_adjust_cfa_offset (-8); @@ -890,7 +878,8 @@ let emit_instr fallthrough i = | Cmm.Raise_notrace -> I.mov r14 rsp; I.pop r14; - I.ret () + I.pop r11; + I.jmp r11 end let rec emit_all fallthrough i = @@ -907,7 +896,7 @@ let all_functions = ref [] let fundecl fundecl = function_name := fundecl.fun_name; fastcode_flag := fundecl.fun_fast; - tailrec_entry_point := new_label(); + tailrec_entry_point := fundecl.fun_tailrec_entry_point_label; stack_offset := 0; call_gc_sites := []; bound_error_sites := []; diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index db94a476..4c3c636b 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -377,6 +377,12 @@ let op_is_pure = function let num_stack_slots = [| 0; 0 |] let contains_calls = ref false +let frame_required () = + fp || !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0 + +let prologue_required () = + frame_required () + (* Calling the assembler *) let assemble_file infile outfile = diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index db7ee0a6..3fd47b7b 100644 --- a/asmcomp/amd64/selection.ml +++ b/asmcomp/amd64/selection.ml @@ -31,25 +31,25 @@ type addressing_expr = let rec select_addr exp = match exp with - Cconst_symbol s when not !Clflags.dlcode -> + Cconst_symbol (s, _) when not !Clflags.dlcode -> (Asymbol s, 0) - | Cop((Caddi | Caddv | Cadda), [arg; Cconst_int m], _) -> + | Cop((Caddi | Caddv | Cadda), [arg; Cconst_int (m, _)], _) -> let (a, n) = select_addr arg in (a, n + m) - | Cop(Csubi, [arg; Cconst_int m], _) -> + | Cop(Csubi, [arg; Cconst_int (m, _)], _) -> let (a, n) = select_addr arg in (a, n - m) - | Cop((Caddi | Caddv | Cadda), [Cconst_int m; arg], _) -> + | Cop((Caddi | Caddv | Cadda), [Cconst_int (m, _); arg], _) -> let (a, n) = select_addr arg in (a, n + m) - | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)], _) -> + | Cop(Clsl, [arg; Cconst_int((1|2|3 as shift), _)], _) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift) | _ -> (Alinear exp, 0) end - | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)], _) -> + | Cop(Cmuli, [arg; Cconst_int((2|4|8 as mult), _)], _) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, mult), n * mult) | _ -> (Alinear exp, 0) end - | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg], _) -> + | Cop(Cmuli, [Cconst_int((2|4|8 as mult), _); arg], _) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, mult), n * mult) | _ -> (Alinear exp, 0) @@ -169,16 +169,16 @@ method select_addressing _chunk exp = method! select_store is_assign addr exp = match exp with - Cconst_int n when self#is_immediate n -> + Cconst_int (n, _dbg) when self#is_immediate n -> (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) - | (Cconst_natint n) when self#is_immediate_natint n -> + | (Cconst_natint (n, _dbg)) when self#is_immediate_natint n -> (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | (Cblockheader(n, _dbg)) when self#is_immediate_natint n && not Config.spacetime -> (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) - | Cconst_pointer n when self#is_immediate n -> + | Cconst_pointer (n, _dbg) when self#is_immediate n -> (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) - | Cconst_natpointer n when self#is_immediate_natint n -> + | Cconst_natpointer (n, _dbg) when self#is_immediate_natint n -> (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | _ -> super#select_store is_assign addr exp @@ -214,7 +214,7 @@ method! select_operation op args dbg = (* Recognize store instructions *) | Cstore ((Word_int|Word_val as chunk), _init) -> begin match args with - [loc; Cop(Caddi, [Cop(Cload _, [loc'], _); Cconst_int n], _)] + [loc; Cop(Caddi, [Cop(Cload _, [loc'], _); Cconst_int (n, _dbg)], _)] when loc = loc' && self#is_immediate n -> let (addr, arg) = self#select_addressing chunk loc in (Ispecific(Ioffset_loc(n, addr)), [arg]) @@ -234,7 +234,7 @@ method! select_operation op args dbg = | Casr -> begin match args with (* Recognize sign extension *) - [Cop(Clsl, [k; Cconst_int 32], _); Cconst_int 32] -> + [Cop(Clsl, [k; Cconst_int (32, _)], _); Cconst_int (32, _)] -> (Ispecific Isextend32, [k]) | _ -> super#select_operation op args dbg end @@ -263,15 +263,15 @@ method! mark_c_tailcall = (* Deal with register constraints *) -method! insert_op_debug op dbg rs rd = +method! insert_op_debug env op dbg rs rd = try let (rsrc, rdst) = pseudoregs_for_operation op rs rd in - self#insert_moves rs rsrc; - self#insert_debug (Iop op) dbg rsrc rdst; - self#insert_moves rdst rd; + self#insert_moves env rs rsrc; + self#insert_debug env (Iop op) dbg rsrc rdst; + self#insert_moves env rdst rd; rd with Use_default -> - super#insert_op_debug op dbg rs rd + super#insert_op_debug env op dbg rs rd end diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index a523fbb9..00d01748 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -285,6 +285,14 @@ let symbol_literals = ref ([] : (string * label) list) (* Total space (in words) occupied by pending literals *) let size_literals = ref 0 +(* Pending offset computations : {lbl; dst; src;} --> lbl: .word dst-(src+N) *) +type offset_computation = + { lbl : label; + dst : label; + src : label; + } +let offset_literals = ref ([] : offset_computation list) + (* Label a floating-point literal *) let float_literal f = try @@ -312,6 +320,13 @@ let symbol_literal s = symbol_literals := (s, lbl) :: !symbol_literals; lbl +(* Add an offset computation *) +let offset_literal dst src = + let lbl = new_label() in + size_literals := !size_literals + 1; + offset_literals := { lbl; dst; src; } :: !offset_literals; + lbl + (* Emit all pending literals *) let emit_literals() = if !float_literals <> [] then begin @@ -337,6 +352,20 @@ let emit_literals() = gotrel_literals := []; symbol_literals := [] end; + if !offset_literals <> [] then begin + (* Additions using the pc register read a value 4 or 8 bytes greater than + the instruction's address, depending on the Thumb setting. However in + Thumb mode we must follow interworking conventions and ensure that the + bottom bit of the pc value is set when reloaded from the trap frame. + Hence "3" not "4". *) + let offset = if !thumb then 3 else 8 in + ` .align 2\n`; + List.iter + (fun { lbl; dst; src; } -> + `{emit_label lbl}: .word {emit_label dst}-({emit_label src}+{emit_int offset})\n`) + !offset_literals; + offset_literals := [] + end; size_literals := 0 (* Emit code to load the address of a symbol *) @@ -396,15 +425,15 @@ let emit_set_condition cmp rd = end end -(* Emission of the profiling prelude *) - -let emit_profile() = - match Config.system with - "linux_eabi" | "linux_eabihf" | "netbsd" -> - ` push \{lr}\n`; - ` {emit_call "__gnu_mcount_nc"}\n`; - 2 - | _ -> 0 +(* Emit code to load the address of a label in the lr register *) +let emit_load_handler_address handler = + (* PIC code *) + let lbl_src = new_label() in + let lbl_offset = offset_literal handler lbl_src in + ` ldr lr, {emit_label lbl_offset}\n`; + `{emit_label lbl_src}:\n`; + ` add lr, pc, lr\n`; + 2 (* Output the assembly code for an instruction *) @@ -413,12 +442,9 @@ let emit_instr i = match i.desc with | Lend -> 0 | Lprologue -> - let num_instrs0 = - if !Clflags.gprofile then emit_profile() - else 0 - in + assert (Proc.prologue_required ()); let n = frame_size() in - let num_instrs1 = + let num_instrs = if n > 0 then begin let num_instrs = emit_stack_adjustment (-n) in if !contains_calls then begin @@ -433,7 +459,7 @@ let emit_instr i = end in `{emit_label !tailrec_entry_point}:\n`; - num_instrs0 + num_instrs1 + num_instrs | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in if src.loc = dst.loc then 0 else begin @@ -838,13 +864,14 @@ let emit_instr i = done; 2 + Array.length jumptbl end - | Lsetuptrap lbl -> - ` bl {emit_label lbl}\n`; 1 - | Lpushtrap -> + | Lentertrap -> + 0 + | Lpushtrap { lbl_handler; } -> + let s = emit_load_handler_address lbl_handler in stack_offset := !stack_offset + 8; ` push \{trap_ptr, lr}\n`; cfi_adjust_cfa_offset 8; - ` mov trap_ptr, sp\n`; 2 + ` mov trap_ptr, sp\n`; s + 2 | Lpoptrap -> ` pop \{trap_ptr, lr}\n`; cfi_adjust_cfa_offset (-8); @@ -905,7 +932,7 @@ let rec emit_all ninstr fallthrough i = let fundecl fundecl = function_name := fundecl.fun_name; fastcode_flag := fundecl.fun_fast; - tailrec_entry_point := new_label(); + tailrec_entry_point := fundecl.fun_tailrec_entry_point_label; float_literals := []; gotrel_literals := []; symbol_literals := []; diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml index 1622fa49..8ad7bebc 100644 --- a/asmcomp/arm/proc.ml +++ b/asmcomp/arm/proc.ml @@ -345,6 +345,15 @@ let op_is_pure = function let num_stack_slots = [| 0; 0; 0 |] let contains_calls = ref false +let frame_required () = + !contains_calls + || num_stack_slots.(0) > 0 + || num_stack_slots.(1) > 0 + || num_stack_slots.(2) > 0 + +let prologue_required () = + frame_required () + (* Calling the assembler *) let assemble_file infile outfile = diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml index 747e86a2..f43c13d9 100644 --- a/asmcomp/arm/selection.ml +++ b/asmcomp/arm/selection.ml @@ -131,10 +131,11 @@ method! effects_of e = | e -> super#effects_of e method select_addressing chunk = function - | Cop((Cadda | Caddv), [arg; Cconst_int n], _) + | Cop((Cadda | Caddv), [arg; Cconst_int (n, _)], _) when is_offset chunk n -> (Iindexed n, arg) - | Cop((Cadda | Caddv as op), [arg1; Cop(Caddi, [arg2; Cconst_int n], _)], dbg) + | Cop((Cadda | Caddv as op), + [arg1; Cop(Caddi, [arg2; Cconst_int (n, _)], _)], dbg) when is_offset chunk n -> (Iindexed n, Cop(op, [arg1; arg2], dbg)) | arg -> @@ -142,10 +143,10 @@ method select_addressing chunk = function method select_shift_arith op dbg arithop arithrevop args = match args with - [arg1; Cop(Clsl | Clsr | Casr as op, [arg2; Cconst_int n], _)] + [arg1; Cop(Clsl | Clsr | Casr as op, [arg2; Cconst_int (n, _)], _)] when n > 0 && n < 32 -> (Ispecific(Ishiftarith(arithop, select_shiftop op, n)), [arg1; arg2]) - | [Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int n], _); arg2] + | [Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int (n, _)], _); arg2] when n > 0 && n < 32 -> (Ispecific(Ishiftarith(arithrevop, select_shiftop op, n)), [arg2; arg1]) | args -> @@ -184,15 +185,15 @@ method private iextcall (func, alloc) = method! select_operation op args dbg = match (op, args) with (* Recognize special shift arithmetic *) - ((Caddv | Cadda | Caddi), [arg; Cconst_int n]) + ((Caddv | Cadda | Caddi), [arg; Cconst_int (n, _)]) when n < 0 && self#is_immediate (-n) -> (Iintop_imm(Isub, -n), [arg]) | ((Caddv | Cadda | Caddi as op), args) -> self#select_shift_arith op dbg Ishiftadd Ishiftadd args - | (Csubi, [arg; Cconst_int n]) + | (Csubi, [arg; Cconst_int (n, _)]) when n < 0 && self#is_immediate (-n) -> (Iintop_imm(Iadd, -n), [arg]) - | (Csubi, [Cconst_int n; arg]) + | (Csubi, [Cconst_int (n, _); arg]) when self#is_immediate n -> (Ispecific(Irevsubimm n), [arg]) | (Csubi as op, args) -> @@ -204,7 +205,7 @@ method! select_operation op args dbg = | (Cxor as op, args) -> self#select_shift_arith op dbg Ishiftxor Ishiftxor args | (Ccheckbound, - [Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int n], _); arg2]) + [Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int (n, _)], _); arg2]) when n > 0 && n < 32 -> (Ispecific(Ishiftcheckbound(select_shiftop op, n)), [arg1; arg2]) (* ARM does not support immediate operands for multiplication *) @@ -304,15 +305,15 @@ method! select_condition = function (* Deal with some register constraints *) -method! insert_op_debug op dbg rs rd = +method! insert_op_debug env op dbg rs rd = try let (rsrc, rdst) = pseudoregs_for_operation op rs rd in - self#insert_moves rs rsrc; - self#insert_debug (Iop op) dbg rsrc rdst; - self#insert_moves rdst rd; + self#insert_moves env rs rsrc; + self#insert_debug env (Iop op) dbg rsrc rdst; + self#insert_moves env rdst rd; rd with Use_default -> - super#insert_op_debug op dbg rs rd + super#insert_op_debug env op dbg rs rd end diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp index 58792663..a00cbced 100644 --- a/asmcomp/arm64/emit.mlp +++ b/asmcomp/arm64/emit.mlp @@ -494,8 +494,8 @@ module BR = Branch_relaxation.Make (struct + begin match lbl1 with None -> 0 | Some _ -> 1 end + begin match lbl2 with None -> 0 | Some _ -> 1 end | Lswitch jumptbl -> 3 + Array.length jumptbl - | Lsetuptrap _ -> 2 - | Lpushtrap -> 3 + | Lentertrap -> 0 + | Lpushtrap _ -> 4 | Lpoptrap -> 1 | Lraise k -> begin match k with @@ -559,17 +559,6 @@ let assembly_code_for_allocation ?label_after_call_gc i ~n ~far = `{emit_label lbl_frame}: add {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n` end -(* Emission of the profiling prelude *) - -let emit_profile() = () (* TODO *) -(* - match Config.system with - "linux_eabi" | "linux_eabihf" | "netbsd" -> - ` push \{lr}\n`; - ` {emit_call "__gnu_mcount_nc"}\n` - | _ -> () -*) - (* Output the assembly code for an instruction *) let emit_instr i = @@ -577,15 +566,14 @@ let emit_instr i = match i.desc with | Lend -> () | Lprologue -> - if !Clflags.gprofile then emit_profile(); + assert (Proc.prologue_required ()); let n = frame_size() in if n > 0 then emit_stack_adjustment (-n); if !contains_calls then begin cfi_offset ~reg:30 (* return address *) ~offset:(-8); ` str x30, [sp, #{emit_int (n-8)}]\n` - end; - `{emit_label !tailrec_entry_point}:\n`; + end | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in if src.loc <> dst.loc then begin @@ -607,7 +595,7 @@ let emit_instr i = if f = 0L then ` fmov {emit_reg i.res.(0)}, xzr\n` else if is_immediate_float f then - ` fmov {emit_reg i.res.(0)}, #{emit_printf "0x%Lx" f}\n` + ` fmov {emit_reg i.res.(0)}, #{emit_printf "%.7f" (Int64.float_of_bits f)}\n` else begin let lbl = float_literal f in ` adrp {emit_reg reg_tmp1}, {emit_label lbl}\n`; @@ -873,12 +861,10 @@ let emit_instr i = ` .word {emit_label jumptbl.(j)} - {emit_label lbltbl}\n` done *) - | Lsetuptrap lbl -> - let lblnext = new_label() in - ` adr {emit_reg reg_tmp1}, {emit_label lblnext}\n`; - ` b {emit_label lbl}\n`; - `{emit_label lblnext}:\n` - | Lpushtrap -> + | Lentertrap -> + () + | Lpushtrap { lbl_handler; } -> + ` adr {emit_reg reg_tmp1}, {emit_label lbl_handler}\n`; stack_offset := !stack_offset + 16; ` str {emit_reg reg_trap_ptr}, [sp, -16]!\n`; ` str {emit_reg reg_tmp1}, [sp, #8]\n`; @@ -910,7 +896,7 @@ let rec emit_all i = let fundecl fundecl = function_name := fundecl.fun_name; fastcode_flag := fundecl.fun_fast; - tailrec_entry_point := new_label(); + tailrec_entry_point := fundecl.fun_tailrec_entry_point_label; float_literals := []; stack_offset := 0; call_gc_sites := []; diff --git a/asmcomp/arm64/proc.ml b/asmcomp/arm64/proc.ml index 14ba08d5..095f22f2 100644 --- a/asmcomp/arm64/proc.ml +++ b/asmcomp/arm64/proc.ml @@ -254,6 +254,14 @@ let op_is_pure = function let num_stack_slots = [| 0; 0 |] let contains_calls = ref false +let frame_required () = + !contains_calls + || num_stack_slots.(0) > 0 + || num_stack_slots.(1) > 0 + +let prologue_required () = + frame_required () + (* Calling the assembler *) let assemble_file infile outfile = diff --git a/asmcomp/arm64/selection.ml b/asmcomp/arm64/selection.ml index b714d003..90166141 100644 --- a/asmcomp/arm64/selection.ml +++ b/asmcomp/arm64/selection.ml @@ -109,16 +109,17 @@ method! effects_of e = | e -> super#effects_of e method select_addressing chunk = function - | Cop((Caddv | Cadda), [Cconst_symbol s; Cconst_int n], _) + | Cop((Caddv | Cadda), [Cconst_symbol (s, _); Cconst_int (n, _)], _) when use_direct_addressing s -> (Ibased(s, n), Ctuple []) - | Cop((Caddv | Cadda), [arg; Cconst_int n], _) + | Cop((Caddv | Cadda), [arg; Cconst_int (n, _)], _) when is_offset chunk n -> (Iindexed n, arg) - | Cop((Caddv | Cadda as op), [arg1; Cop(Caddi, [arg2; Cconst_int n], _)], dbg) + | Cop((Caddv | Cadda as op), + [arg1; Cop(Caddi, [arg2; Cconst_int (n, _)], _)], dbg) when is_offset chunk n -> (Iindexed n, Cop(op, [arg1; arg2], dbg)) - | Cconst_symbol s + | Cconst_symbol (s, _) when use_direct_addressing s -> (Ibased(s, 0), Ctuple []) | arg -> @@ -130,20 +131,20 @@ method! select_operation op args dbg = | Caddi | Caddv | Cadda -> begin match args with (* Add immediate *) - | [arg; Cconst_int n] when self#is_immediate n -> + | [arg; Cconst_int (n, _)] when self#is_immediate n -> ((if n >= 0 then Iintop_imm(Iadd, n) else Iintop_imm(Isub, -n)), [arg]) - | [Cconst_int n; arg] when self#is_immediate n -> + | [Cconst_int (n, _); arg] when self#is_immediate n -> ((if n >= 0 then Iintop_imm(Iadd, n) else Iintop_imm(Isub, -n)), [arg]) (* Shift-add *) - | [arg1; Cop(Clsl, [arg2; Cconst_int n], _)] when n > 0 && n < 64 -> + | [arg1; Cop(Clsl, [arg2; Cconst_int (n, _)], _)] when n > 0 && n < 64 -> (Ispecific(Ishiftarith(Ishiftadd, n)), [arg1; arg2]) - | [arg1; Cop(Casr, [arg2; Cconst_int n], _)] when n > 0 && n < 64 -> + | [arg1; Cop(Casr, [arg2; Cconst_int (n, _)], _)] when n > 0 && n < 64 -> (Ispecific(Ishiftarith(Ishiftadd, -n)), [arg1; arg2]) - | [Cop(Clsl, [arg1; Cconst_int n], _); arg2] when n > 0 && n < 64 -> + | [Cop(Clsl, [arg1; Cconst_int (n, _)], _); arg2] when n > 0 && n < 64 -> (Ispecific(Ishiftarith(Ishiftadd, n)), [arg2; arg1]) - | [Cop(Casr, [arg1; Cconst_int n], _); arg2] when n > 0 && n < 64 -> + | [Cop(Casr, [arg1; Cconst_int (n, _)], _); arg2] when n > 0 && n < 64 -> (Ispecific(Ishiftarith(Ishiftadd, -n)), [arg2; arg1]) (* Multiply-add *) | [arg1; Cop(Cmuli, args2, dbg)] | [Cop(Cmuli, args2, dbg); arg1] -> @@ -162,13 +163,13 @@ method! select_operation op args dbg = | Csubi -> begin match args with (* Sub immediate *) - | [arg; Cconst_int n] when self#is_immediate n -> + | [arg; Cconst_int (n, _)] when self#is_immediate n -> ((if n >= 0 then Iintop_imm(Isub, n) else Iintop_imm(Iadd, -n)), [arg]) (* Shift-sub *) - | [arg1; Cop(Clsl, [arg2; Cconst_int n], _)] when n > 0 && n < 64 -> + | [arg1; Cop(Clsl, [arg2; Cconst_int (n, _)], _)] when n > 0 && n < 64 -> (Ispecific(Ishiftarith(Ishiftsub, n)), [arg1; arg2]) - | [arg1; Cop(Casr, [arg2; Cconst_int n], _)] when n > 0 && n < 64 -> + | [arg1; Cop(Casr, [arg2; Cconst_int (n, _)], _)] when n > 0 && n < 64 -> (Ispecific(Ishiftarith(Ishiftsub, -n)), [arg1; arg2]) (* Multiply-sub *) | [arg1; Cop(Cmuli, args2, dbg)] -> @@ -186,7 +187,7 @@ method! select_operation op args dbg = (* Checkbounds *) | Ccheckbound -> begin match args with - | [Cop(Clsr, [arg1; Cconst_int n], _); arg2] when n > 0 && n < 64 -> + | [Cop(Clsr, [arg1; Cconst_int (n, _)], _); arg2] when n > 0 && n < 64 -> (Ispecific(Ishiftcheckbound { shift = n; label_after_error = None; }), [arg1; arg2]) | _ -> @@ -242,9 +243,9 @@ method! select_operation op args dbg = super#select_operation op args dbg method select_logical op = function - | [arg; Cconst_int n] when is_logical_immediate n -> + | [arg; Cconst_int (n, _)] when is_logical_immediate n -> (Iintop_imm(op, n), [arg]) - | [Cconst_int n; arg] when is_logical_immediate n -> + | [Cconst_int (n, _); arg] when is_logical_immediate n -> (Iintop_imm(op, n), [arg]) | args -> (Iintop op, args) diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index ddbbae8d..46f7b270 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -102,6 +102,7 @@ let (++) x f = f x let compile_fundecl ~ppf_dump fd_cmm = Proc.init (); + Cmmgen.reset (); Reg.reset(); fd_cmm ++ Profile.record ~accumulate:true "selection" Selection.fundecl @@ -220,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 = @@ -239,8 +242,9 @@ let lambda_gen_implementation ?toplevel ~ppf_dump } in let clambda_and_constants = - clambda, [preallocated_block], [] + clambda, [preallocated_block], Compilenv.structured_constants () in + Compilenv.clear_structured_constants (); raw_clambda_dump_if ppf_dump clambda_and_constants; end_gen_implementation ?toplevel ~ppf_dump clambda_and_constants @@ -257,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) = diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli index f2f4ccae..16045621 100644 --- a/asmcomp/asmgen.mli +++ b/asmcomp/asmgen.mli @@ -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 : diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index f77b6cc3..8c4457c8 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -23,23 +23,26 @@ open Compilenv module String = Misc.Stdlib.String type error = - File_not_found of string - | Not_an_object_file of string - | Missing_implementations of (string * string list) list - | Inconsistent_interface of string * string * string - | Inconsistent_implementation of string * string * string - | Assembler_error of string + | File_not_found of filepath + | Not_an_object_file of filepath + | Missing_implementations of (modname * string list) list + | Inconsistent_interface of modname * filepath * filepath + | Inconsistent_implementation of modname * filepath * filepath + | Assembler_error of filepath | Linking_error - | Multiple_definition of string * string * string - | Missing_cmx of string * string + | Multiple_definition of modname * filepath * filepath + | Missing_cmx of filepath * modname exception Error of error (* Consistency check between interfaces and implementations *) -let crc_interfaces = Consistbl.create () +module Cmi_consistbl = Consistbl.Make (Misc.Stdlib.String) +let crc_interfaces = Cmi_consistbl.create () let interfaces = ref ([] : string list) -let crc_implementations = Consistbl.create () + +module Cmx_consistbl = Consistbl.Make (Misc.Stdlib.String) +let crc_implementations = Cmx_consistbl.create () let implementations = ref ([] : string list) let implementations_defined = ref ([] : (string * string) list) let cmx_required = ref ([] : string list) @@ -53,10 +56,10 @@ let check_consistency file_name unit crc = None -> () | Some crc -> if name = unit.ui_name - then Consistbl.set crc_interfaces name crc file_name - else Consistbl.check crc_interfaces name crc file_name) + then Cmi_consistbl.set crc_interfaces name crc file_name + else Cmi_consistbl.check crc_interfaces name crc file_name) unit.ui_imports_cmi - with Consistbl.Inconsistency(name, user, auth) -> + with Cmi_consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_interface(name, user, auth))) end; begin try @@ -68,9 +71,9 @@ let check_consistency file_name unit crc = if List.mem name !cmx_required then raise(Error(Missing_cmx(file_name, name))) | Some crc -> - Consistbl.check crc_implementations name crc file_name) + Cmx_consistbl.check crc_implementations name crc file_name) unit.ui_imports_cmx - with Consistbl.Inconsistency(name, user, auth) -> + with Cmx_consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_implementation(name, user, auth))) end; begin try @@ -79,16 +82,16 @@ let check_consistency file_name unit crc = with Not_found -> () end; implementations := unit.ui_name :: !implementations; - Consistbl.set crc_implementations unit.ui_name crc file_name; + Cmx_consistbl.set crc_implementations unit.ui_name crc file_name; implementations_defined := (unit.ui_name, file_name) :: !implementations_defined; if unit.ui_symbol <> unit.ui_name then cmx_required := unit.ui_name :: !cmx_required let extract_crc_interfaces () = - Consistbl.extract !interfaces crc_interfaces + Cmi_consistbl.extract !interfaces crc_interfaces let extract_crc_implementations () = - Consistbl.extract !implementations crc_implementations + Cmx_consistbl.extract !implementations crc_implementations (* Add C objects and options and "custom" info from a library descriptor. See bytecomp/bytelink.ml for comments on the order of C objects. *) @@ -106,12 +109,9 @@ let add_ccobjs origin l = end let runtime_lib () = - let libname = - if !Clflags.gprofile - then "libasmrunp" ^ ext_lib - else "libasmrun" ^ !Clflags.runtime_variant ^ ext_lib in + let libname = "libasmrun" ^ !Clflags.runtime_variant ^ ext_lib in try - if !Clflags.nopervasives then [] + if !Clflags.nopervasives || not !Clflags.with_runtime then [] else [ Load_path.find libname ] with Not_found -> raise(Error(File_not_found libname)) @@ -328,10 +328,8 @@ let call_linker file_list startup_file output_name = let link ~ppf_dump objfiles output_name = Profile.record_call output_name (fun () -> - let stdlib = - if !Clflags.gprofile then "stdlib.p.cmxa" else "stdlib.cmxa" in - let stdexit = - if !Clflags.gprofile then "std_exit.p.cmx" else "std_exit.cmx" in + let stdlib = "stdlib.cmxa" in + let stdexit = "std_exit.cmx" in let objfiles = if !Clflags.nopervasives then objfiles else if !Clflags.output_c_object then stdlib :: objfiles @@ -431,8 +429,8 @@ let () = ) let reset () = - Consistbl.clear crc_interfaces; - Consistbl.clear crc_implementations; + Cmi_consistbl.clear crc_interfaces; + Cmx_consistbl.clear crc_implementations; implementations_defined := []; cmx_required := []; interfaces := []; diff --git a/asmcomp/asmlink.mli b/asmcomp/asmlink.mli index 80d66099..1c832276 100644 --- a/asmcomp/asmlink.mli +++ b/asmcomp/asmlink.mli @@ -15,6 +15,7 @@ (* Link a set of .cmx/.o files and produce an executable or a plugin *) +open Misc open Format val link: ppf_dump:formatter -> string list -> string -> unit @@ -24,20 +25,20 @@ val link_shared: ppf_dump:formatter -> string list -> string -> unit val call_linker_shared: string list -> string -> unit val reset : unit -> unit -val check_consistency: string -> Cmx_format.unit_infos -> Digest.t -> unit -val extract_crc_interfaces: unit -> (string * Digest.t option) list -val extract_crc_implementations: unit -> (string * Digest.t option) list +val check_consistency: filepath -> Cmx_format.unit_infos -> Digest.t -> unit +val extract_crc_interfaces: unit -> crcs +val extract_crc_implementations: unit -> crcs type error = - File_not_found of string - | Not_an_object_file of string - | Missing_implementations of (string * string list) list - | Inconsistent_interface of string * string * string - | Inconsistent_implementation of string * string * string - | Assembler_error of string + | File_not_found of filepath + | Not_an_object_file of filepath + | Missing_implementations of (modname * string list) list + | Inconsistent_interface of modname * filepath * filepath + | Inconsistent_implementation of modname * filepath * filepath + | Assembler_error of filepath | Linking_error - | Multiple_definition of string * string * string - | Missing_cmx of string * string + | Multiple_definition of modname * filepath * filepath + | Missing_cmx of filepath * modname exception Error of error diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index f079e0e6..df9686aa 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -101,9 +101,9 @@ let make_package_object ~ppf_dump members targetobj targetname coercion let prefixname = Filename.remove_extension objtemp in if Config.flambda then begin let size, lam = Translmod.transl_package_flambda components coercion in - let lam = Simplif.simplify_lambda targetname lam in + let lam = Simplif.simplify_lambda lam in let flam = - Middle_end.middle_end ~ppf_dump + Flambda_middle_end.middle_end ~ppf_dump ~prefixname ~backend ~size @@ -117,9 +117,9 @@ let make_package_object ~ppf_dump members targetobj targetname coercion let main_module_block_size, code = Translmod.transl_store_package components (Ident.create_persistent targetname) coercion in - let code = Simplif.simplify_lambda targetname code in + let code = Simplif.simplify_lambda code 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 = diff --git a/asmcomp/backend_var.ml b/asmcomp/backend_var.ml deleted file mode 100644 index 39af7f60..00000000 --- a/asmcomp/backend_var.ml +++ /dev/null @@ -1,87 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Mark Shinwell, 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. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-30-40-41-42"] - -include Ident - -type backend_var = t - -module Provenance = struct - type t = { - module_path : Path.t; - location : Debuginfo.t; - original_ident : Ident.t; - } - - let print ppf { module_path; location; original_ident; } = - Format.fprintf ppf "@[(\ - @[(module_path@ %a)@]@ \ - @[(location@ %a)@]@ \ - @[(original_ident@ %a)@]\ - )@]" - Path.print module_path - Debuginfo.print_compact location - Ident.print original_ident - - let create ~module_path ~location ~original_ident = - { module_path; - location; - original_ident; - } - - let module_path t = t.module_path - let location t = t.location - let original_ident t = t.original_ident -end - -module With_provenance = struct - type t = - | Without_provenance of backend_var - | With_provenance of { - var : backend_var; - provenance : Provenance.t; - } - - let create ?provenance var = - match provenance with - | None -> Without_provenance var - | Some provenance -> With_provenance { var; provenance; } - - let var t = - match t with - | Without_provenance var - | With_provenance { var; provenance = _; } -> var - - let provenance t = - match t with - | Without_provenance _ -> None - | With_provenance { var = _; provenance; } -> Some provenance - - let name t = name (var t) - - let rename t = - let var = rename (var t) in - match provenance t with - | None -> Without_provenance var - | Some provenance -> With_provenance { var; provenance; } - - let print ppf t = - match provenance t with - | None -> print ppf (var t) - | Some provenance -> - Format.fprintf ppf "%a[%a]" - print (var t) - Provenance.print provenance -end diff --git a/asmcomp/backend_var.mli b/asmcomp/backend_var.mli deleted file mode 100644 index f236be1e..00000000 --- a/asmcomp/backend_var.mli +++ /dev/null @@ -1,54 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Mark Shinwell, 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. *) -(* *) -(**************************************************************************) - -(** Variables used in the backend, optionally equipped with "provenance" - information, used for the emission of debugging information. *) - -[@@@ocaml.warning "+a-4-30-40-41-42"] - -include module type of struct include Ident end - -type backend_var = t - -module Provenance : sig - type t - - val create - : module_path:Path.t - -> location:Debuginfo.t - -> original_ident:Ident.t - -> t - - val module_path : t -> Path.t - val location : t -> Debuginfo.t - val original_ident : t -> Ident.t - - val print : Format.formatter -> t -> unit -end - -module With_provenance : sig - (** Values of type [t] should be used for variables in binding position. *) - type t - - val print : Format.formatter -> t -> unit - - val create : ?provenance:Provenance.t -> backend_var -> t - - val var : t -> backend_var - val provenance : t -> Provenance.t option - - val name : t -> string - - val rename : t -> t -end diff --git a/asmcomp/build_export_info.ml b/asmcomp/build_export_info.ml deleted file mode 100644 index 88082cf6..00000000 --- a/asmcomp/build_export_info.ml +++ /dev/null @@ -1,713 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -module Env : sig - type t - - val new_descr : t -> Export_info.descr -> Export_id.t - - val record_descr : t -> Export_id.t -> Export_info.descr -> unit - val new_value_closure_descr - : t - -> closure_id:Closure_id.t - -> set_of_closures: Export_info.value_set_of_closures - -> Export_id.t - - val get_descr : t -> Export_info.approx -> Export_info.descr option - - val add_approx : t -> Variable.t -> Export_info.approx -> t - val add_approx_maps : t -> Export_info.approx Variable.Map.t list -> t - val find_approx : t -> Variable.t -> Export_info.approx - - val get_symbol_descr : t -> Symbol.t -> Export_info.descr option - - val new_unit_descr : t -> Export_id.t - - module Global : sig - (* "Global" as in "without local variable bindings". *) - type t - - val create_empty : unit -> t - - val add_symbol : t -> Symbol.t -> Export_id.t -> t - val new_symbol : t -> Symbol.t -> Export_id.t * t - - val symbol_to_export_id_map : t -> Export_id.t Symbol.Map.t - val export_id_to_descr_map : t -> Export_info.descr Export_id.Map.t - end - - (** Creates a new environment, sharing the mapping from export IDs to - export descriptions with the given global environment. *) - val empty_of_global : Global.t -> t -end = struct - let fresh_id () = Export_id.create (Compilenv.current_unit ()) - - module Global = struct - type t = - { sym : Export_id.t Symbol.Map.t; - (* Note that [ex_table]s themselves are shared (hence [ref] and not - [mutable]). *) - ex_table : Export_info.descr Export_id.Map.t ref; - closure_table : Export_id.t Closure_id.Map.t ref; - } - - let create_empty () = - { sym = Symbol.Map.empty; - ex_table = ref Export_id.Map.empty; - closure_table = ref Closure_id.Map.empty; - } - - let add_symbol t sym export_id = - if Symbol.Map.mem sym t.sym then begin - Misc.fatal_errorf "Build_export_info.Env.Global.add_symbol: cannot \ - rebind symbol %a in environment" - Symbol.print sym - end; - { t with sym = Symbol.Map.add sym export_id t.sym } - - let new_symbol t sym = - let export_id = fresh_id () in - export_id, add_symbol t sym export_id - - let symbol_to_export_id_map t = t.sym - let export_id_to_descr_map t = !(t.ex_table) - end - - (* CR-someday mshinwell: The half-mutable nature of [t] with sharing of - the [ex_table] is kind of nasty. Consider making it immutable. *) - type t = - { var : Export_info.approx Variable.Map.t; - sym : Export_id.t Symbol.Map.t; - ex_table : Export_info.descr Export_id.Map.t ref; - closure_table: Export_id.t Closure_id.Map.t ref; - } - - let empty_of_global (env : Global.t) = - { var = Variable.Map.empty; - sym = env.sym; - ex_table = env.ex_table; - closure_table = env.closure_table; - } - - let extern_id_descr export_id = - let export = Compilenv.approx_env () in - try Some (Export_info.find_description export export_id) - with Not_found -> None - - let extern_symbol_descr sym = - if Compilenv.is_predefined_exception sym - then None - else - match - Compilenv.approx_for_global (Symbol.compilation_unit sym) - with - | None -> None - | Some export -> - try - let id = Symbol.Map.find sym export.symbol_id in - let descr = Export_info.find_description export id in - Some descr - with - | Not_found -> None - - let get_id_descr t export_id = - try Some (Export_id.Map.find export_id !(t.ex_table)) - with Not_found -> extern_id_descr export_id - - let get_symbol_descr t sym = - try - let export_id = Symbol.Map.find sym t.sym in - Some (Export_id.Map.find export_id !(t.ex_table)) - with - | Not_found -> extern_symbol_descr sym - - let get_descr t (approx : Export_info.approx) = - match approx with - | Value_unknown -> None - | Value_id export_id -> get_id_descr t export_id - | Value_symbol sym -> get_symbol_descr t sym - - let record_descr t id (descr : Export_info.descr) = - if Export_id.Map.mem id !(t.ex_table) then begin - Misc.fatal_errorf "Build_export_info.Env.record_descr: cannot rebind \ - export ID %a in environment" - Export_id.print id - end; - t.ex_table := Export_id.Map.add id descr !(t.ex_table) - - let new_descr t (descr : Export_info.descr) = - let id = fresh_id () in - record_descr t id descr; - id - - let new_value_closure_descr t ~closure_id ~set_of_closures = - match Closure_id.Map.find closure_id !(t.closure_table) with - | exception Not_found -> - let export_id = - new_descr t (Value_closure { closure_id; set_of_closures }) - in - t.closure_table := - Closure_id.Map.add closure_id export_id !(t.closure_table); - export_id - | export_id -> export_id - - let new_unit_descr t = - new_descr t (Value_constptr 0) - - let add_approx t var approx = - if Variable.Map.mem var t.var then begin - Misc.fatal_errorf "Build_export_info.Env.add_approx: cannot rebind \ - variable %a in environment" - Variable.print var - end; - { t with var = Variable.Map.add var approx t.var; } - - let add_approx_map t vars_to_approxs = - Variable.Map.fold (fun var approx t -> add_approx t var approx) - vars_to_approxs - t - - let add_approx_maps t vars_to_approxs_list = - List.fold_left add_approx_map t vars_to_approxs_list - - let find_approx t var : Export_info.approx = - try Variable.Map.find var t.var with - | Not_found -> Value_unknown -end - -let descr_of_constant (c : Flambda.const) : Export_info.descr = - match c with - (* [Const_pointer] is an immediate value of a type whose values may be - boxed (typically a variant type with both constant and non-constant - constructors). *) - | Int i -> Value_int i - | Char c -> Value_char c - | Const_pointer i -> Value_constptr i - -let descr_of_allocated_constant (c : Allocated_const.t) : Export_info.descr = - match c with - | Float f -> Value_float f - | Int32 i -> Value_boxed_int (Int32, i) - | Int64 i -> Value_boxed_int (Int64, i) - | Nativeint i -> Value_boxed_int (Nativeint, i) - | String s -> - let v_string : Export_info.value_string = - { size = String.length s; contents = Unknown_or_mutable; } - in - Value_string v_string - | Immutable_string s -> - let v_string : Export_info.value_string = - { size = String.length s; contents = Contents s; } - in - Value_string v_string - | Immutable_float_array fs -> - Value_float_array { - contents = Contents (Array.map (fun x -> Some x) (Array.of_list fs)); - size = List.length fs; - } - | Float_array fs -> - Value_float_array { - contents = Unknown_or_mutable; - size = List.length fs; - } - -let rec approx_of_expr (env : Env.t) (flam : Flambda.t) : Export_info.approx = - match flam with - | Var var -> Env.find_approx env var - | Let { var; defining_expr; body; _ } -> - let approx = descr_of_named env defining_expr in - let env = Env.add_approx env var approx in - approx_of_expr env body - | Let_mutable { body } -> - approx_of_expr env body - | Let_rec (defs, body) -> - let env = - List.fold_left (fun env (var, defining_expr) -> - let approx = descr_of_named env defining_expr in - Env.add_approx env var approx) - env defs - in - approx_of_expr env body - | Apply { func; kind; _ } -> - begin match kind with - | Indirect -> Value_unknown - | Direct closure_id' -> - match Env.get_descr env (Env.find_approx env func) with - | Some (Value_closure - { closure_id; set_of_closures = { results; _ }; }) -> - assert (Closure_id.equal closure_id closure_id'); - assert (Closure_id.Map.mem closure_id results); - Closure_id.Map.find closure_id results - | _ -> Value_unknown - end - | Assign _ -> Value_id (Env.new_unit_descr env) - | For _ -> Value_id (Env.new_unit_descr env) - | While _ -> Value_id (Env.new_unit_descr env) - | Static_raise _ | Static_catch _ | Try_with _ | If_then_else _ - | Switch _ | String_switch _ | Send _ | Proved_unreachable -> - Value_unknown - -and descr_of_named (env : Env.t) (named : Flambda.named) - : Export_info.approx = - match named with - | Expr expr -> approx_of_expr env expr - | Symbol sym -> Value_symbol sym - | Read_mutable _ -> Value_unknown - | Read_symbol_field (sym, i) -> - begin match Env.get_symbol_descr env sym with - | Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i) - | _ -> Value_unknown - end - | Const const -> - Value_id (Env.new_descr env (descr_of_constant const)) - | Allocated_const const -> - Value_id (Env.new_descr env (descr_of_allocated_constant const)) - | Prim (Pmakeblock (tag, Immutable, _value_kind), args, _dbg) -> - let approxs = List.map (Env.find_approx env) args in - let descr : Export_info.descr = - Value_block (Tag.create_exn tag, Array.of_list approxs) - in - Value_id (Env.new_descr env descr) - | Prim (Pfield i, [arg], _) -> - begin match Env.get_descr env (Env.find_approx env arg) with - | Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i) - | _ -> Value_unknown - end - | Prim (Pgetglobal id, _, _) -> - Value_symbol (Compilenv.symbol_for_global' id) - | Prim _ -> Value_unknown - | Set_of_closures set -> - let descr : Export_info.descr = - Value_set_of_closures (describe_set_of_closures env set) - in - Value_id (Env.new_descr env descr) - | Project_closure { set_of_closures; closure_id; } -> - begin match Env.get_descr env (Env.find_approx env set_of_closures) with - | Some (Value_set_of_closures set_of_closures) -> - if not (Closure_id.Map.mem closure_id set_of_closures.results) then begin - Misc.fatal_errorf "Could not build export description for \ - [Project_closure]: closure ID %a not in set of closures" - Closure_id.print closure_id - end; - Value_id ( - Env.new_value_closure_descr env ~closure_id ~set_of_closures - ) - | _ -> - (* It would be nice if this were [assert false], but owing to the fact - that this pass may propagate less information than for example - [Inline_and_simplify], we might end up here. *) - Value_unknown - end - | Move_within_set_of_closures { closure; start_from; move_to; } -> - begin match Env.get_descr env (Env.find_approx env closure) with - | Some (Value_closure { set_of_closures; closure_id; }) -> - assert (Closure_id.equal closure_id start_from); - Value_id ( - Env.new_value_closure_descr env ~closure_id:move_to ~set_of_closures - ) - | _ -> Value_unknown - end - | Project_var { closure; closure_id = closure_id'; var; } -> - begin match Env.get_descr env (Env.find_approx env closure) with - | Some (Value_closure - { set_of_closures = { bound_vars; _ }; closure_id; }) -> - assert (Closure_id.equal closure_id closure_id'); - if not (Var_within_closure.Map.mem var bound_vars) then begin - Misc.fatal_errorf "Project_var from %a (closure ID %a) of \ - variable %a that is not bound by the closure. \ - Variables bound by the closure are: %a" - Variable.print closure - Closure_id.print closure_id - Var_within_closure.print var - (Var_within_closure.Map.print (fun _ _ -> ())) bound_vars - end; - Var_within_closure.Map.find var bound_vars - | _ -> Value_unknown - end - -and describe_set_of_closures env (set : Flambda.set_of_closures) - : Export_info.value_set_of_closures = - let bound_vars_approx = - Variable.Map.map (fun (external_var : Flambda.specialised_to) -> - Env.find_approx env external_var.var) - set.free_vars - in - let specialised_args_approx = - Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - Env.find_approx env spec_to.var) - set.specialised_args - in - let closures_approx = - (* To build an approximation of the results, we need an - approximation of the functions. The first one we can build is - one where every function returns something unknown. - *) - (* CR-someday pchambart: we could improve a bit on that by building a - recursive approximation of the closures: The value_closure - description contains a [value_set_of_closures]. We could replace - this field by a [Expr_id.t] or an [approx]. - mshinwell: Deferred for now. - *) - let initial_value_set_of_closures = - { Export_info. - set_of_closures_id = set.function_decls.set_of_closures_id; - bound_vars = Var_within_closure.wrap_map bound_vars_approx; - free_vars = set.free_vars; - results = - Closure_id.wrap_map - (Variable.Map.map (fun _ -> Export_info.Value_unknown) - set.function_decls.funs); - aliased_symbol = None; - } - in - Variable.Map.mapi (fun fun_var _function_decl -> - let export_id = - let closure_id = Closure_id.wrap fun_var in - let set_of_closures = initial_value_set_of_closures in - Env.new_value_closure_descr env ~closure_id ~set_of_closures - in - Export_info.Value_id export_id) - set.function_decls.funs - in - let closure_env = - Env.add_approx_maps env - [closures_approx; bound_vars_approx; specialised_args_approx] - in - let results = - let result_approx _var (function_decl : Flambda.function_declaration) = - approx_of_expr closure_env function_decl.body - in - Variable.Map.mapi result_approx set.function_decls.funs - in - { set_of_closures_id = set.function_decls.set_of_closures_id; - bound_vars = Var_within_closure.wrap_map bound_vars_approx; - free_vars = set.free_vars; - results = Closure_id.wrap_map results; - aliased_symbol = None; - } - -let approx_of_constant_defining_value_block_field env - (c : Flambda.constant_defining_value_block_field) : Export_info.approx = - match c with - | Symbol s -> Value_symbol s - | Const c -> Value_id (Env.new_descr env (descr_of_constant c)) - -let describe_constant_defining_value env export_id symbol - (const : Flambda.constant_defining_value) = - let env = - (* Assignments of variables to export IDs are local to each constant - defining value. *) - Env.empty_of_global env - in - match const with - | Allocated_const alloc_const -> - let descr = descr_of_allocated_constant alloc_const in - Env.record_descr env export_id descr - | Block (tag, fields) -> - let approxs = - List.map (approx_of_constant_defining_value_block_field env) fields - in - Env.record_descr env export_id (Value_block (tag, Array.of_list approxs)) - | Set_of_closures set_of_closures -> - let descr : Export_info.descr = - Value_set_of_closures - { (describe_set_of_closures env set_of_closures) with - aliased_symbol = Some symbol; - } - in - Env.record_descr env export_id descr - | Project_closure (sym, closure_id) -> - begin match Env.get_symbol_descr env sym with - | Some (Value_set_of_closures set_of_closures) -> - if not (Closure_id.Map.mem closure_id set_of_closures.results) then begin - Misc.fatal_errorf "Could not build export description for \ - [Project_closure] constant defining value: closure ID %a not in \ - set of closures" - Closure_id.print closure_id - end; - let descr = - Export_info.Value_closure - { closure_id = closure_id; set_of_closures; } - in - Env.record_descr env export_id descr - | None -> - Misc.fatal_errorf - "Cannot project symbol %a to closure_id %a. \ - No available export description@." - Symbol.print sym - Closure_id.print closure_id - | Some (Value_closure _) -> - Misc.fatal_errorf - "Cannot project symbol %a to closure_id %a. \ - The symbol is a closure instead of a set of closures.@." - Symbol.print sym - Closure_id.print closure_id - | Some _ -> - Misc.fatal_errorf - "Cannot project symbol %a to closure_id %a. \ - The symbol is not a set of closures.@." - Symbol.print sym - Closure_id.print closure_id - end - -let describe_program (env : Env.Global.t) (program : Flambda.program) = - let rec loop env (program : Flambda.program_body) = - match program with - | Let_symbol (symbol, constant_defining_value, program) -> - let id, env = Env.Global.new_symbol env symbol in - describe_constant_defining_value env id symbol constant_defining_value; - loop env program - | Let_rec_symbol (defs, program) -> - let env, defs = - List.fold_left (fun (env, defs) (symbol, def) -> - let id, env = Env.Global.new_symbol env symbol in - env, ((id, symbol, def) :: defs)) - (env, []) defs - in - (* [Project_closure]s are separated to be handled last. They are the - only values that need a description for their argument. *) - let project_closures, other_constants = - List.partition (function - | _, _, Flambda.Project_closure _ -> true - | _ -> false) - defs - in - List.iter (fun (id, symbol, def) -> - describe_constant_defining_value env id symbol def) - other_constants; - List.iter (fun (id, symbol, def) -> - describe_constant_defining_value env id symbol def) - project_closures; - loop env program - | Initialize_symbol (symbol, tag, fields, program) -> - let id = - let env = - (* Assignments of variables to export IDs are local to each - [Initialize_symbol] construction. *) - Env.empty_of_global env - in - let field_approxs = List.map (approx_of_expr env) fields in - let descr : Export_info.descr = - Value_block (tag, Array.of_list field_approxs) - in - Env.new_descr env descr - in - let env = Env.Global.add_symbol env symbol id in - loop env program - | Effect (_expr, program) -> loop env program - | End symbol -> symbol, env - in - loop env program.program_body - - -let build_transient ~(backend : (module Backend_intf.S)) - (program : Flambda.program) : Export_info.transient = - if !Clflags.opaque then - let compilation_unit = Compilenv.current_unit () in - let root_symbol = Compilenv.current_unit_symbol () in - Export_info.opaque_transient ~root_symbol ~compilation_unit - else - (* CR-soon pchambart: Should probably use that instead of the ident of - the module as global identifier. - mshinwell: Is "that" the variable "_global_symbol"? - Yes it is. We are just assuming that the symbol produced from - the identifier of the module is the right one. *) - let _global_symbol, env = - describe_program (Env.Global.create_empty ()) program - in - let sets_of_closures_map = - Flambda_utils.all_sets_of_closures_map program - in - let function_declarations_map = - let set_of_closures_approx { Flambda. function_decls; _ } = - let recursive = - lazy - (Find_recursive_functions.in_function_declarations - function_decls ~backend) - in - let keep_body = - Inline_and_simplify_aux.keep_body_check - ~is_classic_mode:function_decls.is_classic_mode ~recursive - in - Simple_value_approx.function_declarations_approx - ~keep_body function_decls - in - Set_of_closures_id.Map.map set_of_closures_approx sets_of_closures_map - in - let unnested_values = - Env.Global.export_id_to_descr_map env - in - let invariant_params = - let invariant_params = - Set_of_closures_id.Map.map - (fun { Flambda. function_decls; _ } -> - if function_decls.is_classic_mode then begin - Variable.Map.empty - end else begin - Invariant_params.invariant_params_in_recursion - ~backend function_decls - end) - (Flambda_utils.all_sets_of_closures_map program) - in - let export = Compilenv.approx_env () in - Export_id.Map.fold - (fun _eid (descr:Export_info.descr) invariant_params -> - match (descr : Export_info.descr) with - | Value_closure { set_of_closures } - | Value_set_of_closures set_of_closures -> - let { Export_info.set_of_closures_id } = set_of_closures in - begin match - Set_of_closures_id.Map.find set_of_closures_id - export.invariant_params - with - | exception Not_found -> - invariant_params - | (set : Variable.Set.t Variable.Map.t) -> - Set_of_closures_id.Map.add - set_of_closures_id set invariant_params - end - | Export_info.Value_boxed_int (_, _) - | Value_block _ - | Value_mutable_block _ - | Value_int _ - | Value_char _ - | Value_constptr _ - | Value_float _ - | Value_float_array _ - | Value_string _ - | Value_unknown_descr -> - invariant_params) - unnested_values invariant_params - in - let recursive = - let recursive = - Set_of_closures_id.Map.map - (fun { Flambda. function_decls; _ } -> - if function_decls.is_classic_mode then begin - Variable.Set.empty - end else begin - Find_recursive_functions.in_function_declarations - ~backend function_decls - end) - (Flambda_utils.all_sets_of_closures_map program) - in - let export = Compilenv.approx_env () in - Export_id.Map.fold - (fun _eid (descr:Export_info.descr) recursive -> - match (descr : Export_info.descr) with - | Value_closure { set_of_closures } - | Value_set_of_closures set_of_closures -> - let { Export_info.set_of_closures_id } = set_of_closures in - begin match - Set_of_closures_id.Map.find set_of_closures_id - export.recursive - with - | exception Not_found -> - recursive - | (set : Variable.Set.t) -> - Set_of_closures_id.Map.add - set_of_closures_id set recursive - end - | Export_info.Value_boxed_int (_, _) - | Value_block _ - | Value_mutable_block _ - | Value_int _ - | Value_char _ - | Value_constptr _ - | Value_float _ - | Value_float_array _ - | Value_string _ - | Value_unknown_descr -> - recursive) - unnested_values recursive - in - let values = Export_info.nest_eid_map unnested_values in - let symbol_id = Env.Global.symbol_to_export_id_map env in - let { Traverse_for_exported_symbols. - set_of_closure_ids = relevant_set_of_closures; - symbols = relevant_symbols; - export_ids = relevant_export_ids; - set_of_closure_ids_keep_declaration = - relevant_set_of_closures_declaration_only; - relevant_local_closure_ids; - relevant_imported_closure_ids; - relevant_local_vars_within_closure; - relevant_imported_vars_within_closure; - } = - let closure_id_to_set_of_closures_id = - Set_of_closures_id.Map.fold - (fun set_of_closure_id - (function_declarations : Simple_value_approx.function_declarations) - acc -> - Variable.Map.fold - (fun fun_var _ acc -> - let closure_id = Closure_id.wrap fun_var in - Closure_id.Map.add closure_id set_of_closure_id acc) - function_declarations.funs - acc) - function_declarations_map - Closure_id.Map.empty - in - Traverse_for_exported_symbols.traverse - ~sets_of_closures_map - ~closure_id_to_set_of_closures_id - ~function_declarations_map - ~values:(Compilation_unit.Map.find (Compilenv.current_unit ()) values) - ~symbol_id - ~root_symbol:(Compilenv.current_unit_symbol ()) - in - let sets_of_closures = - Set_of_closures_id.Map.filter_map - function_declarations_map - ~f:(fun key (fun_decls : Simple_value_approx.function_declarations) -> - if Set_of_closures_id.Set.mem key relevant_set_of_closures then - Some fun_decls - else if begin - Set_of_closures_id.Set.mem key - relevant_set_of_closures_declaration_only - end then begin - if fun_decls.is_classic_mode then - Some (Simple_value_approx.clear_function_bodies fun_decls) - else - Some fun_decls - end else begin - None - end) - in - - let values = - Compilation_unit.Map.map (fun map -> - Export_id.Map.filter (fun key _ -> - Export_id.Set.mem key relevant_export_ids) - map) - values - in - let symbol_id = - Symbol.Map.filter - (fun key _ -> Symbol.Set.mem key relevant_symbols) - symbol_id - in - Export_info.create_transient ~values - ~symbol_id - ~sets_of_closures - ~invariant_params - ~recursive - ~relevant_local_closure_ids - ~relevant_imported_closure_ids - ~relevant_local_vars_within_closure - ~relevant_imported_vars_within_closure diff --git a/asmcomp/build_export_info.mli b/asmcomp/build_export_info.mli deleted file mode 100644 index 0380604b..00000000 --- a/asmcomp/build_export_info.mli +++ /dev/null @@ -1,25 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Construct export information, for emission into .cmx files, from an - Flambda program. *) - -val build_transient : - backend:(module Backend_intf.S) -> - Flambda.program -> - Export_info.transient diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml deleted file mode 100644 index 0e858f11..00000000 --- a/asmcomp/clambda.ml +++ /dev/null @@ -1,203 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* A variant of the "lambda" code with direct / indirect calls explicit - and closures explicit too *) - -open Asttypes -open Lambda - -type function_label = string - -type ustructured_constant = - | Uconst_float of float - | Uconst_int32 of int32 - | Uconst_int64 of int64 - | Uconst_nativeint of nativeint - | Uconst_block of int * uconstant list - | Uconst_float_array of float list - | Uconst_string of string - | Uconst_closure of ufunction list * string * uconstant list - -and uconstant = - | Uconst_ref of string * ustructured_constant option - | Uconst_int of int - | Uconst_ptr of int - -and uphantom_defining_expr = - | Uphantom_const of uconstant - | Uphantom_var of Backend_var.t - | Uphantom_offset_var of { var : Backend_var.t; offset_in_words : int; } - | Uphantom_read_field of { var : Backend_var.t; field : int; } - | Uphantom_read_symbol_field of { sym : string; field : int; } - | Uphantom_block of { tag : int; fields : Backend_var.t list; } - -and ulambda = - Uvar of Backend_var.t - | Uconst of uconstant - | Udirect_apply of function_label * ulambda list * Debuginfo.t - | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t - | Uclosure of ufunction list * ulambda list - | Uoffset of ulambda * int - | Ulet of mutable_flag * value_kind * Backend_var.With_provenance.t - * ulambda * ulambda - | Uphantom_let of Backend_var.With_provenance.t - * uphantom_defining_expr option * ulambda - | Uletrec of (Backend_var.With_provenance.t * ulambda) list * ulambda - | Uprim of primitive * ulambda list * Debuginfo.t - | Uswitch of ulambda * ulambda_switch * Debuginfo.t - | Ustringswitch of ulambda * (string * ulambda) list * ulambda option - | Ustaticfail of int * ulambda list - | Ucatch of - int * - (Backend_var.With_provenance.t * value_kind) list * - ulambda * - ulambda - | Utrywith of ulambda * Backend_var.With_provenance.t * ulambda - | Uifthenelse of ulambda * ulambda * ulambda - | Usequence of ulambda * ulambda - | Uwhile of ulambda * ulambda - | Ufor of Backend_var.With_provenance.t * ulambda * ulambda - * direction_flag * ulambda - | Uassign of Backend_var.t * ulambda - | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t - | Uunreachable - -and ufunction = { - label : function_label; - arity : int; - params : (Backend_var.With_provenance.t * value_kind) list; - return : value_kind; - body : ulambda; - dbg : Debuginfo.t; - env : Backend_var.t option; -} - -and ulambda_switch = - { us_index_consts: int array; - us_actions_consts : ulambda array; - us_index_blocks: int array; - us_actions_blocks: ulambda array} - -(* Description of known functions *) - -type function_description = - { fun_label: function_label; (* Label of direct entry point *) - fun_arity: int; (* Number of arguments *) - mutable fun_closed: bool; (* True if environment not used *) - mutable fun_inline: (Backend_var.With_provenance.t list * ulambda) option; - mutable fun_float_const_prop: bool (* Can propagate FP consts *) - } - -(* Approximation of values *) - -type value_approximation = - Value_closure of function_description * value_approximation - | Value_tuple of value_approximation array - | Value_unknown - | Value_const of uconstant - | Value_global_field of string * int - -(* Preallocated globals *) - -type usymbol_provenance = { - original_idents : Ident.t list; - module_path : Path.t; -} - -type uconstant_block_field = - | Uconst_field_ref of string - | Uconst_field_int of int - -type preallocated_block = { - symbol : string; - exported : bool; - tag : int; - fields : uconstant_block_field option list; - provenance : usymbol_provenance option; -} - -type preallocated_constant = { - symbol : string; - exported : bool; - definition : ustructured_constant; - provenance : usymbol_provenance option; -} - -(* Comparison functions for constants. We must not use Stdlib.compare - because it compares "0.0" and "-0.0" equal. (PR#6442) *) - -let compare_floats x1 x2 = - Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2) - -let rec compare_float_lists l1 l2 = - match l1, l2 with - | [], [] -> 0 - | [], _::_ -> -1 - | _::_, [] -> 1 - | h1::t1, h2::t2 -> - let c = compare_floats h1 h2 in - if c <> 0 then c else compare_float_lists t1 t2 - -let compare_constants c1 c2 = - match c1, c2 with - | Uconst_ref(lbl1, _c1), Uconst_ref(lbl2, _c2) -> String.compare lbl1 lbl2 - (* Same labels -> same constants. - Different labels -> different constants, even if the contents - match, because of string constants that must not be - reshared. *) - | Uconst_int n1, Uconst_int n2 -> Stdlib.compare n1 n2 - | Uconst_ptr n1, Uconst_ptr n2 -> Stdlib.compare n1 n2 - | Uconst_ref _, _ -> -1 - | Uconst_int _, Uconst_ref _ -> 1 - | Uconst_int _, Uconst_ptr _ -> -1 - | Uconst_ptr _, _ -> 1 - -let rec compare_constant_lists l1 l2 = - match l1, l2 with - | [], [] -> 0 - | [], _::_ -> -1 - | _::_, [] -> 1 - | h1::t1, h2::t2 -> - let c = compare_constants h1 h2 in - if c <> 0 then c else compare_constant_lists t1 t2 - -let rank_structured_constant = function - | Uconst_float _ -> 0 - | Uconst_int32 _ -> 1 - | Uconst_int64 _ -> 2 - | Uconst_nativeint _ -> 3 - | Uconst_block _ -> 4 - | Uconst_float_array _ -> 5 - | Uconst_string _ -> 6 - | Uconst_closure _ -> 7 - -let compare_structured_constants c1 c2 = - match c1, c2 with - | Uconst_float x1, Uconst_float x2 -> compare_floats x1 x2 - | Uconst_int32 x1, Uconst_int32 x2 -> Int32.compare x1 x2 - | Uconst_int64 x1, Uconst_int64 x2 -> Int64.compare x1 x2 - | Uconst_nativeint x1, Uconst_nativeint x2 -> Nativeint.compare x1 x2 - | Uconst_block(t1, l1), Uconst_block(t2, l2) -> - let c = t1 - t2 (* no overflow possible here *) in - if c <> 0 then c else compare_constant_lists l1 l2 - | Uconst_float_array l1, Uconst_float_array l2 -> - compare_float_lists l1 l2 - | Uconst_string s1, Uconst_string s2 -> String.compare s1 s2 - | Uconst_closure (_,lbl1,_), Uconst_closure (_,lbl2,_) -> - String.compare lbl1 lbl2 - | _, _ -> - (* no overflow possible here *) - rank_structured_constant c1 - rank_structured_constant c2 diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli deleted file mode 100644 index 98f3184d..00000000 --- a/asmcomp/clambda.mli +++ /dev/null @@ -1,153 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* A variant of the "lambda" code with direct / indirect calls explicit - and closures explicit too *) - -open Asttypes -open Lambda - -type function_label = string - -type ustructured_constant = - | Uconst_float of float - | Uconst_int32 of int32 - | Uconst_int64 of int64 - | Uconst_nativeint of nativeint - | Uconst_block of int * uconstant list - | Uconst_float_array of float list - | Uconst_string of string - | Uconst_closure of ufunction list * string * uconstant list - -and uconstant = - | Uconst_ref of string * ustructured_constant option - | Uconst_int of int - | Uconst_ptr of int - -and uphantom_defining_expr = - | Uphantom_const of uconstant - (** The phantom-let-bound variable is a constant. *) - | Uphantom_var of Backend_var.t - (** The phantom-let-bound variable is an alias for another variable. *) - | Uphantom_offset_var of { var : Backend_var.t; offset_in_words : int; } - (** The phantom-let-bound-variable's value is defined by adding the given - number of words to the pointer contained in the given identifier. *) - | Uphantom_read_field of { var : Backend_var.t; field : int; } - (** The phantom-let-bound-variable's value is found by adding the given - number of words to the pointer contained in the given identifier, then - dereferencing. *) - | Uphantom_read_symbol_field of { sym : string; field : int; } - (** As for [Uphantom_read_var_field], but with the pointer specified by - a symbol. *) - | Uphantom_block of { tag : int; fields : Backend_var.t list; } - (** The phantom-let-bound variable points at a block with the given - structure. *) - -and ulambda = - Uvar of Backend_var.t - | Uconst of uconstant - | Udirect_apply of function_label * ulambda list * Debuginfo.t - | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t - | Uclosure of ufunction list * ulambda list - | Uoffset of ulambda * int - | Ulet of mutable_flag * value_kind * Backend_var.With_provenance.t - * ulambda * ulambda - | Uphantom_let of Backend_var.With_provenance.t - * uphantom_defining_expr option * ulambda - | Uletrec of (Backend_var.With_provenance.t * ulambda) list * ulambda - | Uprim of primitive * ulambda list * Debuginfo.t - | Uswitch of ulambda * ulambda_switch * Debuginfo.t - | Ustringswitch of ulambda * (string * ulambda) list * ulambda option - | Ustaticfail of int * ulambda list - | Ucatch of - int * - (Backend_var.With_provenance.t * value_kind) list * - ulambda * - ulambda - | Utrywith of ulambda * Backend_var.With_provenance.t * ulambda - | Uifthenelse of ulambda * ulambda * ulambda - | Usequence of ulambda * ulambda - | Uwhile of ulambda * ulambda - | Ufor of Backend_var.With_provenance.t * ulambda * ulambda - * direction_flag * ulambda - | Uassign of Backend_var.t * ulambda - | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t - | Uunreachable - -and ufunction = { - label : function_label; - arity : int; - params : (Backend_var.With_provenance.t * value_kind) list; - return : value_kind; - body : ulambda; - dbg : Debuginfo.t; - env : Backend_var.t option; -} - -and ulambda_switch = - { us_index_consts: int array; - us_actions_consts: ulambda array; - us_index_blocks: int array; - us_actions_blocks: ulambda array} - -(* Description of known functions *) - -type function_description = - { fun_label: function_label; (* Label of direct entry point *) - fun_arity: int; (* Number of arguments *) - mutable fun_closed: bool; (* True if environment not used *) - mutable fun_inline: (Backend_var.With_provenance.t list * ulambda) option; - mutable fun_float_const_prop: bool (* Can propagate FP consts *) - } - -(* Approximation of values *) - -type value_approximation = - Value_closure of function_description * value_approximation - | Value_tuple of value_approximation array - | Value_unknown - | Value_const of uconstant - | Value_global_field of string * int - -(* Comparison functions for constants *) - -val compare_structured_constants: - ustructured_constant -> ustructured_constant -> int -val compare_constants: - uconstant -> uconstant -> int - -type usymbol_provenance = { - original_idents : Ident.t list; - module_path : Path.t; -} - -type uconstant_block_field = - | Uconst_field_ref of string - | Uconst_field_int of int - -type preallocated_block = { - symbol : string; - exported : bool; - tag : int; - fields : uconstant_block_field option list; - provenance : usymbol_provenance option; -} - -type preallocated_constant = { - symbol : string; - exported : bool; - definition : ustructured_constant; - provenance : usymbol_provenance option; -} diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml deleted file mode 100644 index 35239faf..00000000 --- a/asmcomp/closure.ml +++ /dev/null @@ -1,1447 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Introduction of closures, uncurrying, recognition of direct calls *) - -open Misc -open Asttypes -open Primitive -open Lambda -open Switch -open Clambda - -module Int = Numbers.Int -module Storer = - Switch.Store - (struct - type t = lambda - type key = lambda - let make_key = Lambda.make_key - let compare_key = Stdlib.compare - end) - -module V = Backend_var -module VP = Backend_var.With_provenance - -let no_phantom_lets () = - Misc.fatal_error "Closure does not support phantom let generation" - -(* Auxiliaries for compiling functions *) - -let rec split_list n l = - if n <= 0 then ([], l) else begin - match l with - [] -> fatal_error "Closure.split_list" - | a::l -> let (l1, l2) = split_list (n-1) l in (a::l1, l2) - end - -let rec build_closure_env env_param pos = function - [] -> V.Map.empty - | id :: rem -> - V.Map.add id - (Uprim(Pfield pos, [Uvar env_param], Debuginfo.none)) - (build_closure_env env_param (pos+1) rem) - -(* Auxiliary for accessing globals. We change the name of the global - to the name of the corresponding asm symbol. This is done here - and no longer in Cmmgen so that approximations stored in .cmx files - contain the right names if the -for-pack option is active. *) - -let getglobal dbg id = - Uprim(Pgetglobal (V.create_persistent (Compilenv.symbol_for_global id)), - [], dbg) - -(* Check if a variable occurs in a [clambda] term. *) - -let occurs_var var u = - let rec occurs = function - Uvar v -> v = var - | Uconst _ -> false - | Udirect_apply(_lbl, args, _) -> List.exists occurs args - | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args - | Uclosure(_fundecls, clos) -> List.exists occurs clos - | Uoffset(u, _ofs) -> occurs u - | Ulet(_str, _kind, _id, def, body) -> occurs def || occurs body - | Uphantom_let _ -> no_phantom_lets () - | Uletrec(decls, body) -> - List.exists (fun (_id, u) -> occurs u) decls || occurs body - | Uprim(_p, args, _) -> List.exists occurs args - | Uswitch(arg, s, _dbg) -> - occurs arg || - occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks - | Ustringswitch(arg,sw,d) -> - occurs arg || - List.exists (fun (_,e) -> occurs e) sw || - (match d with None -> false | Some d -> occurs d) - | Ustaticfail (_, args) -> List.exists occurs args - | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr - | Utrywith(body, _exn, hdlr) -> occurs body || occurs hdlr - | Uifthenelse(cond, ifso, ifnot) -> - occurs cond || occurs ifso || occurs ifnot - | Usequence(u1, u2) -> occurs u1 || occurs u2 - | Uwhile(cond, body) -> occurs cond || occurs body - | Ufor(_id, lo, hi, _dir, body) -> occurs lo || occurs hi || occurs body - | Uassign(id, u) -> id = var || occurs u - | Usend(_, met, obj, args, _) -> - occurs met || occurs obj || List.exists occurs args - | Uunreachable -> false - and occurs_array a = - try - for i = 0 to Array.length a - 1 do - if occurs a.(i) then raise Exit - done; - false - with Exit -> - true - in occurs u - -(* Determine whether the estimated size of a clambda term is below - some threshold *) - -let prim_size prim args = - match prim with - Pidentity | Pbytes_to_string | Pbytes_of_string -> 0 - | Pgetglobal _ -> 1 - | Psetglobal _ -> 1 - | Pmakeblock _ -> 5 + List.length args - | Pfield _ -> 1 - | Psetfield(_f, isptr, init) -> - begin match init with - | Root_initialization -> 1 (* never causes a write barrier hit *) - | Assignment | Heap_initialization -> - match isptr with - | Pointer -> 4 - | Immediate -> 1 - end - | Pfloatfield _ -> 1 - | Psetfloatfield _ -> 1 - | Pduprecord _ -> 10 + List.length args - | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args - | Praise _ -> 4 - | Pstringlength -> 5 - | Pbyteslength -> 5 - | Pstringrefs -> 6 - | Pbytesrefs | Pbytessets -> 6 - | Pmakearray _ -> 5 + List.length args - | Parraylength kind -> if kind = Pgenarray then 6 else 2 - | Parrayrefu kind -> if kind = Pgenarray then 12 else 2 - | Parraysetu kind -> if kind = Pgenarray then 16 else 4 - | Parrayrefs kind -> if kind = Pgenarray then 18 else 8 - | Parraysets kind -> if kind = Pgenarray then 22 else 10 - | Pbigarrayref(_, ndims, _, _) -> 4 + ndims * 6 - | Pbigarrayset(_, ndims, _, _) -> 4 + ndims * 6 - | _ -> 2 (* arithmetic and comparisons *) - -(* Very raw approximation of switch cost *) - -let lambda_smaller lam threshold = - let size = ref 0 in - let rec lambda_size lam = - if !size > threshold then raise Exit; - match lam with - Uvar _ -> () - | Uconst _ -> incr size - | Udirect_apply(_, args, _) -> - size := !size + 4; lambda_list_size args - | Ugeneric_apply(fn, args, _) -> - size := !size + 6; lambda_size fn; lambda_list_size args - | Uclosure _ -> - raise Exit (* inlining would duplicate function definitions *) - | Uoffset(lam, _ofs) -> - incr size; lambda_size lam - | Ulet(_str, _kind, _id, lam, body) -> - lambda_size lam; lambda_size body - | Uphantom_let _ -> no_phantom_lets () - | Uletrec _ -> - raise Exit (* usually too large *) - | Uprim(prim, args, _) -> - size := !size + prim_size prim args; - lambda_list_size args - | Uswitch(lam, cases, _dbg) -> - if Array.length cases.us_actions_consts > 1 then size := !size + 5 ; - if Array.length cases.us_actions_blocks > 1 then size := !size + 5 ; - lambda_size lam; - lambda_array_size cases.us_actions_consts ; - lambda_array_size cases.us_actions_blocks - | Ustringswitch (lam,sw,d) -> - lambda_size lam ; - (* as ifthenelse *) - List.iter - (fun (_,lam) -> - size := !size+2 ; - lambda_size lam) - sw ; - Misc.may lambda_size d - | Ustaticfail (_,args) -> lambda_list_size args - | Ucatch(_, _, body, handler) -> - incr size; lambda_size body; lambda_size handler - | Utrywith(body, _id, handler) -> - size := !size + 8; lambda_size body; lambda_size handler - | Uifthenelse(cond, ifso, ifnot) -> - size := !size + 2; - lambda_size cond; lambda_size ifso; lambda_size ifnot - | Usequence(lam1, lam2) -> - lambda_size lam1; lambda_size lam2 - | Uwhile(cond, body) -> - size := !size + 2; lambda_size cond; lambda_size body - | Ufor(_id, low, high, _dir, body) -> - size := !size + 4; lambda_size low; lambda_size high; lambda_size body - | Uassign(_id, lam) -> - incr size; lambda_size lam - | Usend(_, met, obj, args, _) -> - size := !size + 8; - lambda_size met; lambda_size obj; lambda_list_size args - | Uunreachable -> () - and lambda_list_size l = List.iter lambda_size l - and lambda_array_size a = Array.iter lambda_size a in - try - lambda_size lam; !size <= threshold - with Exit -> - false - -let is_pure_prim p = - let open Semantics_of_primitives in - match Semantics_of_primitives.for_primitive p with - | (No_effects | Only_generative_effects), _ -> true - | Arbitrary_effects, _ -> false - -(* Check if a clambda term is ``pure'', - that is without side-effects *and* not containing function definitions *) - -let rec is_pure_clambda = function - Uvar _ -> true - | Uconst _ -> true - | Uprim(p, args, _) -> is_pure_prim p && List.for_all is_pure_clambda args - | _ -> false - -(* Simplify primitive operations on known arguments *) - -let make_const c = (Uconst c, Value_const c) -let make_const_ref c = - make_const(Uconst_ref(Compilenv.new_structured_constant ~shared:true c, - Some c)) -let make_const_int n = make_const (Uconst_int n) -let make_const_ptr n = make_const (Uconst_ptr n) -let make_const_bool b = make_const_ptr(if b then 1 else 0) - -let make_integer_comparison cmp x y = - make_const_bool - (match cmp with - Ceq -> x = y - | Cne -> x <> y - | Clt -> x < y - | Cgt -> x > y - | Cle -> x <= y - | Cge -> x >= y) - -let make_float_comparison cmp x y = - make_const_bool - (match cmp with - | CFeq -> x = y - | CFneq -> not (x = y) - | CFlt -> x < y - | CFnlt -> not (x < y) - | CFgt -> x > y - | CFngt -> not (x > y) - | CFle -> x <= y - | CFnle -> not (x <= y) - | CFge -> x >= y - | CFnge -> not (x >= y)) - -let make_const_float n = make_const_ref (Uconst_float n) -let make_const_natint n = make_const_ref (Uconst_nativeint n) -let make_const_int32 n = make_const_ref (Uconst_int32 n) -let make_const_int64 n = make_const_ref (Uconst_int64 n) - -(* The [fpc] parameter is true if constant propagation of - floating-point computations is allowed *) - -let simplif_arith_prim_pure fpc p (args, approxs) dbg = - let default = (Uprim(p, args, dbg), Value_unknown) in - match approxs with - (* int (or enumerated type) *) - | [ Value_const(Uconst_int n1 | Uconst_ptr n1) ] -> - begin match p with - | Pnot -> make_const_bool (n1 = 0) - | Pnegint -> make_const_int (- n1) - | Poffsetint n -> make_const_int (n + n1) - | Pfloatofint when fpc -> make_const_float (float_of_int n1) - | Pbintofint Pnativeint -> make_const_natint (Nativeint.of_int n1) - | Pbintofint Pint32 -> make_const_int32 (Int32.of_int n1) - | Pbintofint Pint64 -> make_const_int64 (Int64.of_int n1) - | Pbswap16 -> make_const_int (((n1 land 0xff) lsl 8) - lor ((n1 land 0xff00) lsr 8)) - | _ -> default - end - (* int (or enumerated type), int (or enumerated type) *) - | [ Value_const(Uconst_int n1 | Uconst_ptr n1); - Value_const(Uconst_int n2 | Uconst_ptr n2) ] -> - begin match p with - | Psequand -> make_const_bool (n1 <> 0 && n2 <> 0) - | Psequor -> make_const_bool (n1 <> 0 || n2 <> 0) - | Paddint -> make_const_int (n1 + n2) - | Psubint -> make_const_int (n1 - n2) - | Pmulint -> make_const_int (n1 * n2) - | Pdivint _ when n2 <> 0 -> make_const_int (n1 / n2) - | Pmodint _ when n2 <> 0 -> make_const_int (n1 mod n2) - | Pandint -> make_const_int (n1 land n2) - | Porint -> make_const_int (n1 lor n2) - | Pxorint -> make_const_int (n1 lxor n2) - | Plslint when 0 <= n2 && n2 < 8 * Arch.size_int -> - make_const_int (n1 lsl n2) - | Plsrint when 0 <= n2 && n2 < 8 * Arch.size_int -> - make_const_int (n1 lsr n2) - | Pasrint when 0 <= n2 && n2 < 8 * Arch.size_int -> - make_const_int (n1 asr n2) - | Pintcomp c -> make_integer_comparison c n1 n2 - | _ -> default - end - (* float *) - | [Value_const(Uconst_ref(_, Some (Uconst_float n1)))] when fpc -> - begin match p with - | Pintoffloat -> make_const_int (int_of_float n1) - | Pnegfloat -> make_const_float (-. n1) - | Pabsfloat -> make_const_float (abs_float n1) - | _ -> default - end - (* float, float *) - | [Value_const(Uconst_ref(_, Some (Uconst_float n1))); - Value_const(Uconst_ref(_, Some (Uconst_float n2)))] when fpc -> - begin match p with - | Paddfloat -> make_const_float (n1 +. n2) - | Psubfloat -> make_const_float (n1 -. n2) - | Pmulfloat -> make_const_float (n1 *. n2) - | Pdivfloat -> make_const_float (n1 /. n2) - | Pfloatcomp c -> make_float_comparison c n1 n2 - | _ -> default - end - (* nativeint *) - | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n)))] -> - begin match p with - | Pintofbint Pnativeint -> make_const_int (Nativeint.to_int n) - | Pcvtbint(Pnativeint, Pint32) -> make_const_int32 (Nativeint.to_int32 n) - | Pcvtbint(Pnativeint, Pint64) -> make_const_int64 (Int64.of_nativeint n) - | Pnegbint Pnativeint -> make_const_natint (Nativeint.neg n) - | _ -> default - end - (* nativeint, nativeint *) - | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1))); - Value_const(Uconst_ref(_, Some (Uconst_nativeint n2)))] -> - begin match p with - | Paddbint Pnativeint -> make_const_natint (Nativeint.add n1 n2) - | Psubbint Pnativeint -> make_const_natint (Nativeint.sub n1 n2) - | Pmulbint Pnativeint -> make_const_natint (Nativeint.mul n1 n2) - | Pdivbint {size=Pnativeint} when n2 <> 0n -> - make_const_natint (Nativeint.div n1 n2) - | Pmodbint {size=Pnativeint} when n2 <> 0n -> - make_const_natint (Nativeint.rem n1 n2) - | Pandbint Pnativeint -> make_const_natint (Nativeint.logand n1 n2) - | Porbint Pnativeint -> make_const_natint (Nativeint.logor n1 n2) - | Pxorbint Pnativeint -> make_const_natint (Nativeint.logxor n1 n2) - | Pbintcomp(Pnativeint, c) -> make_integer_comparison c n1 n2 - | _ -> default - end - (* nativeint, int *) - | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1))); - Value_const(Uconst_int n2)] -> - begin match p with - | Plslbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> - make_const_natint (Nativeint.shift_left n1 n2) - | Plsrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> - make_const_natint (Nativeint.shift_right_logical n1 n2) - | Pasrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> - make_const_natint (Nativeint.shift_right n1 n2) - | _ -> default - end - (* int32 *) - | [Value_const(Uconst_ref(_, Some (Uconst_int32 n)))] -> - begin match p with - | Pintofbint Pint32 -> make_const_int (Int32.to_int n) - | Pcvtbint(Pint32, Pnativeint) -> make_const_natint (Nativeint.of_int32 n) - | Pcvtbint(Pint32, Pint64) -> make_const_int64 (Int64.of_int32 n) - | Pnegbint Pint32 -> make_const_int32 (Int32.neg n) - | _ -> default - end - (* int32, int32 *) - | [Value_const(Uconst_ref(_, Some (Uconst_int32 n1))); - Value_const(Uconst_ref(_, Some (Uconst_int32 n2)))] -> - begin match p with - | Paddbint Pint32 -> make_const_int32 (Int32.add n1 n2) - | Psubbint Pint32 -> make_const_int32 (Int32.sub n1 n2) - | Pmulbint Pint32 -> make_const_int32 (Int32.mul n1 n2) - | Pdivbint {size=Pint32} when n2 <> 0l -> - make_const_int32 (Int32.div n1 n2) - | Pmodbint {size=Pint32} when n2 <> 0l -> - make_const_int32 (Int32.rem n1 n2) - | Pandbint Pint32 -> make_const_int32 (Int32.logand n1 n2) - | Porbint Pint32 -> make_const_int32 (Int32.logor n1 n2) - | Pxorbint Pint32 -> make_const_int32 (Int32.logxor n1 n2) - | Pbintcomp(Pint32, c) -> make_integer_comparison c n1 n2 - | _ -> default - end - (* int32, int *) - | [Value_const(Uconst_ref(_, Some (Uconst_int32 n1))); - Value_const(Uconst_int n2)] -> - begin match p with - | Plslbint Pint32 when 0 <= n2 && n2 < 32 -> - make_const_int32 (Int32.shift_left n1 n2) - | Plsrbint Pint32 when 0 <= n2 && n2 < 32 -> - make_const_int32 (Int32.shift_right_logical n1 n2) - | Pasrbint Pint32 when 0 <= n2 && n2 < 32 -> - make_const_int32 (Int32.shift_right n1 n2) - | _ -> default - end - (* int64 *) - | [Value_const(Uconst_ref(_, Some (Uconst_int64 n)))] -> - begin match p with - | Pintofbint Pint64 -> make_const_int (Int64.to_int n) - | Pcvtbint(Pint64, Pint32) -> make_const_int32 (Int64.to_int32 n) - | Pcvtbint(Pint64, Pnativeint) -> make_const_natint (Int64.to_nativeint n) - | Pnegbint Pint64 -> make_const_int64 (Int64.neg n) - | _ -> default - end - (* int64, int64 *) - | [Value_const(Uconst_ref(_, Some (Uconst_int64 n1))); - Value_const(Uconst_ref(_, Some (Uconst_int64 n2)))] -> - begin match p with - | Paddbint Pint64 -> make_const_int64 (Int64.add n1 n2) - | Psubbint Pint64 -> make_const_int64 (Int64.sub n1 n2) - | Pmulbint Pint64 -> make_const_int64 (Int64.mul n1 n2) - | Pdivbint {size=Pint64} when n2 <> 0L -> - make_const_int64 (Int64.div n1 n2) - | Pmodbint {size=Pint64} when n2 <> 0L -> - make_const_int64 (Int64.rem n1 n2) - | Pandbint Pint64 -> make_const_int64 (Int64.logand n1 n2) - | Porbint Pint64 -> make_const_int64 (Int64.logor n1 n2) - | Pxorbint Pint64 -> make_const_int64 (Int64.logxor n1 n2) - | Pbintcomp(Pint64, c) -> make_integer_comparison c n1 n2 - | _ -> default - end - (* int64, int *) - | [Value_const(Uconst_ref(_, Some (Uconst_int64 n1))); - Value_const(Uconst_int n2)] -> - begin match p with - | Plslbint Pint64 when 0 <= n2 && n2 < 64 -> - make_const_int64 (Int64.shift_left n1 n2) - | Plsrbint Pint64 when 0 <= n2 && n2 < 64 -> - make_const_int64 (Int64.shift_right_logical n1 n2) - | Pasrbint Pint64 when 0 <= n2 && n2 < 64 -> - make_const_int64 (Int64.shift_right n1 n2) - | _ -> default - end - (* TODO: Pbbswap *) - (* Catch-all *) - | _ -> - default - -let field_approx n = function - | Value_tuple a when n < Array.length a -> a.(n) - | Value_const (Uconst_ref(_, Some (Uconst_block(_, l)))) - when n < List.length l -> - Value_const (List.nth l n) - | _ -> Value_unknown - -let simplif_prim_pure fpc p (args, approxs) dbg = - match p, args, approxs with - (* Block construction *) - | Pmakeblock(tag, Immutable, _kind), _, _ -> - let field = function - | Value_const c -> c - | _ -> raise Exit - in - begin try - let cst = Uconst_block (tag, List.map field approxs) in - let name = - Compilenv.new_structured_constant cst ~shared:true - in - make_const (Uconst_ref (name, Some cst)) - with Exit -> - (Uprim(p, args, dbg), Value_tuple (Array.of_list approxs)) - end - (* Field access *) - | Pfield n, _, [ Value_const(Uconst_ref(_, Some (Uconst_block(_, l)))) ] - when n < List.length l -> - make_const (List.nth l n) - | Pfield n, [ Uprim(Pmakeblock _, ul, _) ], [approx] - when n < List.length ul -> - (List.nth ul n, field_approx n approx) - (* Strings *) - | (Pstringlength | Pbyteslength), - _, - [ Value_const(Uconst_ref(_, Some (Uconst_string s))) ] -> - make_const_int (String.length s) - (* Identity *) - | (Pidentity | Pbytes_to_string | Pbytes_of_string), [arg1], [app1] -> - (arg1, app1) - (* Kind test *) - | Pisint, _, [a1] -> - begin match a1 with - | Value_const(Uconst_int _ | Uconst_ptr _) -> make_const_bool true - | Value_const(Uconst_ref _) -> make_const_bool false - | Value_closure _ | Value_tuple _ -> make_const_bool false - | _ -> (Uprim(p, args, dbg), Value_unknown) - end - (* Compile-time constants *) - | Pctconst c, _, _ -> - begin 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 ) - | 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 *) - end - (* Catch-all *) - | _ -> - simplif_arith_prim_pure fpc p (args, approxs) dbg - -let simplif_prim fpc p (args, approxs as args_approxs) dbg = - if List.for_all is_pure_clambda args - then simplif_prim_pure fpc p args_approxs dbg - else - (* XXX : always return the same approxs as simplif_prim_pure? *) - let approx = - match p with - | Pmakeblock(_, Immutable, _kind) -> - Value_tuple (Array.of_list approxs) - | _ -> - Value_unknown - in - (Uprim(p, args, dbg), approx) - -(* Substitute variables in a [ulambda] term (a body of an inlined function) - and perform some more simplifications on integer primitives. - Also perform alpha-conversion on let-bound identifiers to avoid - clashes with locally-generated identifiers, and refresh raise counts - in order to avoid clashes with inlined code from other modules. - The variables must not be assigned in the term. - This is used to substitute "trivial" arguments for parameters - during inline expansion, and also for the translation of let rec - over functions. *) - -let approx_ulam = function - Uconst c -> Value_const c - | _ -> Value_unknown - -let find_action idxs acts tag = - if 0 <= tag && tag < Array.length idxs then begin - let idx = idxs.(tag) in - assert(0 <= idx && idx < Array.length acts); - Some acts.(idx) - end else - (* Can this happen? *) - None - -let subst_debuginfo loc dbg = - if !Clflags.debug then - Debuginfo.inline loc dbg - else - dbg - -let rec substitute loc fpc 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) - | 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) - | Uclosure(defs, env) -> - (* Question: should we rename function labels as well? Otherwise, - there is a risk that function labels are not globally unique. - This should not happen in the current system because: - - Inlined function bodies contain no Uclosure nodes - (cf. function [lambda_smaller]) - - When we substitute offsets for idents bound by let rec - in [close], case [Lletrec], we discard the original - let rec body and use only the substituted term. *) - Uclosure(defs, List.map (substitute loc fpc sb rn) env) - | Uoffset(u, ofs) -> Uoffset(substitute loc fpc 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 - (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2) - | Uphantom_let _ -> no_phantom_lets () - | Uletrec(bindings, body) -> - let bindings1 = - List.map (fun (id, rhs) -> - (VP.var id, VP.rename id, rhs)) bindings - in - let sb' = - List.fold_right (fun (id, id', _) s -> - V.Map.add id (Uvar (VP.var id')) s) - bindings1 sb - in - Uletrec( - List.map - (fun (_id, id', rhs) -> (id', substitute loc fpc sb' rn rhs)) - bindings1, - substitute loc fpc sb' rn body) - | Uprim(p, args, dbg) -> - let sargs = List.map (substitute loc fpc 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 - res - | Uswitch(arg, sw, dbg) -> - let sarg = substitute loc fpc sb rn arg in - let action = - (* Unfortunately, we cannot easily deal with the - case of a constructed block (makeblock) bound to a local - identifier. This would require to keep track of - local let bindings (at least their approximations) - in this substitute function. - *) - match sarg with - | Uconst (Uconst_ref (_, Some (Uconst_block (tag, _)))) -> - find_action sw.us_index_blocks sw.us_actions_blocks tag - | Uconst (Uconst_ptr tag) -> - find_action sw.us_index_consts sw.us_actions_consts tag - | _ -> None - in - begin match action with - | Some u -> substitute loc fpc sb rn u - | None -> - Uswitch(sarg, - { sw with - us_actions_consts = - Array.map (substitute loc fpc sb rn) sw.us_actions_consts; - us_actions_blocks = - Array.map (substitute loc fpc 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) - | Ustaticfail (nfail, args) -> - let nfail = - match rn with - | Some rn -> - begin try - Int.Map.find nfail rn - with Not_found -> - fatal_errorf "Closure.split_list: invalid nfail (%d)" nfail - end - | None -> nfail in - Ustaticfail (nfail, List.map (substitute loc fpc sb rn) args) - | Ucatch(nfail, ids, u1, u2) -> - let nfail, rn = - match rn with - | Some rn -> - let new_nfail = next_raise_count () in - new_nfail, Some (Int.Map.add nfail new_nfail rn) - | None -> nfail, rn in - let ids' = List.map (fun (id, k) -> VP.rename id, k) ids in - let sb' = - List.fold_right2 - (fun (id, _) (id', _) s -> - V.Map.add (VP.var id) (Uvar (VP.var id')) s - ) - ids ids' sb - in - Ucatch(nfail, ids', substitute loc fpc sb rn u1, - substitute loc fpc sb' rn u2) - | Utrywith(u1, id, u2) -> - let id' = VP.rename id in - Utrywith(substitute loc fpc sb rn u1, id', - substitute loc fpc - (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 - Uconst (Uconst_ptr n) -> - if n <> 0 then - substitute loc fpc sb rn u2 - else - substitute loc fpc sb rn u3 - | Uprim(Pmakeblock _, _, _) -> - substitute loc fpc sb rn u2 - | su1 -> - Uifthenelse(su1, substitute loc fpc sb rn u2, - substitute loc fpc sb rn u3) - end - | Usequence(u1, u2) -> - Usequence(substitute loc fpc sb rn u1, substitute loc fpc sb rn u2) - | Uwhile(u1, u2) -> - Uwhile(substitute loc fpc sb rn u1, substitute loc fpc 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 - (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u3) - | Uassign(id, u) -> - let id' = - try - match V.Map.find id sb with Uvar i -> i | _ -> assert false - with Not_found -> - id in - Uassign(id', substitute loc fpc 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) - | Uunreachable -> - Uunreachable - -(* Perform an inline expansion *) - -let is_simple_argument = function - | Uvar _ | Uconst _ -> true - | _ -> false - -let no_effects = function - | Uclosure _ -> true - | u -> is_pure_clambda u - -let rec bind_params_rec loc fpc subst params args body = - match (params, args) with - ([], []) -> substitute loc fpc subst (Some Int.Map.empty) body - | (p1 :: pl, a1 :: al) -> - if is_simple_argument a1 then - bind_params_rec loc fpc (V.Map.add (VP.var p1) a1 subst) - pl al body - else begin - let p1' = VP.rename p1 in - let u1, u2 = - match VP.name p1, a1 with - | "*opt*", Uprim(Pmakeblock(0, Immutable, kind), [a], dbg) -> - a, Uprim(Pmakeblock(0, Immutable, kind), [Uvar (VP.var p1')], dbg) - | _ -> - a1, Uvar (VP.var p1') - in - let body' = - bind_params_rec loc fpc (V.Map.add (VP.var p1) u2 subst) - pl al body in - if occurs_var (VP.var p1) body then - Ulet(Immutable, Pgenval, p1', u1, body') - else if no_effects a1 then body' - else Usequence(a1, body') - end - | (_, _) -> assert false - -let bind_params loc fpc params args body = - (* Reverse parameters and arguments to preserve right-to-left - evaluation order (PR#2910). *) - bind_params_rec loc fpc V.Map.empty (List.rev params) (List.rev args) body - -(* Check if a lambda term is ``pure'', - that is without side-effects *and* not containing function definitions *) - -let rec is_pure = function - Lvar _ -> true - | Lconst _ -> true - | Lprim(p, args,_) -> is_pure_prim p && List.for_all is_pure args - | Levent(lam, _ev) -> is_pure lam - | _ -> false - -let warning_if_forced_inline ~loc ~attribute warning = - if attribute = Always_inline then - Location.prerr_warning loc - (Warnings.Inlining_impossible warning) - -(* Generate a direct application *) - -let direct_apply fundesc funct ufunct uargs ~loc ~attribute = - let app_args = - if fundesc.fun_closed then uargs else uargs @ [ufunct] in - let app = - match fundesc.fun_inline, attribute with - | _, Never_inline | None, _ -> - let dbg = Debuginfo.from_location loc in - warning_if_forced_inline ~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 - in - (* If ufunct can contain side-effects or function definitions, - we must make sure that it is evaluated exactly once. - If the function is not closed, we evaluate ufunct as part of the - arguments. - If the function is closed, we force the evaluation of ufunct first. *) - if not fundesc.fun_closed || is_pure funct - then app - else Usequence(ufunct, app) - -(* Add [Value_integer] or [Value_constptr] info to the approximation - of an application *) - -let strengthen_approx appl approx = - match approx_ulam appl with - (Value_const _) as intapprox -> - intapprox - | _ -> approx - -(* If a term has approximation Value_integer or Value_constptr and is pure, - replace it by an integer constant *) - -let check_constant_result lam ulam approx = - match approx with - Value_const c when is_pure lam -> make_const c - | Value_global_field (id, i) when is_pure lam -> - begin match ulam with - | Uprim(Pfield _, [Uprim(Pgetglobal _, _, _)], _) -> (ulam, approx) - | _ -> - let glb = - Uprim(Pgetglobal (V.create_persistent id), [], Debuginfo.none) - in - Uprim(Pfield i, [glb], Debuginfo.none), approx - end - | _ -> (ulam, approx) - -(* Evaluate an expression with known value for its side effects only, - or discard it if it's pure *) - -let sequence_constant_expr lam ulam1 (ulam2, approx2 as res2) = - if is_pure lam then res2 else (Usequence(ulam1, ulam2), approx2) - -(* Maintain the approximation of the global structure being defined *) - -let global_approx = ref([||] : value_approximation array) - -(* Maintain the nesting depth for functions *) - -let function_nesting_depth = ref 0 -let excessive_function_nesting_depth = 5 - -(* Uncurry an expression and explicitate closures. - Also return the approximation of the expression. - The approximation environment [fenv] maps idents to approximations. - Idents not bound in [fenv] approximate to [Value_unknown]. - The closure environment [cenv] maps idents to [ulambda] terms. - It is used to substitute environment accesses for free identifiers. *) - -exception NotClosed - -let close_approx_var fenv cenv id = - let approx = try V.Map.find id fenv with Not_found -> Value_unknown in - match approx with - Value_const c -> make_const c - | approx -> - let subst = try V.Map.find id cenv with Not_found -> Uvar id in - (subst, approx) - -let close_var fenv cenv id = - let (ulam, _app) = close_approx_var fenv cenv id in ulam - -let rec close fenv cenv = function - Lvar id -> - close_approx_var fenv cenv id - | Lconst cst -> - let str ?(shared = true) cst = - let name = - Compilenv.new_structured_constant cst ~shared - in - Uconst_ref (name, Some cst) - in - let rec transl = function - | Const_base(Const_int n) -> Uconst_int n - | Const_base(Const_char c) -> Uconst_int (Char.code c) - | Const_pointer n -> Uconst_ptr n - | Const_block (tag, fields) -> - str (Uconst_block (tag, List.map transl fields)) - | Const_float_array sl -> - (* constant float arrays are really immutable *) - str (Uconst_float_array (List.map float_of_string sl)) - | Const_immstring s -> - str (Uconst_string s) - | Const_base (Const_string (s, _)) -> - (* Strings (even literal ones) must be assumed to be mutable... - except when OCaml has been configured with - -safe-string. Passing -safe-string at compilation - time is not enough, since the unit could be linked - with another one compiled without -safe-string, and - that one could modify our string literal. *) - str ~shared:Config.safe_string (Uconst_string s) - | Const_base(Const_float x) -> str (Uconst_float (float_of_string x)) - | Const_base(Const_int32 x) -> str (Uconst_int32 x) - | Const_base(Const_int64 x) -> str (Uconst_int64 x) - | Const_base(Const_nativeint x) -> str (Uconst_nativeint x) - in - make_const (transl cst) - | Lfunction _ as funct -> - close_one_function fenv cenv (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 - ((ufunct, Value_closure(fundesc, approx_res)), - [Uprim(Pmakeblock _, uargs, _)]) - when List.length uargs = - fundesc.fun_arity -> - let app = - direct_apply ~loc ~attribute fundesc funct 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 funct ufunct uargs in - (app, strengthen_approx app approx_res) - - | ((ufunct, (Value_closure(fundesc, _) as fapprox)), uargs) - when nargs < fundesc.fun_arity -> - let first_args = List.map (fun arg -> - (V.create_local "arg", arg) ) uargs in - let final_args = - Array.to_list (Array.init (fundesc.fun_arity - nargs) - (fun _ -> V.create_local "arg")) in - let rec iter args body = - match args with - [] -> body - | (arg1, arg2) :: args -> - iter args - (Ulet (Immutable, Pgenval, VP.create arg1, arg2, body)) - in - let internal_args = - (List.map (fun (arg1, _arg2) -> Lvar arg1) first_args) - @ (List.map (fun arg -> Lvar arg ) final_args) - 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 - (Lfunction{ - kind = Curried; - return = Pgenval; - params = List.map (fun v -> v, Pgenval) final_args; - body = Lapply{ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=(Lvar funct_var); - ap_args=internal_args; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}; - loc; - attr = default_function_attribute}) - in - let new_fun = - iter first_args - (Ulet (Immutable, Pgenval, VP.create funct_var, ufunct, new_fun)) - in - warning_if_forced_inline ~loc ~attribute "Partial application"; - (new_fun, approx) - - | ((ufunct, Value_closure(fundesc, _approx_res)), uargs) - when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity -> - let args = List.map (fun arg -> V.create_local "arg", arg) uargs in - let (first_args, rem_args) = split_list fundesc.fun_arity args in - let first_args = List.map (fun (id, _) -> Uvar id) first_args in - let rem_args = List.map (fun (id, _) -> Uvar id) rem_args in - let dbg = Debuginfo.from_location loc in - warning_if_forced_inline ~loc ~attribute "Over-application"; - let body = - Ugeneric_apply(direct_apply ~loc ~attribute - fundesc funct ufunct first_args, - rem_args, dbg) - in - let result = - List.fold_left (fun body (id, defining_expr) -> - Ulet (Immutable, Pgenval, VP.create id, defining_expr, body)) - body - args - in - result, Value_unknown - | ((ufunct, _), uargs) -> - let dbg = Debuginfo.from_location loc in - warning_if_forced_inline ~loc ~attribute "Unknown 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 dbg = Debuginfo.from_location loc in - (Usend(kind, umet, uobj, close_list fenv cenv args, dbg), - Value_unknown) - | Llet(str, kind, id, lam, body) -> - let (ulam, alam) = close_named fenv cenv id lam in - begin match (str, alam) with - (Variable, _) -> - let (ubody, abody) = close fenv cenv body in - (Ulet(Mutable, kind, VP.create id, ulam, ubody), abody) - | (_, Value_const _) - when str = Alias || is_pure lam -> - close (V.Map.add id alam fenv) cenv body - | (_, _) -> - let (ubody, abody) = close (V.Map.add id alam fenv) cenv body in - (Ulet(Immutable, kind, VP.create id, ulam, ubody), abody) - end - | Lletrec(defs, body) -> - if List.for_all - (function (_id, Lfunction _) -> true | _ -> false) - defs - then begin - (* Simple case: only function definitions *) - let (clos, infos) = close_functions fenv cenv 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 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), - approx) - end else begin - (* General case: recursive definition of values *) - let rec clos_defs = function - [] -> ([], fenv) - | (id, lam) :: rem -> - let (udefs, fenv_body) = clos_defs rem in - let (ulam, approx) = close_named fenv cenv 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 - (Uletrec(udefs, ubody), approx) - end - | Lprim(Pdirapply,[funct;arg], loc) - | Lprim(Prevapply,[arg;funct], loc) -> - close fenv cenv (Lapply{ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=funct; - ap_args=[arg]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}) - | Lprim(Pgetglobal id, [], loc) as lam -> - let dbg = Debuginfo.from_location loc in - check_constant_result lam - (getglobal dbg id) - (Compilenv.global_approx id) - | Lprim(Pfield n, [lam], loc) -> - let (ulam, approx) = close fenv cenv lam in - let dbg = Debuginfo.from_location loc in - check_constant_result lam (Uprim(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 - if approx <> Value_unknown then - (!global_approx).(n) <- approx; - let dbg = Debuginfo.from_location loc in - (Uprim(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 dbg = Debuginfo.from_location loc in - (Uprim(Praise k, [ulam], dbg), - Value_unknown) - | Lprim(p, args, loc) -> - let dbg = Debuginfo.from_location loc in - simplif_prim !Clflags.float_const_prop - p (close_list_approx fenv cenv args) dbg - | Lswitch(arg, sw, dbg) -> - let fn fail = - let (uarg, _) = close fenv cenv arg in - let const_index, const_actions, fconst = - close_switch fenv cenv 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 - let ulam = - Uswitch - (uarg, - {us_index_consts = const_index; - us_actions_consts = const_actions; - us_index_blocks = block_index; - us_actions_blocks = block_actions}, - Debuginfo.from_location dbg) - in - (fconst (fblock ulam),Value_unknown) in -(* NB: failaction might get copied, thus it should be some Lstaticraise *) - let fail = sw.sw_failaction in - begin match fail with - | None|Some (Lstaticraise (_,_)) -> fn fail - | Some lamfail -> - if - (sw.sw_numconsts - List.length sw.sw_consts) + - (sw.sw_numblocks - List.length sw.sw_blocks) > 1 - then - let i = next_raise_count () in - let ubody,_ = fn (Some (Lstaticraise (i,[]))) - and uhandler,_ = close fenv cenv lamfail in - Ucatch (i,[],ubody,uhandler),Value_unknown - else fn fail - end - | Lstringswitch(arg,sw,d,_) -> - let uarg,_ = close fenv cenv arg in - let usw = - List.map - (fun (s,act) -> - let uact,_ = close fenv cenv act in - s,uact) - sw in - let ud = - Misc.may_map - (fun d -> - let ud,_ = close fenv cenv d in - ud) d in - Ustringswitch (uarg,usw,ud),Value_unknown - | Lstaticraise (i, args) -> - (Ustaticfail (i, close_list fenv cenv args), Value_unknown) - | Lstaticcatch(body, (i, vars), handler) -> - let (ubody, _) = close fenv cenv body in - let (uhandler, _) = close fenv cenv 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 - (Utrywith(ubody, VP.create id, uhandler), Value_unknown) - | Lifthenelse(arg, ifso, ifnot) -> - begin match close fenv cenv arg with - (uarg, Value_const (Uconst_ptr n)) -> - sequence_constant_expr arg uarg - (close fenv cenv (if n = 0 then ifnot else ifso)) - | (uarg, _ ) -> - let (uifso, _) = close fenv cenv ifso in - let (uifnot, _) = close fenv cenv 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 - (Usequence(ulam1, ulam2), approx) - | Lwhile(cond, body) -> - let (ucond, _) = close fenv cenv cond in - let (ubody, _) = close fenv cenv 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 - (Ufor(VP.create id, ulo, uhi, dir, ubody), Value_unknown) - | Lassign(id, lam) -> - let (ulam, _) = close fenv cenv lam in - (Uassign(id, ulam), Value_unknown) - | Levent(lam, _) -> - close fenv cenv lam - | Lifused _ -> - assert false - -and close_list fenv cenv = function - [] -> [] - | lam :: rem -> - let (ulam, _) = close fenv cenv lam in - ulam :: close_list fenv cenv rem - -and close_list_approx fenv cenv = function - [] -> ([], []) - | lam :: rem -> - let (ulam, approx) = close fenv cenv lam in - let (ulams, approxs) = close_list_approx fenv cenv rem in - (ulam :: ulams, approx :: approxs) - -and close_named fenv cenv id = function - Lfunction _ as funct -> - close_one_function fenv cenv id funct - | lam -> - close fenv cenv lam - -(* Build a shared closure for a set of mutually recursive functions *) - -and close_functions fenv cenv fun_defs = - let fun_defs = - List.flatten - (List.map - (function - | (id, Lfunction{kind; params; return; body; attr; loc}) -> - Simplif.split_default_wrapper ~id ~kind ~params - ~body ~attr ~loc ~return - | _ -> assert false - ) - fun_defs) - in - let inline_attribute = match fun_defs with - | [_, Lfunction{attr = { inline; }}] -> inline - | _ -> Default_inline (* recursive functions can't be inlined *) - in - (* Update and check nesting depth *) - incr function_nesting_depth; - let initially_closed = - !function_nesting_depth < excessive_function_nesting_depth in - (* Determine the free variables of the functions *) - let fv = - V.Set.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in - (* Build the function descriptors for the functions. - Initially all functions are assumed not to need their environment - parameter. *) - let uncurried_defs = - List.map - (function - (id, Lfunction{kind; params; return; body; loc}) -> - let label = Compilenv.make_symbol (Some (V.unique_name id)) in - let arity = List.length params in - let fundesc = - {fun_label = label; - fun_arity = (if kind = Tupled then -arity else arity); - fun_closed = initially_closed; - fun_inline = None; - fun_float_const_prop = !Clflags.float_const_prop } in - let dbg = Debuginfo.from_location loc in - (id, params, return, body, fundesc, dbg) - | (_, _) -> fatal_error "Closure.close_functions") - fun_defs in - (* Build an approximate fenv for compiling the functions *) - let fenv_rec = - List.fold_right - (fun (id, _params, _return, _body, fundesc, _dbg) fenv -> - V.Map.add id (Value_closure(fundesc, Value_unknown)) fenv) - uncurried_defs fenv in - (* Determine the offsets of each function's closure in the shared block *) - let env_pos = ref (-1) in - let clos_offsets = - List.map - (fun (_id, _params, _return, _body, fundesc, _dbg) -> - let pos = !env_pos + 1 in - env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2); - pos) - uncurried_defs in - let fv_pos = !env_pos in - (* This reference will be set to false if the hypothesis that a function - does not use its environment parameter is invalidated. *) - let useless_env = ref initially_closed in - (* Translate each function definition *) - let clos_fundef (id, params, return, body, fundesc, dbg) env_pos = - let env_param = V.create_local "env" in - let cenv_fv = - build_closure_env env_param (fv_pos - env_pos) fv in - let cenv_body = - List.fold_right2 - (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 - if !useless_env && occurs_var env_param ubody then raise NotClosed; - let fun_params = - if !useless_env - then params - else params @ [env_param, Pgenval] - in - let f = - { - label = fundesc.fun_label; - arity = fundesc.fun_arity; - params = List.map (fun (var, kind) -> VP.create var, kind) fun_params; - return; - body = ubody; - dbg; - env = Some env_param; - } - in - (* give more chance of function with default parameters (i.e. - their wrapper functions) to be inlined *) - let n = - List.fold_left - (fun n (id, _) -> n + if V.name id = "*opt*" then 8 else 1) - 0 - fun_params - in - let threshold = - match inline_attribute with - | Default_inline -> - let inline_threshold = - Clflags.Float_arg_helper.get ~key:0 !Clflags.inline_threshold - in - let magic_scale_constant = 8. in - int_of_float (inline_threshold *. magic_scale_constant) + n - | Always_inline -> max_int - | Never_inline -> min_int - | Unroll _ -> assert false - in - let fun_params = List.map (fun (var, _) -> VP.create var) fun_params in - if lambda_smaller ubody threshold - then fundesc.fun_inline <- Some(fun_params, ubody); - - (f, (id, env_pos, Value_closure(fundesc, approx))) in - (* Translate all function definitions. *) - let clos_info_list = - if initially_closed then begin - let snap = Compilenv.snapshot () in - try List.map2 clos_fundef uncurried_defs clos_offsets - with NotClosed -> - (* If the hypothesis that the environment parameters are useless has been - invalidated, then set [fun_closed] to false in all descriptions and - recompile *) - Compilenv.backtrack snap; (* PR#6337 *) - List.iter - (fun (_id, _params, _return, _body, fundesc, _dbg) -> - fundesc.fun_closed <- false; - fundesc.fun_inline <- None; - ) - uncurried_defs; - useless_env := false; - List.map2 clos_fundef uncurried_defs clos_offsets - end else - (* Excessive closure nesting: assume environment parameter is used *) - List.map2 clos_fundef uncurried_defs clos_offsets - in - (* Update nesting depth *) - decr function_nesting_depth; - (* Return the Uclosure node and the list of all identifiers defined, - with offsets and approximations. *) - let (clos, infos) = List.split clos_info_list in - let fv = if !useless_env then [] else fv in - (Uclosure(clos, List.map (close_var 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 - | (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 = - let ncases = List.length cases in - let index = Array.make num_keys 0 - and store = Storer.mk_store () in - - (* First default case *) - begin match default with - | Some def when ncases < num_keys -> - assert (store.act_store () def = 0) - | _ -> () - end ; - (* Then all other cases *) - List.iter - (fun (key,lam) -> - index.(key) <- store.act_store () lam) - cases ; - - (* Explicit sharing with catch/exit, as switcher compilation may - later unshare *) - let acts = store.act_get_shared () in - let hs = ref (fun e -> e) in - - (* Compile actions *) - let actions = - Array.map - (function - | Single lam|Shared (Lstaticraise (_,[]) as lam) -> - let ulam,_ = close fenv cenv lam in - ulam - | Shared lam -> - let ulam,_ = close fenv cenv lam in - let i = next_raise_count () in -(* - let string_of_lambda e = - Printlambda.lambda Format.str_formatter e ; - Format.flush_str_formatter () in - Printf.eprintf "SHARE CLOSURE %i [%s]\n%s\n" i - (string_of_lambda arg) - (string_of_lambda lam) ; -*) - let ohs = !hs in - hs := (fun e -> Ucatch (i,[],ohs e,ulam)) ; - Ustaticfail (i,[])) - acts in - match actions with - | [| |] -> [| |], [| |], !hs (* May happen when default is None *) - | _ -> index, actions, !hs - - -(* Collect exported symbols for structured constants *) - -let collect_exported_structured_constants a = - let rec approx = function - | Value_closure (fd, a) -> - approx a; - begin match fd.fun_inline with - | Some (_, u) -> ulam u - | None -> () - end - | Value_tuple a -> Array.iter approx a - | Value_const c -> const c - | Value_unknown | Value_global_field _ -> () - and const = function - | Uconst_ref (s, (Some c)) -> - Compilenv.add_exported_constant s; - structured_constant c - | Uconst_ref (_s, None) -> assert false (* Cannot be generated *) - | Uconst_int _ | Uconst_ptr _ -> () - and structured_constant = function - | Uconst_block (_, ul) -> List.iter const ul - | Uconst_float _ | Uconst_int32 _ - | Uconst_int64 _ | Uconst_nativeint _ - | Uconst_float_array _ | Uconst_string _ -> () - | Uconst_closure _ -> assert false (* Cannot be generated *) - and ulam = function - | Uvar _ -> () - | Uconst c -> const c - | Udirect_apply (_, ul, _) -> List.iter ulam ul - | Ugeneric_apply (u, ul, _) -> ulam u; List.iter ulam ul - | Uclosure (fl, ul) -> - List.iter (fun f -> ulam f.body) fl; - List.iter ulam ul - | Uoffset(u, _) -> ulam u - | Ulet (_str, _kind, _, u1, u2) -> ulam u1; ulam u2 - | Uphantom_let _ -> no_phantom_lets () - | Uletrec (l, u) -> List.iter (fun (_, u) -> ulam u) l; ulam u - | Uprim (_, ul, _) -> List.iter ulam ul - | Uswitch (u, sl, _dbg) -> - ulam u; - Array.iter ulam sl.us_actions_consts; - Array.iter ulam sl.us_actions_blocks - | Ustringswitch (u,sw,d) -> - ulam u ; - List.iter (fun (_,act) -> ulam act) sw ; - Misc.may ulam d - | Ustaticfail (_, ul) -> List.iter ulam ul - | Ucatch (_, _, u1, u2) - | Utrywith (u1, _, u2) - | Usequence (u1, u2) - | Uwhile (u1, u2) -> ulam u1; ulam u2 - | Uifthenelse (u1, u2, u3) - | Ufor (_, u1, u2, _, u3) -> ulam u1; ulam u2; ulam u3 - | Uassign (_, u) -> ulam u - | Usend (_, u1, u2, ul, _) -> ulam u1; ulam u2; List.iter ulam ul - | Uunreachable -> () - in - approx a - -let reset () = - global_approx := [||]; - function_nesting_depth := 0 - -(* The entry point *) - -let intro 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 opaque = - !Clflags.opaque - || Env.is_imported_opaque (Compilenv.current_unit_name ()) - in - if opaque - then Compilenv.set_global_approx(Value_unknown) - else collect_exported_structured_constants (Value_tuple !global_approx); - global_approx := [||]; - ulam diff --git a/asmcomp/closure.mli b/asmcomp/closure.mli deleted file mode 100644 index f930e0fe..00000000 --- a/asmcomp/closure.mli +++ /dev/null @@ -1,19 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Introduction of closures, uncurrying, recognition of direct calls *) - -val intro: int -> Lambda.lambda -> Clambda.ulambda -val reset : unit -> unit diff --git a/asmcomp/closure_offsets.ml b/asmcomp/closure_offsets.ml deleted file mode 100644 index 51a09f02..00000000 --- a/asmcomp/closure_offsets.ml +++ /dev/null @@ -1,89 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -type result = { - function_offsets : int Closure_id.Map.t; - free_variable_offsets : int Var_within_closure.Map.t; -} - -let add_closure_offsets - { function_offsets; free_variable_offsets } - ({ function_decls; free_vars } : Flambda.set_of_closures) = - (* Build the table mapping the functions declared by the set of closures - to the positions of their individual "infix" closures inside the runtime - closure block. (All of the environment entries will come afterwards.) *) - let assign_function_offset id function_decl (map, env_pos) = - let pos = env_pos + 1 in - let env_pos = - let arity = Flambda_utils.function_arity function_decl in - env_pos - + 1 (* GC header; either [Closure_tag] or [Infix_tag] *) - + 1 (* full application code pointer *) - + 1 (* arity *) - + (if arity > 1 then 1 else 0) (* partial application code pointer *) - in - let closure_id = Closure_id.wrap id in - if Closure_id.Map.mem closure_id map then begin - Misc.fatal_errorf "Closure_offsets.add_closure_offsets: function \ - offset for %a would be defined multiple times" - Closure_id.print closure_id - end; - let map = Closure_id.Map.add closure_id pos map in - (map, env_pos) - in - let function_offsets, free_variable_pos = - Variable.Map.fold assign_function_offset - function_decls.funs (function_offsets, -1) - in - (* Adds the mapping of free variables to their offset. Recall that - projections of [Var_within_closure]s are only currently used when - compiling accesses to the closure of a function from outside that - function (in particular, as a result of inlining). Accesses to - a function's own closure are compiled directly via normal [Var] - accesses. *) - (* CR-someday mshinwell: As discussed with lwhite, maybe this isn't - ideal, and the self accesses should be explicitly marked too. *) - let assign_free_variable_offset var _ (map, pos) = - let var_within_closure = Var_within_closure.wrap var in - if Var_within_closure.Map.mem var_within_closure map then begin - Misc.fatal_errorf "Closure_offsets.add_closure_offsets: free variable \ - offset for %a would be defined multiple times" - Var_within_closure.print var_within_closure - end; - let map = Var_within_closure.Map.add var_within_closure pos map in - (map, pos + 1) - in - let free_variable_offsets, _ = - Variable.Map.fold assign_free_variable_offset - free_vars (free_variable_offsets, free_variable_pos) - in - { function_offsets; - free_variable_offsets; - } - -let compute (program:Flambda.program) = - let init : result = - { function_offsets = Closure_id.Map.empty; - free_variable_offsets = Var_within_closure.Map.empty; - } - in - let r = - List.fold_left add_closure_offsets - init (Flambda_utils.all_sets_of_closures program) - in - r diff --git a/asmcomp/closure_offsets.mli b/asmcomp/closure_offsets.mli deleted file mode 100644 index 7ecf9c27..00000000 --- a/asmcomp/closure_offsets.mli +++ /dev/null @@ -1,27 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Assign numerical offsets, within closure blocks, for code pointers and - environment entries. *) - -type result = private { - function_offsets : int Closure_id.Map.t; - free_variable_offsets : int Var_within_closure.Map.t; -} - -val compute : Flambda.program -> result diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index 3c0b2d78..b2d58d0b 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -159,12 +159,12 @@ and operation = | Ccheckbound type expression = - Cconst_int of int - | Cconst_natint of nativeint - | Cconst_float of float - | Cconst_symbol of string - | Cconst_pointer of int - | Cconst_natpointer of nativeint + Cconst_int of int * Debuginfo.t + | Cconst_natint of nativeint * Debuginfo.t + | Cconst_float of float * Debuginfo.t + | Cconst_symbol of string * Debuginfo.t + | Cconst_pointer of int * Debuginfo.t + | Cconst_natpointer of nativeint * Debuginfo.t | Cblockheader of nativeint * Debuginfo.t | Cvar of Backend_var.t | Clet of Backend_var.With_provenance.t * expression * expression @@ -174,16 +174,18 @@ type expression = | Ctuple of expression list | Cop of operation * expression list * Debuginfo.t | Csequence of expression * expression - | Cifthenelse of expression * expression * expression - | Cswitch of expression * int array * expression array * Debuginfo.t - | Cloop of expression + | Cifthenelse of expression * Debuginfo.t * expression + * Debuginfo.t * expression * Debuginfo.t + | Cswitch of expression * int array * (expression * Debuginfo.t) array + * Debuginfo.t | Ccatch of rec_flag * (int * (Backend_var.With_provenance.t * machtype) list - * expression) list + * expression * Debuginfo.t) list * expression | Cexit of int * expression list | Ctrywith of expression * Backend_var.With_provenance.t * expression + * Debuginfo.t type codegen_option = | Reduce_code_size @@ -215,8 +217,8 @@ type phrase = Cfunction of fundecl | Cdata of data_item list -let ccatch (i, ids, e1, e2)= - Ccatch(Nonrecursive, [i, ids, e2], e1) +let ccatch (i, ids, e1, e2, dbg) = + Ccatch(Nonrecursive, [i, ids, e2, dbg], e1) let reset () = label_counter := 99 diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index 219083a1..a46e6599 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -152,17 +152,15 @@ and operation = | Craise of raise_kind | Ccheckbound -(** Not all cmm expressions currently have [Debuginfo.t] values attached to - them. The ones that do are those that are likely to generate code that - can fairly robustly be mapped back to a source location. In the future - it might be the case that more [Debuginfo.t] annotations are desirable. *) +(** Every basic block should have a corresponding [Debuginfo.t] for its + beginning. *) and expression = - Cconst_int of int - | Cconst_natint of nativeint - | Cconst_float of float - | Cconst_symbol of string - | Cconst_pointer of int - | Cconst_natpointer of nativeint + Cconst_int of int * Debuginfo.t + | Cconst_natint of nativeint * Debuginfo.t + | Cconst_float of float * Debuginfo.t + | Cconst_symbol of string * Debuginfo.t + | Cconst_pointer of int * Debuginfo.t + | Cconst_natpointer of nativeint * Debuginfo.t | Cblockheader of nativeint * Debuginfo.t | Cvar of Backend_var.t | Clet of Backend_var.With_provenance.t * expression * expression @@ -172,16 +170,18 @@ and expression = | Ctuple of expression list | Cop of operation * expression list * Debuginfo.t | Csequence of expression * expression - | Cifthenelse of expression * expression * expression - | Cswitch of expression * int array * expression array * Debuginfo.t - | Cloop of expression + | Cifthenelse of expression * Debuginfo.t * expression + * Debuginfo.t * expression * Debuginfo.t + | Cswitch of expression * int array * (expression * Debuginfo.t) array + * Debuginfo.t | Ccatch of rec_flag * (int * (Backend_var.With_provenance.t * machtype) list - * expression) list + * expression * Debuginfo.t) list * expression | Cexit of int * expression list | Ctrywith of expression * Backend_var.With_provenance.t * expression + * Debuginfo.t type codegen_option = | Reduce_code_size @@ -215,7 +215,7 @@ type phrase = val ccatch : int * (Backend_var.With_provenance.t * machtype) list - * expression * expression + * expression * expression * Debuginfo.t -> expression val reset : unit -> unit diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 68e36d0d..598debb6 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -15,6 +15,8 @@ (* Translation from closed lambda to C-- *) +[@@@ocaml.warning "-40"] + open Misc open Arch open Asttypes @@ -22,8 +24,10 @@ open Primitive open Types open Lambda open Clambda +open Clambda_primitives open Cmm open Cmx_format +open Cmxs_format module String = Misc.Stdlib.String module V = Backend_var @@ -86,7 +90,7 @@ let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8 (* Block headers. Meaning of the tag field: see stdlib/obj.ml *) -let floatarray_tag = Cconst_int Obj.double_array_tag +let floatarray_tag dbg = Cconst_int (Obj.double_array_tag, dbg) let block_header tag sz = Nativeint.add (Nativeint.shift_left (Nativeint.of_int sz) 10) @@ -110,6 +114,10 @@ let string_header len = let boxedint32_header = block_header Obj.custom_tag 2 let boxedint64_header = block_header Obj.custom_tag (1 + 8 / size_addr) let boxedintnat_header = block_header Obj.custom_tag 2 +let caml_nativeint_ops = "caml_nativeint_ops" +let caml_int32_ops = "caml_int32_ops" +let caml_int64_ops = "caml_int64_ops" + let alloc_float_header dbg = Cblockheader (float_header, dbg) let alloc_floatarray_header len dbg = Cblockheader (floatarray_header len, dbg) @@ -124,11 +132,17 @@ let alloc_boxedintnat_header dbg = Cblockheader (boxedintnat_header, dbg) let max_repr_int = max_int asr 1 let min_repr_int = min_int asr 1 -let int_const n = +let int_const dbg n = if n <= max_repr_int && n >= min_repr_int - then Cconst_int((n lsl 1) + 1) + then Cconst_int((n lsl 1) + 1, dbg) else Cconst_natint - (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) + (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n, dbg) + +let natint_const_untagged dbg n = + if n > Nativeint.of_int max_int + || n < Nativeint.of_int min_int + then Cconst_natint (n,dbg) + else Cconst_int (Nativeint.to_int n, dbg) let cint_const n = Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) @@ -139,55 +153,55 @@ let targetint_const n = let add_no_overflow n x c dbg = let d = n + x in - if d = 0 then c else Cop(Caddi, [c; Cconst_int d], dbg) + if d = 0 then c else Cop(Caddi, [c; Cconst_int (d, dbg)], dbg) let rec add_const c n dbg = if n = 0 then c else match c with - | Cconst_int x when no_overflow_add x n -> Cconst_int (x + n) - | Cop(Caddi, [Cconst_int x; c], _) + | Cconst_int (x, _) when no_overflow_add x n -> Cconst_int (x + n, dbg) + | Cop(Caddi, [Cconst_int (x, _); c], _) when no_overflow_add n x -> add_no_overflow n x c dbg - | Cop(Caddi, [c; Cconst_int x], _) + | Cop(Caddi, [c; Cconst_int (x, _)], _) when no_overflow_add n x -> add_no_overflow n x c dbg - | Cop(Csubi, [Cconst_int x; c], _) when no_overflow_add n x -> - Cop(Csubi, [Cconst_int (n + x); c], dbg) - | Cop(Csubi, [c; Cconst_int x], _) when no_overflow_sub n x -> + | Cop(Csubi, [Cconst_int (x, _); c], _) when no_overflow_add n x -> + Cop(Csubi, [Cconst_int (n + x, dbg); c], dbg) + | Cop(Csubi, [c; Cconst_int (x, _)], _) when no_overflow_sub n x -> add_const c (n - x) dbg - | c -> Cop(Caddi, [c; Cconst_int n], dbg) + | c -> Cop(Caddi, [c; Cconst_int (n, dbg)], dbg) let incr_int c dbg = add_const c 1 dbg let decr_int c dbg = add_const c (-1) dbg let rec add_int c1 c2 dbg = match (c1, c2) with - | (Cconst_int n, c) | (c, Cconst_int n) -> + | (Cconst_int (n, _), c) | (c, Cconst_int (n, _)) -> add_const c n dbg - | (Cop(Caddi, [c1; Cconst_int n1], _), c2) -> + | (Cop(Caddi, [c1; Cconst_int (n1, _)], _), c2) -> add_const (add_int c1 c2 dbg) n1 dbg - | (c1, Cop(Caddi, [c2; Cconst_int n2], _)) -> + | (c1, Cop(Caddi, [c2; Cconst_int (n2, _)], _)) -> add_const (add_int c1 c2 dbg) n2 dbg | (_, _) -> Cop(Caddi, [c1; c2], dbg) let rec sub_int c1 c2 dbg = match (c1, c2) with - | (c1, Cconst_int n2) when n2 <> min_int -> + | (c1, Cconst_int (n2, _)) when n2 <> min_int -> add_const c1 (-n2) dbg - | (c1, Cop(Caddi, [c2; Cconst_int n2], _)) when n2 <> min_int -> + | (c1, Cop(Caddi, [c2; Cconst_int (n2, _)], _)) when n2 <> min_int -> add_const (sub_int c1 c2 dbg) (-n2) dbg - | (Cop(Caddi, [c1; Cconst_int n1], _), c2) -> + | (Cop(Caddi, [c1; Cconst_int (n1, _)], _), c2) -> add_const (sub_int c1 c2 dbg) n1 dbg | (c1, c2) -> Cop(Csubi, [c1; c2], dbg) let rec lsl_int c1 c2 dbg = match (c1, c2) with - | (Cop(Clsl, [c; Cconst_int n1], _), Cconst_int n2) + | (Cop(Clsl, [c; Cconst_int (n1, _)], _), Cconst_int (n2, _)) when n1 > 0 && n2 > 0 && n1 + n2 < size_int * 8 -> - Cop(Clsl, [c; Cconst_int (n1 + n2)], dbg) - | (Cop(Caddi, [c1; Cconst_int n1], _), Cconst_int n2) + Cop(Clsl, [c; Cconst_int (n1 + n2, dbg)], dbg) + | (Cop(Caddi, [c1; Cconst_int (n1, _)], _), Cconst_int (n2, _)) when no_overflow_lsl n1 n2 -> add_const (lsl_int c1 c2 dbg) (n1 lsl n2) dbg | (_, _) -> @@ -195,80 +209,87 @@ let rec lsl_int c1 c2 dbg = let is_power2 n = n = 1 lsl Misc.log2 n -and mult_power2 c n dbg = lsl_int c (Cconst_int (Misc.log2 n)) dbg +and mult_power2 c n dbg = lsl_int c (Cconst_int (Misc.log2 n, dbg)) dbg let rec mul_int c1 c2 dbg = match (c1, c2) with - | (c, Cconst_int 0) | (Cconst_int 0, c) -> Csequence (c, Cconst_int 0) - | (c, Cconst_int 1) | (Cconst_int 1, c) -> + | (c, Cconst_int (0, _)) | (Cconst_int (0, _), c) -> + Csequence (c, Cconst_int (0, dbg)) + | (c, Cconst_int (1, _)) | (Cconst_int (1, _), c) -> c - | (c, Cconst_int(-1)) | (Cconst_int(-1), c) -> - sub_int (Cconst_int 0) c dbg - | (c, Cconst_int n) when is_power2 n -> mult_power2 c n dbg - | (Cconst_int n, c) when is_power2 n -> mult_power2 c n dbg - | (Cop(Caddi, [c; Cconst_int n], _), Cconst_int k) | - (Cconst_int k, Cop(Caddi, [c; Cconst_int n], _)) + | (c, Cconst_int(-1, _)) | (Cconst_int(-1, _), c) -> + sub_int (Cconst_int (0, dbg)) c dbg + | (c, Cconst_int (n, _)) when is_power2 n -> mult_power2 c n dbg + | (Cconst_int (n, _), c) when is_power2 n -> mult_power2 c n dbg + | (Cop(Caddi, [c; Cconst_int (n, _)], _), Cconst_int (k, _)) | + (Cconst_int (k, _), Cop(Caddi, [c; Cconst_int (n, _)], _)) when no_overflow_mul n k -> - add_const (mul_int c (Cconst_int k) dbg) (n * k) dbg + add_const (mul_int c (Cconst_int (k, dbg)) dbg) (n * k) dbg | (c1, c2) -> Cop(Cmuli, [c1; c2], dbg) let ignore_low_bit_int = function - Cop(Caddi, [(Cop(Clsl, [_; Cconst_int n], _) as c); Cconst_int 1], _) + Cop(Caddi, + [(Cop(Clsl, [_; Cconst_int (n, _)], _) as c); Cconst_int (1, _)], _) when n > 0 -> c - | Cop(Cor, [c; Cconst_int 1], _) -> c + | Cop(Cor, [c; Cconst_int (1, _)], _) -> c | c -> c let lsr_int c1 c2 dbg = match c2 with - Cconst_int 0 -> + Cconst_int (0, _) -> c1 - | Cconst_int n when n > 0 -> + | Cconst_int (n, _) when n > 0 -> Cop(Clsr, [ignore_low_bit_int c1; c2], dbg) | _ -> Cop(Clsr, [c1; c2], dbg) let asr_int c1 c2 dbg = match c2 with - Cconst_int 0 -> + Cconst_int (0, _) -> c1 - | Cconst_int n when n > 0 -> + | Cconst_int (n, _) when n > 0 -> Cop(Casr, [ignore_low_bit_int c1; c2], dbg) | _ -> Cop(Casr, [c1; c2], dbg) let tag_int i dbg = match i with - Cconst_int n -> - int_const n - | Cop(Casr, [c; Cconst_int n], _) when n > 0 -> - Cop(Cor, [asr_int c (Cconst_int (n - 1)) dbg; Cconst_int 1], dbg) + | Cconst_int (n, _) -> + int_const dbg n + | Cop(Casr, [c; Cconst_int (n, _)], _) when n > 0 -> + Cop(Cor, + [asr_int c (Cconst_int (n - 1, dbg)) dbg; Cconst_int (1, dbg)], + dbg) | c -> - incr_int (lsl_int c (Cconst_int 1) dbg) dbg + incr_int (lsl_int c (Cconst_int (1, dbg)) dbg) dbg let force_tag_int i dbg = match i with - Cconst_int n -> - int_const n - | Cop(Casr, [c; Cconst_int n], dbg') when n > 0 -> - Cop(Cor, [asr_int c (Cconst_int (n - 1)) dbg'; Cconst_int 1], dbg) + Cconst_int (n, _) -> + int_const dbg n + | Cop(Casr, [c; Cconst_int (n, _)], dbg') when n > 0 -> + Cop(Cor, [asr_int c (Cconst_int (n - 1, dbg)) dbg'; Cconst_int (1, dbg)], + dbg) | c -> - Cop(Cor, [lsl_int c (Cconst_int 1) dbg; Cconst_int 1], dbg) + Cop(Cor, [lsl_int c (Cconst_int (1, dbg)) dbg; Cconst_int (1, dbg)], dbg) let untag_int i dbg = match i with - Cconst_int n -> Cconst_int(n asr 1) - | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1], _); Cconst_int 1], _) -> c - | Cop(Cor, [Cop(Casr, [c; Cconst_int n], _); Cconst_int 1], _) + Cconst_int (n, _) -> Cconst_int(n asr 1, dbg) + | Cop(Caddi, [Cop(Clsl, [c; Cconst_int (1, _)], _); Cconst_int (1, _)], _) -> + c + | Cop(Cor, [Cop(Casr, [c; Cconst_int (n, _)], _); Cconst_int (1, _)], _) when n > 0 && n < size_int * 8 -> - Cop(Casr, [c; Cconst_int (n+1)], dbg) - | Cop(Cor, [Cop(Clsr, [c; Cconst_int n], _); Cconst_int 1], _) + Cop(Casr, [c; Cconst_int (n+1, dbg)], dbg) + | Cop(Cor, [Cop(Clsr, [c; Cconst_int (n, _)], _); Cconst_int (1, _)], _) when n > 0 && n < size_int * 8 -> - Cop(Clsr, [c; Cconst_int (n+1)], dbg) - | Cop(Cor, [c; Cconst_int 1], _) -> Cop(Casr, [c; Cconst_int 1], dbg) - | c -> Cop(Casr, [c; Cconst_int 1], dbg) + Cop(Clsr, [c; Cconst_int (n+1, dbg)], dbg) + | Cop(Cor, [c; Cconst_int (1, _)], _) -> + Cop(Casr, [c; Cconst_int (1, dbg)], dbg) + | c -> Cop(Casr, [c; Cconst_int (1, dbg)], dbg) (* Description of the "then" and "else" continuations in [transl_if]. If the "then" continuation is true and the "else" continuation is false then @@ -285,16 +306,18 @@ let invert_then_else = function | Then_false_else_true -> Then_true_else_false | Unknown -> Unknown -let mk_if_then_else cond ifso ifnot = +let mk_if_then_else dbg cond ifso_dbg ifso ifnot_dbg ifnot = match cond with - | Cconst_int 0 -> ifnot - | Cconst_int 1 -> ifso + | Cconst_int (0, _) -> ifnot + | Cconst_int (1, _) -> ifso | _ -> - Cifthenelse(cond, ifso, ifnot) + Cifthenelse(cond, ifso_dbg, ifso, ifnot_dbg, ifnot, dbg) let mk_not dbg cmm = match cmm with - | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1], _); Cconst_int 1], dbg') -> begin + | Cop(Caddi, + [Cop(Clsl, [c; Cconst_int (1, _)], _); Cconst_int (1, _)], dbg') -> + begin match c with | Cop(Ccmpi cmp, [c1; c2], dbg'') -> tag_int @@ -307,15 +330,22 @@ let mk_not dbg cmm = (Cop(Ccmpf (negate_float_comparison cmp), [c1; c2], dbg'')) dbg' | _ -> (* 0 -> 3, 1 -> 1 *) - Cop(Csubi, [Cconst_int 3; Cop(Clsl, [c; Cconst_int 1], dbg)], dbg) + Cop(Csubi, + [Cconst_int (3, dbg); Cop(Clsl, [c; Cconst_int (1, dbg)], dbg)], dbg) end - | Cconst_int 3 -> Cconst_int 1 - | Cconst_int 1 -> Cconst_int 3 + | Cconst_int (3, _) -> Cconst_int (1, dbg) + | Cconst_int (1, _) -> Cconst_int (3, dbg) | c -> (* 1 -> 3, 3 -> 1 *) - Cop(Csubi, [Cconst_int 4; c], dbg) + Cop(Csubi, [Cconst_int (4, dbg); c], dbg) +let create_loop body dbg = + let cont = next_raise_count () in + let call_cont = Cexit (cont, []) in + let body = Csequence (body, call_cont) in + Ccatch (Recursive, [cont, [], body, dbg], call_cont) + (* Turning integer divisions into multiply-high then shift. The [division_parameters] function is used in module Emit for those target platforms that support this optimization. *) @@ -408,21 +438,22 @@ let validate d m p = let raise_regular dbg exc = Csequence( Cop(Cstore (Thirtytwo_signed, Assignment), - [(Cconst_symbol "caml_backtrace_pos"); Cconst_int 0], dbg), + [(Cconst_symbol ("caml_backtrace_pos", dbg)); + Cconst_int (0, dbg)], dbg), Cop(Craise Raise_withtrace,[exc], dbg)) let raise_symbol dbg symb = - raise_regular dbg (Cconst_symbol symb) + raise_regular dbg (Cconst_symbol (symb, dbg)) let rec div_int c1 c2 is_safe dbg = match (c1, c2) with - (c1, Cconst_int 0) -> + (c1, Cconst_int (0, _)) -> Csequence(c1, raise_symbol dbg "caml_exn_Division_by_zero") - | (c1, Cconst_int 1) -> + | (c1, Cconst_int (1, _)) -> c1 - | (Cconst_int n1, Cconst_int n2) -> - Cconst_int (n1 / n2) - | (c1, Cconst_int n) when n <> min_int -> + | (Cconst_int (n1, _), Cconst_int (n2, _)) -> + Cconst_int (n1 / n2, dbg) + | (c1, Cconst_int (n, _)) when n <> min_int -> let l = Misc.log2 n in if n = 1 lsl l then (* Algorithm: @@ -432,12 +463,16 @@ let rec div_int c1 c2 is_safe dbg = res = shift-right-signed(c1 + t, l) *) Cop(Casr, [bind "dividend" c1 (fun c1 -> - let t = asr_int c1 (Cconst_int (l - 1)) dbg in - let t = lsr_int t (Cconst_int (Nativeint.size - l)) dbg in + let t = asr_int c1 (Cconst_int (l - 1, dbg)) dbg in + let t = + lsr_int t (Cconst_int (Nativeint.size - l, dbg)) dbg + in add_int c1 t dbg); - Cconst_int l], dbg) + Cconst_int (l, dbg)], dbg) else if n < 0 then - sub_int (Cconst_int 0) (div_int c1 (Cconst_int (-n)) is_safe dbg) dbg + sub_int (Cconst_int (0, dbg)) + (div_int c1 (Cconst_int (-n, dbg)) is_safe dbg) + dbg else begin let (m, p) = divimm_parameters (Nativeint.of_int n) in (* Algorithm: @@ -447,10 +482,12 @@ let rec div_int c1 c2 is_safe dbg = res = t + sign-bit(c1) *) bind "dividend" c1 (fun c1 -> - let t = Cop(Cmulhi, [c1; Cconst_natint m], dbg) in + let t = Cop(Cmulhi, [c1; Cconst_natint (m, dbg)], dbg) in let t = if m < 0n then Cop(Caddi, [t; c1], dbg) else t in - let t = if p > 0 then Cop(Casr, [t; Cconst_int p], dbg) else t in - add_int t (lsr_int c1 (Cconst_int (Nativeint.size - 1)) dbg) dbg) + let t = + if p > 0 then Cop(Casr, [t; Cconst_int (p, dbg)], dbg) else t + in + add_int t (lsr_int c1 (Cconst_int (Nativeint.size - 1, dbg)) dbg) dbg) end | (c1, c2) when !Clflags.unsafe || is_safe = Lambda.Unsafe -> Cop(Cdivi, [c1; c2], dbg) @@ -458,18 +495,21 @@ let rec div_int c1 c2 is_safe dbg = bind "divisor" c2 (fun c2 -> bind "dividend" c1 (fun c1 -> Cifthenelse(c2, + dbg, Cop(Cdivi, [c1; c2], dbg), - raise_symbol dbg "caml_exn_Division_by_zero"))) + dbg, + raise_symbol dbg "caml_exn_Division_by_zero", + dbg))) let mod_int c1 c2 is_safe dbg = match (c1, c2) with - (c1, Cconst_int 0) -> + (c1, Cconst_int (0, _)) -> Csequence(c1, raise_symbol dbg "caml_exn_Division_by_zero") - | (c1, Cconst_int (1 | (-1))) -> - Csequence(c1, Cconst_int 0) - | (Cconst_int n1, Cconst_int n2) -> - Cconst_int (n1 mod n2) - | (c1, (Cconst_int n as c2)) when n <> min_int -> + | (c1, Cconst_int ((1 | (-1)), _)) -> + Csequence(c1, Cconst_int (0, dbg)) + | (Cconst_int (n1, _), Cconst_int (n2, _)) -> + Cconst_int (n1 mod n2, dbg) + | (c1, (Cconst_int (n, _) as c2)) when n <> min_int -> let l = Misc.log2 n in if n = 1 lsl l then (* Algorithm: @@ -480,10 +520,10 @@ let mod_int c1 c2 is_safe dbg = res = c1 - t *) bind "dividend" c1 (fun c1 -> - let t = asr_int c1 (Cconst_int (l - 1)) dbg in - let t = lsr_int t (Cconst_int (Nativeint.size - l)) dbg in + let t = asr_int c1 (Cconst_int (l - 1, dbg)) dbg in + let t = lsr_int t (Cconst_int (Nativeint.size - l, dbg)) dbg in let t = add_int c1 t dbg in - let t = Cop(Cand, [t; Cconst_int (-n)], dbg) in + let t = Cop(Cand, [t; Cconst_int (-n, dbg)], dbg) in sub_int c1 t dbg) else bind "dividend" c1 (fun c1 -> @@ -495,15 +535,18 @@ let mod_int c1 c2 is_safe dbg = bind "divisor" c2 (fun c2 -> bind "dividend" c1 (fun c1 -> Cifthenelse(c2, + dbg, Cop(Cmodi, [c1; c2], dbg), - raise_symbol dbg "caml_exn_Division_by_zero"))) + dbg, + raise_symbol dbg "caml_exn_Division_by_zero", + dbg))) (* Division or modulo on boxed integers. The overflow case min_int / -1 can occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *) let is_different_from x = function - Cconst_int n -> n <> x - | Cconst_natint n -> n <> Nativeint.of_int x + Cconst_int (n, _) -> n <> x + | Cconst_natint (n, _) -> n <> Nativeint.of_int x | _ -> false let safe_divmod_bi mkop is_safe mkm1 c1 c2 bi dbg = @@ -513,27 +556,33 @@ let safe_divmod_bi mkop is_safe mkm1 c1 c2 bi dbg = if Arch.division_crashes_on_overflow && (size_int = 4 || bi <> Pint32) && not (is_different_from (-1) c2) - then Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int(-1)], dbg), c, mkm1 c1 dbg) - else c)) + then + Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int (-1, dbg)], dbg), + dbg, c, + dbg, mkm1 c1 dbg, + dbg) + else + c)) let safe_div_bi is_safe = safe_divmod_bi div_int is_safe - (fun c1 dbg -> Cop(Csubi, [Cconst_int 0; c1], dbg)) + (fun c1 dbg -> Cop(Csubi, [Cconst_int (0, dbg); c1], dbg)) let safe_mod_bi is_safe = - safe_divmod_bi mod_int is_safe (fun _ _ -> Cconst_int 0) + safe_divmod_bi mod_int is_safe (fun _ dbg -> Cconst_int (0, dbg)) (* Bool *) let test_bool dbg cmm = match cmm with - | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1], _); Cconst_int 1], _) -> c - | Cconst_int n -> + | Cop(Caddi, [Cop(Clsl, [c; Cconst_int (1, _)], _); Cconst_int (1, _)], _) -> + c + | Cconst_int (n, dbg) -> if n = 1 then - Cconst_int 0 + Cconst_int (0, dbg) else - Cconst_int 1 - | c -> Cop(Ccmpi Cne, [c; Cconst_int 1], dbg) + Cconst_int (1, dbg) + | c -> Cop(Ccmpi Cne, [c; Cconst_int (1, dbg)], dbg) (* Float *) @@ -541,7 +590,7 @@ let box_float dbg c = Cop(Calloc, [alloc_float_header dbg; c], dbg) let map_ccatch f rec_flag handlers body = let handlers = List.map - (fun (n, ids, handler) -> (n, ids, f handler)) + (fun (n, ids, handler, dbg) -> (n, ids, f handler, dbg)) handlers in Ccatch(rec_flag, handlers, f body) @@ -550,14 +599,19 @@ let rec unbox_float dbg cmm = | Cop(Calloc, [Cblockheader (header, _); c], _) when header = float_header -> c | Clet(id, exp, body) -> Clet(id, exp, unbox_float dbg body) - | Cifthenelse(cond, e1, e2) -> - Cifthenelse(cond, unbox_float dbg e1, unbox_float dbg e2) + | Cifthenelse(cond, ifso_dbg, e1, ifnot_dbg, e2, dbg) -> + Cifthenelse(cond, + ifso_dbg, unbox_float dbg e1, + ifnot_dbg, unbox_float dbg e2, + dbg) | Csequence(e1, e2) -> Csequence(e1, unbox_float dbg e2) | Cswitch(e, tbl, el, dbg') -> - Cswitch(e, tbl, Array.map (unbox_float dbg) el, dbg') + Cswitch(e, tbl, + Array.map (fun (expr, dbg) -> unbox_float dbg expr, dbg) el, dbg') | Ccatch(rec_flag, handlers, body) -> map_ccatch (unbox_float dbg) rec_flag handlers body - | Ctrywith(e1, id, e2) -> Ctrywith(unbox_float dbg e1, id, unbox_float dbg e2) + | Ctrywith(e1, id, e2, dbg) -> + Ctrywith(unbox_float dbg e1, id, unbox_float dbg e2, dbg) | c -> Cop(Cload (Double_u, Immutable), [c], dbg) (* Complex *) @@ -567,25 +621,31 @@ let box_complex dbg c_re c_im = let complex_re c dbg = Cop(Cload (Double_u, Immutable), [c], dbg) let complex_im c dbg = Cop(Cload (Double_u, Immutable), - [Cop(Cadda, [c; Cconst_int size_float], dbg)], dbg) + [Cop(Cadda, [c; Cconst_int (size_float, dbg)], dbg)], + dbg) (* Unit *) -let return_unit c = Csequence(c, Cconst_pointer 1) +let return_unit dbg c = Csequence(c, Cconst_pointer (1, dbg)) let rec remove_unit = function - Cconst_pointer 1 -> Ctuple [] - | Csequence(c, Cconst_pointer 1) -> c + Cconst_pointer (1, _) -> Ctuple [] + | Csequence(c, Cconst_pointer (1, _)) -> c | Csequence(c1, c2) -> Csequence(c1, remove_unit c2) - | Cifthenelse(cond, ifso, ifnot) -> - Cifthenelse(cond, remove_unit ifso, remove_unit ifnot) + | Cifthenelse(cond, ifso_dbg, ifso, ifnot_dbg, ifnot, dbg) -> + Cifthenelse(cond, + ifso_dbg, remove_unit ifso, + ifnot_dbg, + remove_unit ifnot, dbg) | Cswitch(sel, index, cases, dbg) -> - Cswitch(sel, index, Array.map remove_unit cases, dbg) + Cswitch(sel, index, + Array.map (fun (case, dbg) -> remove_unit case, dbg) cases, + dbg) | Ccatch(rec_flag, handlers, body) -> map_ccatch remove_unit rec_flag handlers body - | Ctrywith(body, exn, handler) -> - Ctrywith(remove_unit body, exn, remove_unit handler) + | Ctrywith(body, exn, handler, dbg) -> + Ctrywith(remove_unit body, exn, remove_unit handler, dbg) | Clet(id, c1, c2) -> Clet(id, c1, remove_unit c2) | Cop(Capply _mty, args, dbg) -> @@ -601,7 +661,7 @@ let rec remove_unit = function let field_address ptr n dbg = if n = 0 then ptr - else Cop(Cadda, [ptr; Cconst_int(n * size_addr)], dbg) + else Cop(Cadda, [ptr; Cconst_int(n * size_addr, dbg)], dbg) let get_field env ptr n dbg = let mut = @@ -629,11 +689,11 @@ let get_header ptr dbg = (* We cannot deem this as [Immutable] due to the presence of [Obj.truncate] and [Obj.set_tag]. *) Cop(Cload (Word_int, Mutable), - [Cop(Cadda, [ptr; Cconst_int(-size_int)], dbg)], dbg) + [Cop(Cadda, [ptr; Cconst_int(-size_int, dbg)], dbg)], dbg) let get_header_without_profinfo ptr dbg = if Config.profinfo then - Cop(Cand, [get_header ptr dbg; Cconst_int non_profinfo_mask], dbg) + Cop(Cand, [get_header ptr dbg; Cconst_int (non_profinfo_mask, dbg)], dbg) else get_header ptr dbg @@ -642,13 +702,13 @@ let tag_offset = let get_tag ptr dbg = if Proc.word_addressed then (* If byte loads are slow *) - Cop(Cand, [get_header ptr dbg; Cconst_int 255], dbg) + Cop(Cand, [get_header ptr dbg; Cconst_int (255, dbg)], dbg) else (* If byte loads are efficient *) Cop(Cload (Byte_unsigned, Mutable), (* Same comment as [get_header] above *) - [Cop(Cadda, [ptr; Cconst_int(tag_offset)], dbg)], dbg) + [Cop(Cadda, [ptr; Cconst_int(tag_offset, dbg)], dbg)], dbg) let get_size ptr dbg = - Cop(Clsr, [get_header_without_profinfo ptr dbg; Cconst_int 10], dbg) + Cop(Clsr, [get_header_without_profinfo ptr dbg; Cconst_int (10, dbg)], dbg) (* Array indexing *) @@ -659,19 +719,21 @@ let wordsize_shift = 9 let numfloat_shift = 9 + log2_size_float - log2_size_addr let is_addr_array_hdr hdr dbg = - Cop(Ccmpi Cne, [Cop(Cand, [hdr; Cconst_int 255], dbg); floatarray_tag], dbg) + Cop(Ccmpi Cne, + [Cop(Cand, [hdr; Cconst_int (255, dbg)], dbg); floatarray_tag dbg], + dbg) let is_addr_array_ptr ptr dbg = - Cop(Ccmpi Cne, [get_tag ptr dbg; floatarray_tag], dbg) + Cop(Ccmpi Cne, [get_tag ptr dbg; floatarray_tag dbg], dbg) let addr_array_length hdr dbg = - Cop(Clsr, [hdr; Cconst_int wordsize_shift], dbg) + Cop(Clsr, [hdr; Cconst_int (wordsize_shift, dbg)], dbg) let float_array_length hdr dbg = - Cop(Clsr, [hdr; Cconst_int numfloat_shift], dbg) + Cop(Clsr, [hdr; Cconst_int (numfloat_shift, dbg)], dbg) let lsl_const c n dbg = if n = 0 then c - else Cop(Clsl, [c; Cconst_int n], dbg) + else Cop(Clsl, [c; Cconst_int (n, dbg)], dbg) (* Produces a pointer to the element of the array [ptr] on the position [ofs] with the given element [log2size] log2 element size. [ofs] is given as a @@ -688,22 +750,25 @@ let array_indexing ?typ log2size ptr ofs dbg = | Some Int -> Caddi | _ -> assert false in match ofs with - | Cconst_int n -> + | Cconst_int (n, _) -> let i = n asr 1 in - if i = 0 then ptr else Cop(add, [ptr; Cconst_int(i lsl log2size)], dbg) - | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1], _); Cconst_int 1], dbg') -> + if i = 0 then ptr + else Cop(add, [ptr; Cconst_int(i lsl log2size, dbg)], dbg) + | Cop(Caddi, + [Cop(Clsl, [c; Cconst_int (1, _)], _); Cconst_int (1, _)], dbg') -> Cop(add, [ptr; lsl_const c log2size dbg], dbg') - | Cop(Caddi, [c; Cconst_int n], dbg') when log2size = 0 -> - Cop(add, [Cop(add, [ptr; untag_int c dbg], dbg); Cconst_int (n asr 1)], + | Cop(Caddi, [c; Cconst_int (n, _)], dbg') when log2size = 0 -> + Cop(add, + [Cop(add, [ptr; untag_int c dbg], dbg); Cconst_int (n asr 1, dbg)], dbg') - | Cop(Caddi, [c; Cconst_int n], _) -> + | Cop(Caddi, [c; Cconst_int (n, _)], _) -> Cop(add, [Cop(add, [ptr; lsl_const c (log2size - 1) dbg], dbg); - Cconst_int((n-1) lsl (log2size - 1))], dbg) + Cconst_int((n-1) lsl (log2size - 1), dbg)], dbg) | _ when log2size = 0 -> Cop(add, [ptr; untag_int ofs dbg], dbg) | _ -> Cop(add, [Cop(add, [ptr; lsl_const ofs (log2size - 1) dbg], dbg); - Cconst_int((-1) lsl (log2size - 1))], dbg) + Cconst_int((-1) lsl (log2size - 1), dbg)], dbg) let addr_array_ref arr ofs dbg = Cop(Cload (Word_val, Mutable), @@ -736,20 +801,23 @@ let float_array_set arr ofs newval dbg = let string_length exp dbg = bind "str" exp (fun str -> - let tmp_var = V.create_local "tmp" in + let tmp_var = V.create_local "*tmp*" in Clet(VP.create tmp_var, Cop(Csubi, [Cop(Clsl, [get_size str dbg; - Cconst_int log2_size_addr], + Cconst_int (log2_size_addr, dbg)], dbg); - Cconst_int 1], + Cconst_int (1, dbg)], dbg), Cop(Csubi, [Cvar tmp_var; Cop(Cload (Byte_unsigned, Mutable), [Cop(Cadda, [str; Cvar tmp_var], dbg)], dbg)], dbg))) +let bigstring_length ba dbg = + Cop(Cload (Word_int, Mutable), [field_address ba 5 dbg], dbg) + (* Message sending *) let lookup_tag obj tag dbg = @@ -768,7 +836,7 @@ let call_cached_method obj tag cache pos args dbg = let cache = array_indexing log2_size_addr cache pos dbg in Compilenv.need_send_fun arity; Cop(Capply typ_val, - Cconst_symbol("caml_send" ^ Int.to_string arity) :: + Cconst_symbol("caml_send" ^ Int.to_string arity, dbg) :: obj :: tag :: cache :: args, dbg) @@ -778,14 +846,14 @@ let make_alloc_generic set_fn dbg tag wordsize args = if wordsize <= Config.max_young_wosize then Cop(Calloc, Cblockheader(block_header tag wordsize, dbg) :: args, dbg) else begin - let id = V.create_local "alloc" in + let id = V.create_local "*alloc*" in let rec fill_fields idx = function [] -> Cvar id - | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1 dbg, + | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int (idx, dbg)) e1 dbg, fill_fields (idx + 2) el) in Clet(VP.create id, Cop(Cextcall("caml_alloc", typ_val, true, None), - [Cconst_int wordsize; Cconst_int tag], dbg), + [Cconst_int (wordsize, dbg); Cconst_int (tag, dbg)], dbg), fill_fields 1 args) end @@ -803,8 +871,9 @@ let make_float_alloc dbg tag args = (* Bounds checking *) let make_checkbound dbg = function - | [Cop(Clsr, [a1; Cconst_int n], _); Cconst_int m] when (m lsl n) > n -> - Cop(Ccheckbound, [a1; Cconst_int(m lsl n + 1 lsl n - 1)], dbg) + | [Cop(Clsr, [a1; Cconst_int (n, _)], _); Cconst_int (m, _)] + when (m lsl n) > n -> + Cop(Ccheckbound, [a1; Cconst_int(m lsl n + 1 lsl n - 1, dbg)], dbg) | args -> Cop(Ccheckbound, args, dbg) @@ -830,6 +899,7 @@ let fundecls_size fundecls = type rhs_kind = | RHS_block of int + | RHS_infix of { blocksize : int; offset : int } | RHS_floatblock of int | RHS_nonrec ;; @@ -871,6 +941,11 @@ let rec expr_size env = function expr_size env closure | Usequence(_exp, exp') -> expr_size env exp' + | Uoffset (exp, offset) -> + (match expr_size env exp with + | RHS_block blocksize -> RHS_infix { blocksize; offset } + | RHS_nonrec -> RHS_nonrec + | _ -> assert false) | _ -> RHS_nonrec (* Record application and currying functions *) @@ -889,50 +964,107 @@ let transl_int_comparison cmp = cmp let transl_float_comparison cmp = cmp -(* Translate structured constants *) +(* Translate structured constants to Cmm data items *) -let transl_constant = function +let transl_constant dbg = function | Uconst_int n -> - int_const n + int_const dbg n | Uconst_ptr n -> if n <= max_repr_int && n >= min_repr_int - then Cconst_pointer((n lsl 1) + 1) + then Cconst_pointer((n lsl 1) + 1, dbg) else Cconst_natpointer - (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) + (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n, + dbg) | Uconst_ref (label, _) -> - Cconst_symbol label + Cconst_symbol (label, dbg) -let transl_structured_constant cst = - let label = Compilenv.new_structured_constant cst ~shared:true in - Cconst_symbol label +let cdefine_symbol (symb, (global : Cmmgen_state.is_global)) = + match global with + | Global -> [Cglobal_symbol symb; Cdefine_symbol symb] + | Local -> [Cdefine_symbol symb] -(* Translate constant closures *) +let emit_block symb is_global white_header cont = + (* Headers for structured constants must be marked black in case we + are in no-naked-pointers mode. See [caml_darken]. *) + let black_header = Nativeint.logor white_header caml_black in + Cint black_header :: cdefine_symbol (symb, is_global) @ cont -type is_global = Global | Not_global +let rec emit_structured_constant (sym, is_global) cst cont = + match cst with + | Uconst_float s -> + emit_block sym is_global float_header (Cdouble s :: cont) + | Uconst_string s -> + emit_block sym is_global (string_header (String.length s)) + (emit_string_constant s cont) + | Uconst_int32 n -> + emit_block sym is_global boxedint32_header + (emit_boxed_int32_constant n cont) + | Uconst_int64 n -> + emit_block sym is_global boxedint64_header + (emit_boxed_int64_constant n cont) + | Uconst_nativeint n -> + emit_block sym is_global boxedintnat_header + (emit_boxed_nativeint_constant n cont) + | Uconst_block (tag, csts) -> + let cont = List.fold_right emit_constant csts cont in + emit_block sym is_global (block_header tag (List.length csts)) cont + | Uconst_float_array fields -> + emit_block sym is_global (floatarray_header (List.length fields)) + (Misc.map_end (fun f -> Cdouble f) fields cont) + | Uconst_closure(fundecls, lbl, fv) -> + Cmmgen_state.add_constant lbl (Const_closure (is_global, fundecls, fv)); + List.iter (fun f -> Cmmgen_state.add_function f) fundecls; + cont -type symbol_defn = string * is_global +and emit_constant cst cont = + match cst with + | Uconst_int n | Uconst_ptr n -> + cint_const n + :: cont + | Uconst_ref (sym, _) -> + Csymbol_address sym :: cont -type cmm_constant = - | Const_closure of symbol_defn * ufunction list * uconstant list - | Const_table of symbol_defn * data_item list +and emit_string_constant s cont = + let n = size_int - 1 - (String.length s) mod size_int in + Cstring s :: Cskip n :: Cint8 n :: cont -let cmm_constants = - ref ([] : cmm_constant list) +and emit_boxed_int32_constant n cont = + let n = Nativeint.of_int32 n in + if size_int = 8 then + Csymbol_address caml_int32_ops :: Cint32 n :: Cint32 0n :: cont + else + Csymbol_address caml_int32_ops :: Cint n :: cont -let add_cmm_constant c = - cmm_constants := c :: !cmm_constants +and emit_boxed_nativeint_constant n cont = + Csymbol_address caml_nativeint_ops :: Cint n :: cont + +and emit_boxed_int64_constant n cont = + let lo = Int64.to_nativeint n in + if size_int = 8 then + Csymbol_address caml_int64_ops :: Cint lo :: cont + else begin + let hi = Int64.to_nativeint (Int64.shift_right n 32) in + if big_endian then + Csymbol_address caml_int64_ops :: Cint hi :: Cint lo :: cont + else + Csymbol_address caml_int64_ops :: Cint lo :: Cint hi :: cont + end (* Boxed integers *) -let box_int_constant bi n = +let box_int_constant sym bi n = match bi with - Pnativeint -> Uconst_nativeint n - | Pint32 -> Uconst_int32 (Nativeint.to_int32 n) - | Pint64 -> Uconst_int64 (Int64.of_nativeint n) - -let caml_nativeint_ops = "caml_nativeint_ops" -let caml_int32_ops = "caml_int32_ops" -let caml_int64_ops = "caml_int64_ops" + Pnativeint -> + emit_block sym Local boxedintnat_header + (emit_boxed_nativeint_constant n []) + | Pint32 -> + let n = Nativeint.to_int32 n in + emit_block sym Local boxedint32_header + (emit_boxed_int32_constant n []) + | Pint64 -> + let n = Int64.of_nativeint n in + emit_block sym Local boxedint64_header + (emit_boxed_int64_constant n []) let operations_boxed_int bi = match bi with @@ -948,76 +1080,92 @@ let alloc_header_boxed_int bi = let box_int dbg bi arg = match arg with - Cconst_int n -> - transl_structured_constant (box_int_constant bi (Nativeint.of_int n)) - | Cconst_natint n -> - transl_structured_constant (box_int_constant bi n) + | Cconst_int (n, _) -> + let sym = Compilenv.new_const_symbol () in + let data_items = box_int_constant sym bi (Nativeint.of_int n) in + Cmmgen_state.add_data_items data_items; + Cconst_symbol (sym, dbg) + | Cconst_natint (n, _) -> + let sym = Compilenv.new_const_symbol () in + let data_items = box_int_constant sym bi n in + Cmmgen_state.add_data_items data_items; + Cconst_symbol (sym, dbg) | _ -> let arg' = if bi = Pint32 && size_int = 8 && big_endian - then Cop(Clsl, [arg; Cconst_int 32], dbg) + then Cop(Clsl, [arg; Cconst_int (32, dbg)], dbg) else arg in Cop(Calloc, [alloc_header_boxed_int bi dbg; - Cconst_symbol(operations_boxed_int bi); + Cconst_symbol(operations_boxed_int bi, dbg); arg'], dbg) let split_int64_for_32bit_target arg dbg = bind "split_int64" arg (fun arg -> - let first = Cop (Cadda, [Cconst_int size_int; arg], dbg) in - let second = Cop (Cadda, [Cconst_int (2 * size_int); arg], dbg) in + let first = Cop (Cadda, [Cconst_int (size_int, dbg); arg], dbg) in + let second = Cop (Cadda, [Cconst_int (2 * size_int, dbg); arg], dbg) in Ctuple [Cop (Cload (Thirtytwo_unsigned, Mutable), [first], dbg); Cop (Cload (Thirtytwo_unsigned, Mutable), [second], dbg)]) let alloc_matches_boxed_int bi ~hdr ~ops = match bi, hdr, ops with - | Pnativeint, Cblockheader (hdr, _dbg), Cconst_symbol sym -> + | Pnativeint, Cblockheader (hdr, _dbg), Cconst_symbol (sym, _) -> Nativeint.equal hdr boxedintnat_header && String.equal sym caml_nativeint_ops - | Pint32, Cblockheader (hdr, _dbg), Cconst_symbol sym -> + | Pint32, Cblockheader (hdr, _dbg), Cconst_symbol (sym, _) -> Nativeint.equal hdr boxedint32_header && String.equal sym caml_int32_ops - | Pint64, Cblockheader (hdr, _dbg), Cconst_symbol sym -> + | Pint64, Cblockheader (hdr, _dbg), Cconst_symbol (sym, _) -> Nativeint.equal hdr boxedint64_header && String.equal sym caml_int64_ops | (Pnativeint | Pint32 | Pint64), _, _ -> false let rec unbox_int bi arg dbg = match arg with - Cop(Calloc, [hdr; ops; Cop(Clsl, [contents; Cconst_int 32], dbg')], _dbg) + Cop(Calloc, [hdr; ops; Cop(Clsl, [contents; Cconst_int (32, _)], dbg')], + _dbg) when bi = Pint32 && size_int = 8 && big_endian && alloc_matches_boxed_int bi ~hdr ~ops -> (* Force sign-extension of low 32 bits *) - Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32], dbg'); Cconst_int 32], + Cop(Casr, [Cop(Clsl, [contents; Cconst_int (32, dbg)], dbg'); + Cconst_int (32, dbg)], dbg) | Cop(Calloc, [hdr; ops; contents], _dbg) when bi = Pint32 && size_int = 8 && not big_endian && alloc_matches_boxed_int bi ~hdr ~ops -> (* Force sign-extension of low 32 bits *) - Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32], dbg); Cconst_int 32], dbg) + Cop(Casr, [Cop(Clsl, [contents; Cconst_int (32, dbg)], dbg); + Cconst_int (32, dbg)], + dbg) | Cop(Calloc, [hdr; ops; contents], _dbg) when alloc_matches_boxed_int bi ~hdr ~ops -> contents | Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body dbg) - | Cifthenelse(cond, e1, e2) -> - Cifthenelse(cond, unbox_int bi e1 dbg, unbox_int bi e2 dbg) + | Cifthenelse(cond, ifso_dbg, e1, ifnot_dbg, e2, dbg) -> + Cifthenelse(cond, + ifso_dbg, unbox_int bi e1 ifso_dbg, + ifnot_dbg, unbox_int bi e2 ifnot_dbg, + dbg) | Csequence(e1, e2) -> Csequence(e1, unbox_int bi e2 dbg) | Cswitch(e, tbl, el, dbg') -> - Cswitch(e, tbl, Array.map (fun e -> unbox_int bi e dbg) el, dbg') + Cswitch(e, tbl, + Array.map (fun (e, dbg) -> unbox_int bi e dbg, dbg) el, + dbg') | Ccatch(rec_flag, handlers, body) -> map_ccatch (fun e -> unbox_int bi e dbg) rec_flag handlers body - | Ctrywith(e1, id, e2) -> - Ctrywith(unbox_int bi e1 dbg, id, unbox_int bi e2 dbg) + | Ctrywith(e1, id, e2, handler_dbg) -> + Ctrywith(unbox_int bi e1 dbg, id, + unbox_int bi e2 handler_dbg, handler_dbg) | _ -> if size_int = 4 && bi = Pint64 then split_int64_for_32bit_target arg dbg else Cop( Cload((if bi = Pint32 then Thirtytwo_signed else Word_int), Mutable), - [Cop(Cadda, [arg; Cconst_int size_addr], dbg)], dbg) + [Cop(Cadda, [arg; Cconst_int (size_addr, dbg)], dbg)], dbg) let make_unsigned_int bi arg dbg = if bi = Pint32 && size_int = 8 - then Cop(Cand, [arg; Cconst_natint 0xFFFFFFFFn], dbg) + then Cop(Cand, [arg; Cconst_natint (0xFFFFFFFFn, dbg)], dbg) else arg (* Boxed numbers *) @@ -1106,7 +1254,7 @@ let bigarray_indexing unsafe elt_kind layout b args dbg = ba_indexing (4 + List.length args) (-1) (List.rev args) | Pbigarray_fortran_layout -> ba_indexing 5 1 - (List.map (fun idx -> sub_int idx (Cconst_int 2) dbg) args) + (List.map (fun idx -> sub_int idx (Cconst_int (2, dbg)) dbg) args) and elt_size = bigarray_elt_size elt_kind in (* [array_indexing] can simplify the given expressions *) @@ -1141,7 +1289,7 @@ let bigarray_get unsafe elt_kind layout b args dbg = (Cop(Cload (kind, Mutable), [addr], dbg)) (fun reval -> bind "imval" (Cop(Cload (kind, Mutable), - [Cop(Cadda, [addr; Cconst_int sz], dbg)], dbg)) + [Cop(Cadda, [addr; Cconst_int (sz, dbg)], dbg)], dbg)) (fun imval -> box_complex dbg reval imval))) | _ -> Cop(Cload (bigarray_word_kind elt_kind, Mutable), @@ -1160,7 +1308,8 @@ let bigarray_set unsafe elt_kind layout b args newval dbg = Csequence( Cop(Cstore (kind, Assignment), [addr; complex_re newv dbg], dbg), Cop(Cstore (kind, Assignment), - [Cop(Cadda, [addr; Cconst_int sz], dbg); complex_im newv dbg], + [Cop(Cadda, [addr; Cconst_int (sz, dbg)], dbg); + complex_im newv dbg], dbg)))) | _ -> Cop(Cstore (bigarray_word_kind elt_kind, Assignment), @@ -1171,11 +1320,13 @@ let unaligned_load_16 ptr idx dbg = if Arch.allow_unaligned_access then Cop(Cload (Sixteen_unsigned, Mutable), [add_int ptr idx dbg], dbg) else + let cconst_int i = Cconst_int (i, dbg) in let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in let v2 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg], dbg) in + [add_int (add_int ptr idx dbg) (cconst_int 1) dbg], dbg) + in let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in - Cop(Cor, [lsl_int b1 (Cconst_int 8) dbg; b2], dbg) + Cop(Cor, [lsl_int b1 (cconst_int 8) dbg; b2], dbg) let unaligned_set_16 ptr idx newval dbg = if Arch.allow_unaligned_access @@ -1183,35 +1334,41 @@ let unaligned_set_16 ptr idx newval dbg = Cop(Cstore (Sixteen_unsigned, Assignment), [add_int ptr idx dbg; newval], dbg) else + let cconst_int i = Cconst_int (i, dbg) in let v1 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8], dbg); Cconst_int 0xFF], dbg) + Cop(Cand, [Cop(Clsr, [newval; cconst_int 8], dbg); + cconst_int 0xFF], dbg) in - let v2 = Cop(Cand, [newval; Cconst_int 0xFF], dbg) in + let v2 = Cop(Cand, [newval; cconst_int 0xFF], dbg) in let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in Csequence( Cop(Cstore (Byte_unsigned, Assignment), [add_int ptr idx dbg; b1], dbg), Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg; b2], dbg)) + [add_int (add_int ptr idx dbg) (cconst_int 1) dbg; b2], dbg)) let unaligned_load_32 ptr idx dbg = if Arch.allow_unaligned_access then Cop(Cload (Thirtytwo_unsigned, Mutable), [add_int ptr idx dbg], dbg) else + let cconst_int i = Cconst_int (i, dbg) in let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in let v2 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg], dbg) in + [add_int (add_int ptr idx dbg) (cconst_int 1) dbg], dbg) + in let v3 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (Cconst_int 2) dbg], dbg) in + [add_int (add_int ptr idx dbg) (cconst_int 2) dbg], dbg) + in let v4 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (Cconst_int 3) dbg], dbg) in + [add_int (add_int ptr idx dbg) (cconst_int 3) dbg], dbg) + in let b1, b2, b3, b4 = if Arch.big_endian then v1, v2, v3, v4 else v4, v3, v2, v1 in Cop(Cor, - [Cop(Cor, [lsl_int b1 (Cconst_int 24) dbg; - lsl_int b2 (Cconst_int 16) dbg], dbg); - Cop(Cor, [lsl_int b3 (Cconst_int 8) dbg; b4], dbg)], + [Cop(Cor, [lsl_int b1 (cconst_int 24) dbg; + lsl_int b2 (cconst_int 16) dbg], dbg); + Cop(Cor, [lsl_int b3 (cconst_int 8) dbg; b4], dbg)], dbg) let unaligned_set_32 ptr idx newval dbg = @@ -1220,16 +1377,17 @@ let unaligned_set_32 ptr idx newval dbg = Cop(Cstore (Thirtytwo_unsigned, Assignment), [add_int ptr idx dbg; newval], dbg) else + let cconst_int i = Cconst_int (i, dbg) in let v1 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int 24], dbg); Cconst_int 0xFF], dbg) + Cop(Cand, [Cop(Clsr, [newval; cconst_int 24], dbg); cconst_int 0xFF], dbg) in let v2 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int 16], dbg); Cconst_int 0xFF], dbg) + Cop(Cand, [Cop(Clsr, [newval; cconst_int 16], dbg); cconst_int 0xFF], dbg) in let v3 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8], dbg); Cconst_int 0xFF], dbg) + Cop(Cand, [Cop(Clsr, [newval; cconst_int 8], dbg); cconst_int 0xFF], dbg) in - let v4 = Cop(Cand, [newval; Cconst_int 0xFF], dbg) in + let v4 = Cop(Cand, [newval; cconst_int 0xFF], dbg) in let b1, b2, b3, b4 = if Arch.big_endian then v1, v2, v3, v4 @@ -1239,48 +1397,59 @@ let unaligned_set_32 ptr idx newval dbg = Cop(Cstore (Byte_unsigned, Assignment), [add_int ptr idx dbg; b1], dbg), Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg; b2], dbg)), + [add_int (add_int ptr idx dbg) (cconst_int 1) dbg; b2], + dbg)), Csequence( Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (Cconst_int 2) dbg; b3], dbg), + [add_int (add_int ptr idx dbg) (cconst_int 2) dbg; b3], + dbg), Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (Cconst_int 3) dbg; b4], dbg))) + [add_int (add_int ptr idx dbg) (cconst_int 3) dbg; b4], + dbg))) let unaligned_load_64 ptr idx dbg = assert(size_int = 8); if Arch.allow_unaligned_access then Cop(Cload (Word_int, Mutable), [add_int ptr idx dbg], dbg) else + let cconst_int i = Cconst_int (i, dbg) in let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in let v2 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg], dbg) in + [add_int (add_int ptr idx dbg) (cconst_int 1) dbg], dbg) + in let v3 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (Cconst_int 2) dbg], dbg) in + [add_int (add_int ptr idx dbg) (cconst_int 2) dbg], dbg) + in let v4 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (Cconst_int 3) dbg], dbg) in + [add_int (add_int ptr idx dbg) (cconst_int 3) dbg], dbg) + in let v5 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (Cconst_int 4) dbg], dbg) in + [add_int (add_int ptr idx dbg) (cconst_int 4) dbg], dbg) + in let v6 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (Cconst_int 5) dbg], dbg) in + [add_int (add_int ptr idx dbg) (cconst_int 5) dbg], dbg) + in let v7 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (Cconst_int 6) dbg], dbg) in + [add_int (add_int ptr idx dbg) (cconst_int 6) dbg], dbg) + in let v8 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (Cconst_int 7) dbg], dbg) in + [add_int (add_int ptr idx dbg) (cconst_int 7) dbg], dbg) + in let b1, b2, b3, b4, b5, b6, b7, b8 = if Arch.big_endian then v1, v2, v3, v4, v5, v6, v7, v8 else v8, v7, v6, v5, v4, v3, v2, v1 in Cop(Cor, [Cop(Cor, - [Cop(Cor, [lsl_int b1 (Cconst_int (8*7)) dbg; - lsl_int b2 (Cconst_int (8*6)) dbg], dbg); - Cop(Cor, [lsl_int b3 (Cconst_int (8*5)) dbg; - lsl_int b4 (Cconst_int (8*4)) dbg], dbg)], + [Cop(Cor, [lsl_int b1 (cconst_int (8*7)) dbg; + lsl_int b2 (cconst_int (8*6)) dbg], dbg); + Cop(Cor, [lsl_int b3 (cconst_int (8*5)) dbg; + lsl_int b4 (cconst_int (8*4)) dbg], dbg)], dbg); Cop(Cor, - [Cop(Cor, [lsl_int b5 (Cconst_int (8*3)) dbg; - lsl_int b6 (Cconst_int (8*2)) dbg], dbg); - Cop(Cor, [lsl_int b7 (Cconst_int 8) dbg; + [Cop(Cor, [lsl_int b5 (cconst_int (8*3)) dbg; + lsl_int b6 (cconst_int (8*2)) dbg], dbg); + Cop(Cor, [lsl_int b7 (cconst_int 8) dbg; b8], dbg)], dbg)], dbg) @@ -1289,35 +1458,36 @@ let unaligned_set_64 ptr idx newval dbg = if Arch.allow_unaligned_access then Cop(Cstore (Word_int, Assignment), [add_int ptr idx dbg; newval], dbg) else + let cconst_int i = Cconst_int (i, dbg) in let v1 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*7)], dbg); Cconst_int 0xFF], + Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*7)], dbg); cconst_int 0xFF], dbg) in let v2 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*6)], dbg); Cconst_int 0xFF], + Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*6)], dbg); cconst_int 0xFF], dbg) in let v3 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*5)], dbg); Cconst_int 0xFF], + Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*5)], dbg); cconst_int 0xFF], dbg) in let v4 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*4)], dbg); Cconst_int 0xFF], + Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*4)], dbg); cconst_int 0xFF], dbg) in let v5 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*3)], dbg); Cconst_int 0xFF], + Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*3)], dbg); cconst_int 0xFF], dbg) in let v6 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*2)], dbg); Cconst_int 0xFF], + Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*2)], dbg); cconst_int 0xFF], dbg) in let v7 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8], dbg); Cconst_int 0xFF], + Cop(Cand, [Cop(Clsr, [newval; cconst_int 8], dbg); cconst_int 0xFF], dbg) in - let v8 = Cop(Cand, [newval; Cconst_int 0xFF], dbg) in + let v8 = Cop(Cand, [newval; cconst_int 0xFF], dbg) in let b1, b2, b3, b4, b5, b6, b7, b8 = if Arch.big_endian then v1, v2, v3, v4, v5, v6, v7, v8 @@ -1329,47 +1499,76 @@ let unaligned_set_64 ptr idx newval dbg = [add_int ptr idx dbg; b1], dbg), Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg; b2], + [add_int (add_int ptr idx dbg) (cconst_int 1) dbg; b2], dbg)), Csequence( Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (Cconst_int 2) dbg; b3], + [add_int (add_int ptr idx dbg) (cconst_int 2) dbg; b3], dbg), Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (Cconst_int 3) dbg; b4], + [add_int (add_int ptr idx dbg) (cconst_int 3) dbg; b4], dbg))), Csequence( Csequence( Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (Cconst_int 4) dbg; b5], + [add_int (add_int ptr idx dbg) (cconst_int 4) dbg; b5], dbg), Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (Cconst_int 5) dbg; b6], + [add_int (add_int ptr idx dbg) (cconst_int 5) dbg; b6], dbg)), Csequence( Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (Cconst_int 6) dbg; b7], + [add_int (add_int ptr idx dbg) (cconst_int 6) dbg; b7], dbg), Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (Cconst_int 7) dbg; b8], + [add_int (add_int ptr idx dbg) (cconst_int 7) dbg; b8], dbg)))) let max_or_zero a dbg = bind "size" a (fun a -> (* equivalent to - Cifthenelse(Cop(Ccmpi Cle, [a; Cconst_int 0]), Cconst_int 0, a) + Cifthenelse(Cop(Ccmpi Cle, [a; cconst_int 0]), cconst_int 0, a) if a is positive, sign is 0 hence sign_negation is full of 1 so sign_negation&a = a if a is negative, sign is full of 1 hence sign_negation is 0 so sign_negation&a = 0 *) - let sign = Cop(Casr, [a; Cconst_int (size_int * 8 - 1)], dbg) in - let sign_negation = Cop(Cxor, [sign; Cconst_int (-1)], dbg) in + let sign = Cop(Casr, [a; Cconst_int (size_int * 8 - 1, dbg)], dbg) in + let sign_negation = Cop(Cxor, [sign; Cconst_int (-1, dbg)], dbg) in Cop(Cand, [sign_negation; a], dbg)) -let check_bound unsafe dbg a1 a2 k = - if unsafe then k - else Csequence(make_checkbound dbg [max_or_zero a1 dbg; a2], k) +let check_bound safety access_size dbg length a2 k = + match safety with + | Unsafe -> k + | Safe -> + let offset = + match access_size with + | Sixteen -> 1 + | Thirty_two -> 3 + | Sixty_four -> 7 + in + let a1 = + sub_int length (Cconst_int (offset, dbg)) dbg + in + Csequence(make_checkbound dbg [max_or_zero a1 dbg; a2], k) + +let unaligned_set size ptr idx newval dbg = + match size with + | Sixteen -> unaligned_set_16 ptr idx newval dbg + | Thirty_two -> unaligned_set_32 ptr idx newval dbg + | Sixty_four -> unaligned_set_64 ptr idx newval dbg + +let unaligned_load size ptr idx dbg = + match size with + | Sixteen -> unaligned_load_16 ptr idx dbg + | Thirty_two -> unaligned_load_32 ptr idx dbg + | Sixty_four -> unaligned_load_64 ptr idx dbg + +let box_sized size dbg exp = + match size with + | Sixteen -> tag_int exp dbg + | Thirty_two -> box_int dbg Pint32 exp + | Sixty_four -> box_int dbg Pint64 exp (* Simplification of some primitives into C calls *) @@ -1424,11 +1623,11 @@ let simplif_primitive_32bits = function Pccall (default_prim ("caml_ba_get_" ^ Int.to_string n)) | Pbigarrayset(_unsafe, n, Pbigarray_int64, _layout) -> Pccall (default_prim ("caml_ba_set_" ^ Int.to_string n)) - | Pstring_load_64(_) -> Pccall (default_prim "caml_string_get64") - | Pbytes_load_64(_) -> Pccall (default_prim "caml_bytes_get64") - | Pbytes_set_64(_) -> Pccall (default_prim "caml_bytes_set64") - | Pbigstring_load_64(_) -> Pccall (default_prim "caml_ba_uint8_get64") - | Pbigstring_set_64(_) -> Pccall (default_prim "caml_ba_uint8_set64") + | Pstring_load(Sixty_four, _) -> Pccall (default_prim "caml_string_get64") + | Pbytes_load(Sixty_four, _) -> Pccall (default_prim "caml_bytes_get64") + | Pbytes_set(Sixty_four, _) -> Pccall (default_prim "caml_bytes_set64") + | Pbigstring_load(Sixty_four,_) -> Pccall (default_prim "caml_ba_uint8_get64") + | Pbigstring_set(Sixty_four,_) -> Pccall (default_prim "caml_ba_uint8_set64") | Pbbswap Pint64 -> Pccall (default_prim "caml_int64_bswap") | p -> p @@ -1454,31 +1653,64 @@ let transl_isout h arg dbg = tag_int (Cop(Ccmpa Clt, [h ; arg], dbg)) dbg (* Build an actual switch (ie jump table) *) let make_switch arg cases actions dbg = - let is_const = function + let extract_uconstant = + function (* Constant integers loaded from a table should end in 1, so that Cload never produces untagged integers *) - | Cconst_int n - | Cconst_pointer n -> (n land 1) = 1 - | Cconst_natint n - | Cconst_natpointer n -> (Nativeint.(to_int (logand n one) = 1)) - | Cconst_symbol _ -> true - | _ -> false in - if Array.for_all is_const actions then - let to_data_item = function - | Cconst_int n - | Cconst_pointer n -> Cint (Nativeint.of_int n) - | Cconst_natint n - | Cconst_natpointer n -> Cint n - | Cconst_symbol s -> Csymbol_address s - | _ -> assert false in - let const_actions = Array.map to_data_item actions in + | Cconst_int (n, _), _dbg + | Cconst_pointer (n, _), _dbg when (n land 1) = 1 -> + Some (Cint (Nativeint.of_int n)) + | Cconst_natint (n, _), _dbg + | Cconst_natpointer (n, _), _dbg + when Nativeint.(to_int (logand n one) = 1) -> + Some (Cint n) + | Cconst_symbol (s,_), _dbg -> + Some (Csymbol_address s) + | _ -> None + in + let extract_affine ~cases ~const_actions = + let length = Array.length cases in + if length >= 2 + then begin + match const_actions.(cases.(0)), const_actions.(cases.(1)) with + | Cint v0, Cint v1 -> + let slope = Nativeint.sub v1 v0 in + let check i = function + | Cint v -> v = Nativeint.(add (mul (of_int i) slope) v0) + | _ -> false + in + if Misc.Stdlib.Array.for_alli + (fun i idx -> check i const_actions.(idx)) cases + then Some (v0, slope) + else None + | _, _ -> + None + end + else None + in + let make_table_lookup ~cases ~const_actions arg dbg = let table = Compilenv.new_const_symbol () in - add_cmm_constant (Const_table ((table, Not_global), + Cmmgen_state.add_constant table (Const_table (Local, Array.to_list (Array.map (fun act -> const_actions.(act)) cases))); - addr_array_ref (Cconst_symbol table) (tag_int arg dbg) dbg - else - Cswitch (arg,cases,actions,dbg) + addr_array_ref (Cconst_symbol (table, dbg)) (tag_int arg dbg) dbg + in + let make_affine_computation ~offset ~slope arg dbg = + (* In case the resulting integers are an affine function of the index, we + don't emit a table, and just compute the result directly *) + add_int + (mul_int arg (natint_const_untagged dbg slope) dbg) + (natint_const_untagged dbg offset) + dbg + in + match Misc.Stdlib.Array.all_somes (Array.map extract_uconstant actions) with + | None -> + Cswitch (arg,cases,actions,dbg) + | Some const_actions -> + match extract_affine ~cases ~const_actions with + | Some (offset, slope) -> + make_affine_computation ~offset ~slope arg dbg + | None -> make_table_lookup ~cases ~const_actions arg dbg module SArgBlocks = struct @@ -1493,20 +1725,27 @@ struct type act = expression - let make_const i = Cconst_int i - (* CR mshinwell: fix debuginfo *) + (* CR mshinwell: GPR#2294 will fix the Debuginfo here *) + + let make_const i = Cconst_int (i, Debuginfo.none) let make_prim p args = Cop (p,args, Debuginfo.none) let make_offset arg n = add_const arg n Debuginfo.none let make_isout h arg = Cop (Ccmpa Clt, [h ; arg], Debuginfo.none) let make_isin h arg = Cop (Ccmpa Cge, [h ; arg], Debuginfo.none) - let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot) + let make_if cond ifso ifnot = + Cifthenelse (cond, Debuginfo.none, ifso, Debuginfo.none, ifnot, + Debuginfo.none) let make_switch loc arg cases actions = - make_switch arg cases actions (Debuginfo.from_location loc) + let dbg = Debuginfo.from_location loc in + let actions = Array.map (fun expr -> expr, dbg) actions in + make_switch arg cases actions dbg let bind arg body = bind "switcher" arg body - let make_catch handler = match handler with + let make_catch handler = + match handler with | Cexit (i,[]) -> i,fun e -> e | _ -> + let dbg = Debuginfo.none in let i = next_raise_count () in (* Printf.eprintf "SHARE CMM: %i\n" i ; @@ -1518,7 +1757,7 @@ struct | Cexit (j,_) -> if i=j then handler else body - | _ -> ccatch (i,[],body,handler)) + | _ -> ccatch (i,[],body,handler, dbg)) let make_exit i = Cexit (i,[]) @@ -1655,14 +1894,19 @@ let rec is_unboxed_number ~strict env e = | Some (_, bn) -> Boxed (bn, false) end + (* CR mshinwell: Changes to [Clambda] will provide the [Debuginfo] here *) | Uconst(Uconst_ref(_, Some (Uconst_float _))) -> - Boxed (Boxed_float Debuginfo.none, true) + let dbg = Debuginfo.none in + Boxed (Boxed_float dbg, true) | Uconst(Uconst_ref(_, Some (Uconst_int32 _))) -> - Boxed (Boxed_integer (Pint32, Debuginfo.none), true) + let dbg = Debuginfo.none in + Boxed (Boxed_integer (Pint32, dbg), true) | Uconst(Uconst_ref(_, Some (Uconst_int64 _))) -> - Boxed (Boxed_integer (Pint64, Debuginfo.none), true) + let dbg = Debuginfo.none in + Boxed (Boxed_integer (Pint64, dbg), true) | Uconst(Uconst_ref(_, Some (Uconst_nativeint _))) -> - Boxed (Boxed_integer (Pnativeint, Debuginfo.none), true) + let dbg = Debuginfo.none in + Boxed (Boxed_integer (Pnativeint, dbg), true) | Uprim(p, _, dbg) -> begin match simplif_primitive p with | Pccall p -> unboxed_number_kind_of_unbox dbg p.prim_native_repr_res @@ -1699,12 +1943,16 @@ let rec is_unboxed_number ~strict env e = Boxed (Boxed_integer (Pint64, dbg), false) | Pbigarrayref(_, _, Pbigarray_native_int,_) -> Boxed (Boxed_integer (Pnativeint, dbg), false) - | Pstring_load_32(_) | Pbytes_load_32(_) -> + | Pstring_load(Thirty_two,_) + | Pbytes_load(Thirty_two,_) -> Boxed (Boxed_integer (Pint32, dbg), false) - | Pstring_load_64(_) | Pbytes_load_64(_) -> + | Pstring_load(Sixty_four,_) + | Pbytes_load(Sixty_four,_) -> + Boxed (Boxed_integer (Pint64, dbg), false) + | Pbigstring_load(Thirty_two,_) -> + Boxed (Boxed_integer (Pint32, dbg), false) + | Pbigstring_load(Sixty_four,_) -> Boxed (Boxed_integer (Pint64, dbg), false) - | Pbigstring_load_32(_) -> Boxed (Boxed_integer (Pint32, dbg), false) - | Pbigstring_load_64(_) -> Boxed (Boxed_integer (Pint64, dbg), false) | Praise _ -> No_result | _ -> No_unboxing end @@ -1738,8 +1986,6 @@ let assignment_kind ptr init = (* Translate an expression *) -let functions = (Queue.create() : ufunction Queue.t) - let strmatch_compile = let module S = Strmatch.Make @@ -1757,28 +2003,33 @@ let rec transl env e = | Some (unboxed_id, bn) -> box_number bn (Cvar unboxed_id) end | Uconst sc -> - transl_constant sc + transl_constant Debuginfo.none sc | Uclosure(fundecls, []) -> - let lbl = Compilenv.new_const_symbol() in - add_cmm_constant ( - Const_closure ((lbl, Not_global), fundecls, [])); - List.iter (fun f -> Queue.add f functions) fundecls; - Cconst_symbol lbl + let sym = Compilenv.new_const_symbol() in + Cmmgen_state.add_constant sym (Const_closure (Local, fundecls, [])); + List.iter (fun f -> Cmmgen_state.add_function f) fundecls; + let dbg = + match fundecls with + | [] -> Debuginfo.none + | fundecl::_ -> fundecl.dbg + in + Cconst_symbol (sym, dbg) | Uclosure(fundecls, clos_vars) -> let rec transl_fundecls pos = function [] -> List.map (transl env) clos_vars | f :: rem -> - Queue.add f functions; + Cmmgen_state.add_function f; + let dbg = f.dbg in let without_header = if f.arity = 1 || f.arity = 0 then - Cconst_symbol f.label :: - int_const f.arity :: + Cconst_symbol (f.label, dbg) :: + int_const dbg f.arity :: transl_fundecls (pos + 3) rem else - Cconst_symbol(curry_function f.arity) :: - int_const f.arity :: - Cconst_symbol f.label :: + Cconst_symbol (curry_function f.arity, dbg) :: + int_const dbg f.arity :: + Cconst_symbol (f.label, dbg) :: transl_fundecls (pos + 4) rem in if pos = 0 then without_header @@ -1793,27 +2044,32 @@ let rec transl env e = | Uoffset(arg, offset) -> (* produces a valid Caml value, pointing just after an infix header *) let ptr = transl env arg in + let dbg = Debuginfo.none in if offset = 0 then ptr - else Cop(Caddv, [ptr; Cconst_int(offset * size_addr)], Debuginfo.none) + else Cop(Caddv, [ptr; Cconst_int(offset * size_addr, dbg)], dbg) | Udirect_apply(lbl, args, dbg) -> - Cop(Capply typ_val, Cconst_symbol lbl :: List.map (transl env) args, dbg) + Cop(Capply typ_val, + Cconst_symbol (lbl, dbg) :: List.map (transl env) args, + dbg) | Ugeneric_apply(clos, [arg], dbg) -> bind "fun" (transl env clos) (fun clos -> - Cop(Capply typ_val, [get_field env clos 0 dbg; transl env arg; clos], + Cop(Capply typ_val, + [get_field env clos 0 dbg; transl env arg; clos], dbg)) | Ugeneric_apply(clos, args, dbg) -> let arity = List.length args in - let cargs = Cconst_symbol(apply_function arity) :: + let cargs = Cconst_symbol(apply_function arity, dbg) :: List.map (transl env) (args @ [clos]) in Cop(Capply typ_val, cargs, dbg) | Usend(kind, met, obj, args, dbg) -> let call_met obj args clos = if args = [] then - Cop(Capply typ_val, [get_field env clos 0 dbg; obj; clos], dbg) + Cop(Capply typ_val, + [get_field env clos 0 dbg; obj; clos], dbg) else let arity = List.length args + 1 in - let cargs = Cconst_symbol(apply_function arity) :: obj :: + let cargs = Cconst_symbol(apply_function arity, dbg) :: obj :: (List.map (transl env) args) @ [clos] in Cop(Capply typ_val, cargs, dbg) in @@ -1861,8 +2117,8 @@ let rec transl env e = (* Primitives *) | Uprim(prim, args, dbg) -> begin match (simplif_primitive prim, args) with - (Pgetglobal id, []) -> - Cconst_symbol (V.name id) + | (Pread_symbol sym, []) -> + Cconst_symbol (sym, dbg) | (Pmakeblock _, []) -> assert false | (Pmakeblock(tag, _mut, _kind), args) -> @@ -1888,7 +2144,7 @@ let rec transl env e = in transl_ccall env prim_obj_dup [arg] dbg | (Pmakearray _, []) -> - transl_structured_constant (Uconst_block(0, [])) + Misc.fatal_error "Pmakearray is not allowed for an empty array" | (Pmakearray (kind, _), args) -> transl_make_array dbg env kind args | (Pbigarrayref(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) -> let elt = @@ -1905,7 +2161,7 @@ let rec transl env e = end | (Pbigarrayset(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) -> let (argidx, argnewval) = split_last argl in - return_unit(bigarray_set unsafe elt_kind layout + return_unit dbg (bigarray_set unsafe elt_kind layout (transl env arg1) (List.map (transl env) argidx) (match elt_kind with @@ -1929,7 +2185,33 @@ let rec transl env e = transl_prim_2 env p arg1 arg2 dbg | (p, [arg1; arg2; arg3]) -> transl_prim_3 env p arg1 arg2 arg3 dbg - | (_, _) -> + | (Pread_symbol _, _::_::_::_::_) + | (Pbigarrayset (_, _, _, _), []) + | (Pbigarrayref (_, _, _, _), []) + | ((Pbigarraydim _ | Pduparray (_, _)), ([] | _::_::_::_::_)) + -> + fatal_error "Cmmgen.transl:prim, wrong arity" + | ((Pfield_computed|Psequand + | Psequor | Pnot | Pnegint | Paddint | Psubint + | Pmulint | Pandint | Porint | Pxorint | Plslint + | Plsrint | Pasrint | Pintoffloat | Pfloatofint + | Pnegfloat | Pabsfloat | Paddfloat | Psubfloat + | Pmulfloat | Pdivfloat | Pstringlength | Pstringrefu + | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu + | Pbytesrefs | Pbytessets | Pisint | Pisout + | Pbswap16 | Pint_as_pointer | Popaque | Pfield _ + | Psetfield (_, _, _) | Psetfield_computed (_, _) + | Pfloatfield _ | Psetfloatfield (_, _) | Pduprecord (_, _) + | Praise _ | Pdivint _ | Pmodint _ | Pintcomp _ | Poffsetint _ + | Poffsetref _ | Pfloatcomp _ | Parraylength _ + | Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _ + | Pbintofint _ | Pintofbint _ | Pcvtbint (_, _) | Pnegbint _ + | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ + | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ + | Pasrbint _ | Pbintcomp (_, _) | Pstring_load _ | Pbytes_load _ + | Pbytes_set _ | Pbigstring_load _ | Pbigstring_set _ + | Pbbswap _), _) + -> fatal_error "Cmmgen.transl:prim" end @@ -1942,7 +2224,7 @@ let rec transl env e = make_switch (untag_int (transl env arg) dbg) s.us_index_consts - (Array.map (transl env) s.us_actions_consts) + (Array.map (fun expr -> transl env expr, dbg) s.us_actions_consts) dbg else if Array.length s.us_index_consts = 0 then bind "switch" (transl env arg) (fun arg -> @@ -1951,11 +2233,14 @@ let rec transl env e = else bind "switch" (transl env arg) (fun arg -> Cifthenelse( - Cop(Cand, [arg; Cconst_int 1], dbg), + Cop(Cand, [arg; Cconst_int (1, dbg)], dbg), + dbg, transl_switch loc env (untag_int arg dbg) s.us_index_consts s.us_actions_consts, + dbg, transl_switch loc env - (get_tag arg dbg) s.us_index_blocks s.us_actions_blocks)) + (get_tag arg dbg) s.us_index_blocks s.us_actions_blocks, + dbg)) | Ustringswitch(arg,sw,d) -> let dbg = Debuginfo.none in bind "switch" (transl env arg) @@ -1965,38 +2250,45 @@ let rec transl env e = | Ustaticfail (nfail, args) -> Cexit (nfail, List.map (transl env) args) | Ucatch(nfail, [], body, handler) -> - make_catch nfail (transl env body) (transl env handler) + let dbg = Debuginfo.none in + make_catch nfail (transl env body) (transl env handler) dbg | Ucatch(nfail, ids, body, handler) -> + let dbg = Debuginfo.none in (* CR-someday mshinwell: consider how we can do better than [typ_val] when appropriate. *) let ids_with_types = List.map (fun (i, _) -> (i, Cmm.typ_val)) ids in - ccatch(nfail, ids_with_types, transl env body, transl env handler) + ccatch(nfail, ids_with_types, transl env body, transl env handler, dbg) | Utrywith(body, exn, handler) -> - Ctrywith(transl env body, exn, transl env handler) + let dbg = Debuginfo.none in + Ctrywith(transl env body, exn, transl env handler, dbg) | Uifthenelse(cond, ifso, ifnot) -> + let ifso_dbg = Debuginfo.none in + let ifnot_dbg = Debuginfo.none in let dbg = Debuginfo.none in - transl_if env cond dbg Unknown - (transl env ifso) (transl env ifnot) + transl_if env Unknown dbg cond + ifso_dbg (transl env ifso) ifnot_dbg (transl env ifnot) | Usequence(exp1, exp2) -> Csequence(remove_unit(transl env exp1), transl env exp2) | Uwhile(cond, body) -> let dbg = Debuginfo.none in let raise_num = next_raise_count () in - return_unit + return_unit dbg (ccatch (raise_num, [], - Cloop(transl_if env cond dbg Unknown - (remove_unit(transl env body)) - (Cexit (raise_num,[]))), - Ctuple [])) + create_loop(transl_if env Unknown dbg cond + dbg (remove_unit(transl env body)) + dbg (Cexit (raise_num,[]))) + dbg, + Ctuple [], + dbg)) | Ufor(id, low, high, dir, body) -> let dbg = Debuginfo.none in let tst = match dir with Upto -> Cgt | Downto -> Clt in let inc = match dir with Upto -> Caddi | Downto -> Csubi in let raise_num = next_raise_count () in - let id_prev = VP.rename id in - return_unit + let id_prev = VP.create (V.create_local "*id_prev*") in + return_unit dbg (Clet (id, transl env low, bind_nonvar "bound" (transl env high) (fun high -> @@ -2004,32 +2296,39 @@ let rec transl env e = (raise_num, [], Cifthenelse (Cop(Ccmpi tst, [Cvar (VP.var id); high], dbg), + dbg, Cexit (raise_num, []), - Cloop + dbg, + create_loop (Csequence (remove_unit(transl env body), Clet(id_prev, Cvar (VP.var id), Csequence (Cassign(VP.var id, - Cop(inc, [Cvar (VP.var id); Cconst_int 2], + Cop(inc, [Cvar (VP.var id); Cconst_int (2, dbg)], dbg)), Cifthenelse (Cop(Ccmpi Ceq, [Cvar (VP.var id_prev); high], dbg), - Cexit (raise_num,[]), Ctuple [])))))), - Ctuple [])))) + dbg, Cexit (raise_num,[]), + dbg, Ctuple [], + dbg))))) + dbg, + dbg), + Ctuple [], + dbg)))) | Uassign(id, exp) -> let dbg = Debuginfo.none in begin match is_unboxed_id id env with | None -> - return_unit (Cassign(id, transl env exp)) + return_unit dbg (Cassign(id, transl env exp)) | Some (unboxed_id, bn) -> - return_unit(Cassign(unboxed_id, + return_unit dbg (Cassign(unboxed_id, transl_unbox_number dbg env bn exp)) end | Uunreachable -> let dbg = Debuginfo.none in - Cop(Cload (Word_int, Mutable), [Cconst_int 0], dbg) + Cop(Cload (Word_int, Mutable), [Cconst_int (0, dbg)], dbg) and transl_make_array dbg env kind args = match kind with @@ -2077,10 +2376,8 @@ and transl_ccall env prim args dbg = and transl_prim_1 env p arg dbg = match p with (* Generic operations *) - Pidentity | Pbytes_to_string | Pbytes_of_string | Popaque -> + Popaque -> transl env arg - | Pignore -> - return_unit(remove_unit (transl env arg)) (* Heap operations *) | Pfield n -> get_field env (transl env arg) n dbg @@ -2088,11 +2385,12 @@ and transl_prim_1 env p arg dbg = let ptr = transl env arg in box_float dbg ( Cop(Cload (Double_u, Mutable), - [if n = 0 then ptr - else Cop(Cadda, [ptr; Cconst_int(n * size_float)], dbg)], + [if n = 0 + then ptr + else Cop(Cadda, [ptr; Cconst_int(n * size_float, dbg)], dbg)], dbg)) | Pint_as_pointer -> - Cop(Caddi, [transl env arg; Cconst_int (-1)], dbg) + Cop(Caddi, [transl env arg; Cconst_int (-1, dbg)], dbg) (* always a pointer outside the heap *) (* Exceptions *) | Praise _ when not (!Clflags.debug) -> @@ -2105,28 +2403,14 @@ and transl_prim_1 env p arg dbg = raise_regular dbg (transl env arg) (* Integer operations *) | Pnegint -> - Cop(Csubi, [Cconst_int 2; transl env arg], dbg) - | Pctconst c -> - let const_of_bool b = int_const (if b then 1 else 0) in - begin - match c with - | Big_endian -> const_of_bool Arch.big_endian - | Word_size -> int_const (8*Arch.size_int) - | Int_size -> int_const (8*Arch.size_int - 1) - | Max_wosize -> int_const ((1 lsl ((8*Arch.size_int) - 10)) - 1) - | Ostype_unix -> const_of_bool (Sys.os_type = "Unix") - | Ostype_win32 -> const_of_bool (Sys.os_type = "Win32") - | Ostype_cygwin -> const_of_bool (Sys.os_type = "Cygwin") - | Backend_type -> int_const 0 (* tag 0 is the same as Native here *) - end + Cop(Csubi, [Cconst_int (2, dbg); transl env arg], dbg) | Poffsetint n -> if no_overflow_lsl n 1 then add_const (transl env arg) (n lsl 1) dbg else - transl_prim_2 env Paddint arg (Uconst (Uconst_int n)) - Debuginfo.none + transl_prim_2 env Paddint arg (Uconst (Uconst_int n)) dbg | Poffsetref n -> - return_unit + return_unit dbg (bind "ref" (transl env arg) (fun arg -> Cop(Cstore (Word_int, Assignment), [arg; @@ -2152,26 +2436,33 @@ and transl_prim_1 env p arg dbg = Pgenarray -> let len = if wordsize_shift = numfloat_shift then - Cop(Clsr, [hdr; Cconst_int wordsize_shift], dbg) + Cop(Clsr, [hdr; Cconst_int (wordsize_shift, dbg)], dbg) else bind "header" hdr (fun hdr -> Cifthenelse(is_addr_array_hdr hdr dbg, - Cop(Clsr, [hdr; Cconst_int wordsize_shift], dbg), - Cop(Clsr, [hdr; Cconst_int numfloat_shift], dbg))) + dbg, + Cop(Clsr, + [hdr; Cconst_int (wordsize_shift, dbg)], dbg), + dbg, + Cop(Clsr, + [hdr; Cconst_int (numfloat_shift, dbg)], dbg), + dbg)) in - Cop(Cor, [len; Cconst_int 1], dbg) + Cop(Cor, [len; Cconst_int (1, dbg)], dbg) | Paddrarray | Pintarray -> - Cop(Cor, [addr_array_length hdr dbg; Cconst_int 1], dbg) + Cop(Cor, [addr_array_length hdr dbg; Cconst_int (1, dbg)], dbg) | Pfloatarray -> - Cop(Cor, [float_array_length hdr dbg; Cconst_int 1], dbg) + Cop(Cor, [float_array_length hdr dbg; Cconst_int (1, dbg)], dbg) end (* Boolean operations *) | Pnot -> - transl_if env arg dbg Then_false_else_true - (Cconst_pointer 1) (Cconst_pointer 3) + transl_if env Then_false_else_true + dbg arg + dbg (Cconst_pointer (1, dbg)) + dbg (Cconst_pointer (3, dbg)) (* Test integer/block *) | Pisint -> - tag_int(Cop(Cand, [transl env arg; Cconst_int 1], dbg)) dbg + tag_int(Cop(Cand, [transl env arg; Cconst_int (1, dbg)], dbg)) dbg (* Boxed integers *) | Pbintofint bi -> box_int dbg bi (untag_int (transl env arg) dbg) @@ -2181,7 +2472,8 @@ and transl_prim_1 env p arg dbg = box_int dbg bi2 (transl_unbox_int dbg env bi1 arg) | Pnegbint bi -> box_int dbg bi - (Cop(Csubi, [Cconst_int 0; transl_unbox_int dbg env bi arg], dbg)) + (Cop(Csubi, [Cconst_int (0, dbg); transl_unbox_int dbg env bi arg], + dbg)) | Pbbswap bi -> let prim = match bi with | Pnativeint -> "nativeint" @@ -2196,8 +2488,25 @@ and transl_prim_1 env p arg dbg = [untag_int (transl env arg) dbg], dbg)) dbg - | prim -> - fatal_errorf "Cmmgen.transl_prim_1: %a" Printlambda.primitive prim + | (Pfield_computed | Psequand | Psequor + | Paddint | Psubint | Pmulint | Pandint + | Porint | Pxorint | Plslint | Plsrint | Pasrint + | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat + | Pstringrefu | Pstringrefs | Pbytesrefu | Pbytessetu + | Pbytesrefs | Pbytessets | Pisout | Pread_symbol _ + | Pmakeblock (_, _, _) | Psetfield (_, _, _) | Psetfield_computed (_, _) + | Psetfloatfield (_, _) | Pduprecord (_, _) | Pccall _ | Pdivint _ + | Pmodint _ | Pintcomp _ | Pfloatcomp _ | Pmakearray (_, _) + | Pduparray (_, _) | Parrayrefu _ | Parraysetu _ + | Parrayrefs _ | Parraysets _ | Paddbint _ | Psubbint _ | Pmulbint _ + | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _ + | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp (_, _) + | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) + | Pbigarraydim _ | Pstring_load _ | Pbytes_load _ | Pbytes_set _ + | Pbigstring_load _ | Pbigstring_set _) + -> + fatal_errorf "Cmmgen.transl_prim_1: %a" + Printclambda_primitives.primitive p and transl_prim_2 env p arg1 arg2 dbg = match p with @@ -2207,38 +2516,46 @@ and transl_prim_2 env p arg1 arg2 dbg = | Psetfield(n, ptr, init) -> begin match assignment_kind ptr init with | Caml_modify -> - return_unit(Cop(Cextcall("caml_modify", typ_void, false, None), + return_unit dbg (Cop(Cextcall("caml_modify", typ_void, false, None), [field_address (transl env arg1) n dbg; transl env arg2], dbg)) | Caml_initialize -> - return_unit(Cop(Cextcall("caml_initialize", typ_void, false, None), + return_unit dbg (Cop(Cextcall("caml_initialize", typ_void, false, None), [field_address (transl env arg1) n dbg; transl env arg2], dbg)) | Simple -> - return_unit(set_field (transl env arg1) n (transl env arg2) init dbg) + return_unit dbg + (set_field (transl env arg1) n (transl env arg2) init dbg) end | Psetfloatfield (n, init) -> let ptr = transl env arg1 in - return_unit( + return_unit dbg ( Cop(Cstore (Double_u, init), [if n = 0 then ptr - else Cop(Cadda, [ptr; Cconst_int(n * size_float)], dbg); - transl_unbox_float dbg env arg2], dbg)) + else + Cop(Cadda, [ptr; Cconst_int(n * size_float, dbg)], dbg); + transl_unbox_float dbg env arg2], dbg)) (* Boolean operations *) | Psequand -> let dbg' = Debuginfo.none in - transl_sequand env arg1 dbg arg2 dbg' Then_true_else_false - (Cconst_pointer 3) (Cconst_pointer 1) + transl_sequand env Then_true_else_false + dbg arg1 + dbg' arg2 + dbg (Cconst_pointer (3, dbg)) + dbg' (Cconst_pointer (1, dbg)) (* let id = V.create_local "res1" in Clet(id, transl env arg1, Cifthenelse(test_bool dbg (Cvar id), transl env arg2, Cvar id)) *) | Psequor -> let dbg' = Debuginfo.none in - transl_sequor env arg1 dbg arg2 dbg' Then_true_else_false - (Cconst_pointer 3) (Cconst_pointer 1) + transl_sequor env Then_true_else_false + dbg arg1 + dbg' arg2 + dbg (Cconst_pointer (3, dbg)) + dbg' (Cconst_pointer (1, dbg)) (* Integer operations *) | Paddint -> decr_int(add_int (transl env arg1) (transl env arg2) dbg) dbg @@ -2254,10 +2571,10 @@ and transl_prim_2 env p arg1 arg2 dbg = (+ ( * 200 (>>s a 1)) 15) *) match transl env arg1, transl env arg2 with - | Cconst_int _ as c1, c2 -> - incr_int (mul_int (untag_int c1 dbg) (decr_int c2 dbg) dbg) dbg - | c1, c2 -> - incr_int (mul_int (decr_int c1 dbg) (untag_int c2 dbg) dbg) dbg + | Cconst_int _ as c1, c2 -> + incr_int (mul_int (untag_int c1 dbg) (decr_int c2 dbg) dbg) dbg + | c1, c2 -> + incr_int (mul_int (decr_int c1 dbg) (untag_int c2 dbg) dbg) dbg end | Pdivint is_safe -> tag_int(div_int (untag_int(transl env arg1) dbg) @@ -2272,16 +2589,16 @@ and transl_prim_2 env p arg1 arg2 dbg = | Pxorint -> Cop(Cor, [Cop(Cxor, [ignore_low_bit_int(transl env arg1); ignore_low_bit_int(transl env arg2)], dbg); - Cconst_int 1], dbg) + Cconst_int (1, dbg)], dbg) | Plslint -> incr_int(lsl_int (decr_int(transl env arg1) dbg) (untag_int(transl env arg2) dbg) dbg) dbg | Plsrint -> Cop(Cor, [lsr_int (transl env arg1) (untag_int(transl env arg2) dbg) dbg; - Cconst_int 1], dbg) + Cconst_int (1, dbg)], dbg) | Pasrint -> Cop(Cor, [asr_int (transl env arg1) (untag_int(transl env arg2) dbg) dbg; - Cconst_int 1], dbg) + Cconst_int (1, dbg)], dbg) | Pintcomp cmp -> tag_int(Cop(Ccmpi(transl_int_comparison cmp), [transl env arg1; transl env arg2], dbg)) dbg @@ -2329,65 +2646,25 @@ and transl_prim_2 env p arg1 arg2 dbg = Cop(Cload (Byte_unsigned, Mutable), [add_int str idx dbg], dbg))))) dbg - | Pstring_load_16(unsafe) | Pbytes_load_16(unsafe) -> - tag_int + | Pstring_load(size, unsafe) | Pbytes_load(size, unsafe) -> + box_sized size dbg (bind "str" (transl env arg1) (fun str -> bind "index" (untag_int (transl env arg2) dbg) (fun idx -> - check_bound unsafe dbg - (sub_int (string_length str dbg) (Cconst_int 1) dbg) - idx (unaligned_load_16 str idx dbg)))) dbg + check_bound unsafe size dbg + (string_length str dbg) + idx (unaligned_load size str idx dbg)))) - | Pbigstring_load_16(unsafe) -> - tag_int + | Pbigstring_load(size, unsafe) -> + box_sized size dbg (bind "ba" (transl env arg1) (fun ba -> bind "index" (untag_int (transl env arg2) dbg) (fun idx -> bind "ba_data" (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) (fun ba_data -> - check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable), - [field_address ba 5 dbg], dbg)) - (Cconst_int 1) dbg) idx - (unaligned_load_16 ba_data idx dbg))))) dbg - - | Pstring_load_32(unsafe) | Pbytes_load_32(unsafe) -> - box_int dbg Pint32 - (bind "str" (transl env arg1) (fun str -> - bind "index" (untag_int (transl env arg2) dbg) (fun idx -> - check_bound unsafe dbg - (sub_int (string_length str dbg) (Cconst_int 3) dbg) - idx (unaligned_load_32 str idx dbg)))) - - | Pbigstring_load_32(unsafe) -> - box_int dbg Pint32 - (bind "ba" (transl env arg1) (fun ba -> - bind "index" (untag_int (transl env arg2) dbg) (fun idx -> - bind "ba_data" - (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) - (fun ba_data -> - check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable), - [field_address ba 5 dbg], dbg)) - (Cconst_int 3) dbg) idx - (unaligned_load_32 ba_data idx dbg))))) - - | Pstring_load_64(unsafe) | Pbytes_load_64(unsafe) -> - box_int dbg Pint64 - (bind "str" (transl env arg1) (fun str -> - bind "index" (untag_int (transl env arg2) dbg) (fun idx -> - check_bound unsafe dbg - (sub_int (string_length str dbg) (Cconst_int 7) dbg) - idx (unaligned_load_64 str idx dbg)))) - - | Pbigstring_load_64(unsafe) -> - box_int dbg Pint64 - (bind "ba" (transl env arg1) (fun ba -> - bind "index" (untag_int (transl env arg2) dbg) (fun idx -> - bind "ba_data" - (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) - (fun ba_data -> - check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable), - [field_address ba 5 dbg], dbg)) - (Cconst_int 7) dbg) idx - (unaligned_load_64 ba_data idx dbg))))) + check_bound unsafe size dbg + (bigstring_length ba dbg) + idx + (unaligned_load size ba_data idx dbg))))) (* Array operations *) | Parrayrefu kind -> @@ -2396,8 +2673,11 @@ and transl_prim_2 env p arg1 arg2 dbg = bind "arr" (transl env arg1) (fun arr -> bind "index" (transl env arg2) (fun idx -> Cifthenelse(is_addr_array_ptr arr dbg, + dbg, addr_array_ref arr idx dbg, - float_array_ref dbg arr idx))) + dbg, + float_array_ref dbg arr idx, + dbg))) | Paddrarray -> addr_array_ref (transl env arg1) (transl env arg2) dbg | Pintarray -> @@ -2415,14 +2695,20 @@ and transl_prim_2 env p arg1 arg2 dbg = if wordsize_shift = numfloat_shift then Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx], Cifthenelse(is_addr_array_hdr hdr dbg, + dbg, addr_array_ref arr idx dbg, - float_array_ref dbg arr idx)) + dbg, + float_array_ref dbg arr idx, + dbg)) else Cifthenelse(is_addr_array_hdr hdr dbg, + dbg, Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx], addr_array_ref arr idx dbg), + dbg, Csequence(make_checkbound dbg [float_array_length hdr dbg; idx], - float_array_ref dbg arr idx))))) + float_array_ref dbg arr idx), + dbg)))) | Paddrarray -> bind "index" (transl env arg2) (fun idx -> bind "arr" (transl env arg1) (fun arr -> @@ -2497,8 +2783,18 @@ and transl_prim_2 env p arg1 arg2 dbg = tag_int (Cop(Ccmpi(transl_int_comparison cmp), [transl_unbox_int dbg env bi arg1; transl_unbox_int dbg env bi arg2], dbg)) dbg - | prim -> - fatal_errorf "Cmmgen.transl_prim_2: %a" Printlambda.primitive prim + | Pnot | Pnegint | Pintoffloat | Pfloatofint | Pnegfloat + | Pabsfloat | Pstringlength | Pbyteslength | Pbytessetu | Pbytessets + | Pisint | Pbswap16 | Pint_as_pointer | Popaque | Pread_symbol _ + | Pmakeblock (_, _, _) | Pfield _ | Psetfield_computed (_, _) | Pfloatfield _ + | Pduprecord (_, _) | Pccall _ | Praise _ | Poffsetint _ | Poffsetref _ + | Pmakearray (_, _) | Pduparray (_, _) | Parraylength _ | Parraysetu _ + | Parraysets _ | Pbintofint _ | Pintofbint _ | Pcvtbint (_, _) + | Pnegbint _ | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) + | Pbigarraydim _ | Pbytes_set _ | Pbigstring_set _ | Pbbswap _ + -> + fatal_errorf "Cmmgen.transl_prim_2: %a" + Printclambda_primitives.primitive p and transl_prim_3 env p arg1 arg2 arg3 dbg = match p with @@ -2506,27 +2802,27 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg = | Psetfield_computed(ptr, init) -> begin match assignment_kind ptr init with | Caml_modify -> - return_unit ( + return_unit dbg ( addr_array_set (transl env arg1) (transl env arg2) (transl env arg3) dbg) | Caml_initialize -> - return_unit ( + return_unit dbg ( addr_array_initialize (transl env arg1) (transl env arg2) (transl env arg3) dbg) | Simple -> - return_unit ( + return_unit dbg ( int_array_set (transl env arg1) (transl env arg2) (transl env arg3) dbg) end (* String operations *) | Pbytessetu -> - return_unit(Cop(Cstore (Byte_unsigned, Assignment), + return_unit dbg (Cop(Cstore (Byte_unsigned, Assignment), [add_int (transl env arg1) (untag_int(transl env arg2) dbg) dbg; untag_int(transl env arg3) dbg], dbg)) | Pbytessets -> - return_unit + return_unit dbg (bind "str" (transl env arg1) (fun str -> bind "index" (untag_int (transl env arg2) dbg) (fun idx -> Csequence( @@ -2537,15 +2833,18 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg = (* Array operations *) | Parraysetu kind -> - return_unit(begin match kind with + return_unit dbg (begin match kind with Pgenarray -> bind "newval" (transl env arg3) (fun newval -> bind "index" (transl env arg2) (fun index -> bind "arr" (transl env arg1) (fun arr -> Cifthenelse(is_addr_array_ptr arr dbg, + dbg, addr_array_set arr index newval dbg, + dbg, float_array_set arr index (unbox_float dbg newval) - dbg)))) + dbg, + dbg)))) | Paddrarray -> addr_array_set (transl env arg1) (transl env arg2) (transl env arg3) dbg @@ -2558,7 +2857,7 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg = dbg end) | Parraysets kind -> - return_unit(begin match kind with + return_unit dbg (begin match kind with | Pgenarray -> bind "newval" (transl env arg3) (fun newval -> bind "index" (transl env arg2) (fun idx -> @@ -2567,17 +2866,23 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg = if wordsize_shift = numfloat_shift then Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx], Cifthenelse(is_addr_array_hdr hdr dbg, + dbg, addr_array_set arr idx newval dbg, + dbg, float_array_set arr idx (unbox_float dbg newval) - dbg)) + dbg, + dbg)) else Cifthenelse(is_addr_array_hdr hdr dbg, + dbg, Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx], addr_array_set arr idx newval dbg), + dbg, Csequence(make_checkbound dbg [float_array_length hdr dbg; idx], float_array_set arr idx - (unbox_float dbg newval) dbg)))))) + (unbox_float dbg newval) dbg), + dbg))))) | Paddrarray -> bind "newval" (transl env arg3) (fun newval -> bind "index" (transl env arg2) (fun idx -> @@ -2601,98 +2906,66 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg = float_array_set arr idx newval dbg)))) end) - | Pbytes_set_16(unsafe) -> - return_unit - (bind "str" (transl env arg1) (fun str -> - bind "index" (untag_int (transl env arg2) dbg) (fun idx -> - bind "newval" (untag_int (transl env arg3) dbg) (fun newval -> - check_bound unsafe dbg - (sub_int (string_length str dbg) (Cconst_int 1) dbg) - idx (unaligned_set_16 str idx newval dbg))))) - - | Pbigstring_set_16(unsafe) -> - return_unit - (bind "ba" (transl env arg1) (fun ba -> - bind "index" (untag_int (transl env arg2) dbg) (fun idx -> - bind "newval" (untag_int (transl env arg3) dbg) (fun newval -> - bind "ba_data" - (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) - (fun ba_data -> - check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable), - [field_address ba 5 dbg], dbg)) - (Cconst_int 1) - dbg) - idx (unaligned_set_16 ba_data idx newval dbg)))))) - - | Pbytes_set_32(unsafe) -> - return_unit + | Pbytes_set(size, unsafe) -> + return_unit dbg (bind "str" (transl env arg1) (fun str -> bind "index" (untag_int (transl env arg2) dbg) (fun idx -> - bind "newval" (transl_unbox_int dbg env Pint32 arg3) (fun newval -> - check_bound unsafe dbg - (sub_int (string_length str dbg) (Cconst_int 3) dbg) - idx (unaligned_set_32 str idx newval dbg))))) + bind "newval" (transl_unbox_sized size dbg env arg3) (fun newval -> + check_bound unsafe size dbg (string_length str dbg) + idx (unaligned_set size str idx newval dbg))))) - | Pbigstring_set_32(unsafe) -> - return_unit + | Pbigstring_set(size, unsafe) -> + return_unit dbg (bind "ba" (transl env arg1) (fun ba -> bind "index" (untag_int (transl env arg2) dbg) (fun idx -> - bind "newval" (transl_unbox_int dbg env Pint32 arg3) (fun newval -> + bind "newval" (transl_unbox_sized size dbg env arg3) (fun newval -> bind "ba_data" (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) (fun ba_data -> - check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable), - [field_address ba 5 dbg], dbg)) - (Cconst_int 3) - dbg) - idx (unaligned_set_32 ba_data idx newval dbg)))))) - - | Pbytes_set_64(unsafe) -> - return_unit - (bind "str" (transl env arg1) (fun str -> - bind "index" (untag_int (transl env arg2) dbg) (fun idx -> - bind "newval" (transl_unbox_int dbg env Pint64 arg3) (fun newval -> - check_bound unsafe dbg - (sub_int (string_length str dbg) (Cconst_int 7) dbg) - idx (unaligned_set_64 str idx newval dbg))))) - - | Pbigstring_set_64(unsafe) -> - return_unit - (bind "ba" (transl env arg1) (fun ba -> - bind "index" (untag_int (transl env arg2) dbg) (fun idx -> - bind "newval" (transl_unbox_int dbg env Pint64 arg3) (fun newval -> - bind "ba_data" - (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) - (fun ba_data -> - check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable), - [field_address ba 5 dbg], dbg)) - (Cconst_int 7) - dbg) idx - (unaligned_set_64 ba_data idx newval dbg)))))) - - | prim -> - fatal_errorf "Cmmgen.transl_prim_3: %a" Printlambda.primitive prim + check_bound unsafe size dbg (bigstring_length ba dbg) + idx (unaligned_set size ba_data idx newval dbg)))))) + + | Pfield_computed | Psequand | Psequor | Pnot | Pnegint | Paddint + | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint + | Pintoffloat | Pfloatofint | Pnegfloat | Pabsfloat | Paddfloat | Psubfloat + | Pmulfloat | Pdivfloat | Pstringlength | Pstringrefu | Pstringrefs + | Pbyteslength | Pbytesrefu | Pbytesrefs | Pisint | Pisout + | Pbswap16 | Pint_as_pointer | Popaque | Pread_symbol _ | Pmakeblock (_, _, _) + | Pfield _ | Psetfield (_, _, _) | Pfloatfield _ | Psetfloatfield (_, _) + | Pduprecord (_, _) | Pccall _ | Praise _ | Pdivint _ | Pmodint _ | Pintcomp _ + | Poffsetint _ | Poffsetref _ | Pfloatcomp _ | Pmakearray (_, _) + | Pduparray (_, _) | Parraylength _ | Parrayrefu _ | Parrayrefs _ + | Pbintofint _ | Pintofbint _ | Pcvtbint (_, _) | Pnegbint _ | Paddbint _ + | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _ + | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp (_, _) + | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) | Pbigarraydim _ + | Pstring_load _ | Pbytes_load _ | Pbigstring_load _ | Pbbswap _ + -> + fatal_errorf "Cmmgen.transl_prim_3: %a" + Printclambda_primitives.primitive p and transl_unbox_float dbg env = function - Uconst(Uconst_ref(_, Some (Uconst_float f))) -> Cconst_float f + Uconst(Uconst_ref(_, Some (Uconst_float f))) -> Cconst_float (f, dbg) | exp -> unbox_float dbg (transl env exp) and transl_unbox_int dbg env bi = function Uconst(Uconst_ref(_, Some (Uconst_int32 n))) -> - Cconst_natint (Nativeint.of_int32 n) + Cconst_natint (Nativeint.of_int32 n, dbg) | Uconst(Uconst_ref(_, Some (Uconst_nativeint n))) -> - Cconst_natint n + Cconst_natint (n, dbg) | Uconst(Uconst_ref(_, Some (Uconst_int64 n))) -> if size_int = 8 then - Cconst_natint (Int64.to_nativeint n) + Cconst_natint (Int64.to_nativeint n, dbg) else begin let low = Int64.to_nativeint n in let high = Int64.to_nativeint (Int64.shift_right_logical n 32) in - if big_endian then Ctuple [Cconst_natint high; Cconst_natint low] - else Ctuple [Cconst_natint low; Cconst_natint high] + if big_endian then + Ctuple [Cconst_natint (high, dbg); Cconst_natint (low, dbg)] + else + Ctuple [Cconst_natint (low, dbg); Cconst_natint (high, dbg)] end | Uprim(Pbintofint bi',[Uconst(Uconst_int i)],_) when bi = bi' -> - Cconst_int i + Cconst_int (i, dbg) | exp -> unbox_int bi (transl env exp) dbg and transl_unbox_number dbg env bn arg = @@ -2700,6 +2973,12 @@ and transl_unbox_number dbg env bn arg = | Boxed_float _ -> transl_unbox_float dbg env arg | Boxed_integer (bi, _) -> transl_unbox_int dbg env bi arg +and transl_unbox_sized size dbg env exp = + match size with + | Sixteen -> untag_int (transl env exp) dbg + | Thirty_two -> transl_unbox_int dbg env Pint32 exp + | Sixty_four -> transl_unbox_int dbg env Pint64 exp + and transl_let env str kind id exp body = let dbg = Debuginfo.none in let unboxing = @@ -2738,16 +3017,16 @@ and transl_let env str kind id exp body = Clet(VP.create unboxed_id, transl_unbox_number dbg env boxed_number exp, transl (add_unboxed_id (VP.var id) unboxed_id boxed_number env) body) -and make_catch ncatch body handler = match body with +and make_catch ncatch body handler dbg = match body with | Cexit (nexit,[]) when nexit=ncatch -> handler -| _ -> ccatch (ncatch, [], body, handler) +| _ -> ccatch (ncatch, [], body, handler, dbg) and is_shareable_cont exp = match exp with | Cexit (_,[]) -> true | _ -> false -and make_shareable_cont mk exp = +and make_shareable_cont dbg mk exp = if is_shareable_cont exp then mk exp else begin let nfail = next_raise_count () in @@ -2755,39 +3034,80 @@ and make_shareable_cont mk exp = nfail (mk (Cexit (nfail,[]))) exp + dbg end -and transl_if env cond dbg approx then_ else_ = +and transl_if env (approx : then_else) + (dbg : Debuginfo.t) cond + (then_dbg : Debuginfo.t) then_ + (else_dbg : Debuginfo.t) else_ = match cond with | Uconst (Uconst_ptr 0) -> else_ | Uconst (Uconst_ptr 1) -> then_ | Uifthenelse (arg1, arg2, Uconst (Uconst_ptr 0)) -> - let dbg' = Debuginfo.none in - transl_sequand env arg1 dbg' arg2 dbg approx then_ else_ - | Uprim(Psequand, [arg1; arg2], dbg') -> - transl_sequand env arg1 dbg' arg2 dbg approx then_ else_ + (* CR mshinwell: These Debuginfos will flow through from Clambda *) + let inner_dbg = Debuginfo.none in + let ifso_dbg = Debuginfo.none in + transl_sequand env approx + inner_dbg arg1 + ifso_dbg arg2 + then_dbg then_ + else_dbg else_ + | Uprim (Psequand, [arg1; arg2], inner_dbg) -> + transl_sequand env approx + inner_dbg arg1 + inner_dbg arg2 + then_dbg then_ + else_dbg else_ | Uifthenelse (arg1, Uconst (Uconst_ptr 1), arg2) -> - let dbg' = Debuginfo.none in - transl_sequor env arg1 dbg' arg2 dbg approx then_ else_ - | Uprim(Psequor, [arg1; arg2], dbg') -> - transl_sequor env arg1 dbg' arg2 dbg approx then_ else_ - | Uprim(Pnot, [arg], _) -> - transl_if env arg dbg (invert_then_else approx) else_ then_ + let inner_dbg = Debuginfo.none in + let ifnot_dbg = Debuginfo.none in + transl_sequor env approx + inner_dbg arg1 + ifnot_dbg arg2 + then_dbg then_ + else_dbg else_ + | Uprim (Psequor, [arg1; arg2], inner_dbg) -> + transl_sequor env approx + inner_dbg arg1 + inner_dbg arg2 + then_dbg then_ + else_dbg else_ + | Uprim (Pnot, [arg], _dbg) -> + transl_if env (invert_then_else approx) + dbg arg + else_dbg else_ + then_dbg then_ | Uifthenelse (Uconst (Uconst_ptr 1), ifso, _) -> - transl_if env ifso dbg approx then_ else_ + let ifso_dbg = Debuginfo.none in + transl_if env approx + ifso_dbg ifso + then_dbg then_ + else_dbg else_ | Uifthenelse (Uconst (Uconst_ptr 0), _, ifnot) -> - transl_if env ifnot dbg approx then_ else_ + let ifnot_dbg = Debuginfo.none in + transl_if env approx + ifnot_dbg ifnot + then_dbg then_ + else_dbg else_ | Uifthenelse (cond, ifso, ifnot) -> - make_shareable_cont + let inner_dbg = Debuginfo.none in + let ifso_dbg = Debuginfo.none in + let ifnot_dbg = Debuginfo.none in + make_shareable_cont then_dbg (fun shareable_then -> - make_shareable_cont + make_shareable_cont else_dbg (fun shareable_else -> mk_if_then_else - (test_bool dbg (transl env cond)) - (transl_if env ifso dbg approx - shareable_then shareable_else) - (transl_if env ifnot dbg approx - shareable_then shareable_else)) + inner_dbg (test_bool inner_dbg (transl env cond)) + ifso_dbg (transl_if env approx + ifso_dbg ifso + then_dbg shareable_then + else_dbg shareable_else) + ifnot_dbg (transl_if env approx + ifnot_dbg ifnot + then_dbg shareable_then + else_dbg shareable_else)) else_) then_ | _ -> begin @@ -2797,23 +3117,42 @@ and transl_if env cond dbg approx then_ else_ = | Then_false_else_true -> mk_not dbg (transl env cond) | Unknown -> - mk_if_then_else (test_bool dbg (transl env cond)) then_ else_ + mk_if_then_else + dbg (test_bool dbg (transl env cond)) + then_dbg then_ + else_dbg else_ end -and transl_sequand env arg1 dbg1 arg2 dbg2 approx then_ else_ = - make_shareable_cont +and transl_sequand env (approx : then_else) + (arg1_dbg : Debuginfo.t) arg1 + (arg2_dbg : Debuginfo.t) arg2 + (then_dbg : Debuginfo.t) then_ + (else_dbg : Debuginfo.t) else_ = + make_shareable_cont else_dbg (fun shareable_else -> - transl_if env arg1 dbg1 Unknown - (transl_if env arg2 dbg2 approx then_ shareable_else) - shareable_else) + transl_if env Unknown + arg1_dbg arg1 + arg2_dbg (transl_if env approx + arg2_dbg arg2 + then_dbg then_ + else_dbg shareable_else) + else_dbg shareable_else) else_ -and transl_sequor env arg1 dbg1 arg2 dbg2 approx then_ else_ = - make_shareable_cont +and transl_sequor env (approx : then_else) + (arg1_dbg : Debuginfo.t) arg1 + (arg2_dbg : Debuginfo.t) arg2 + (then_dbg : Debuginfo.t) then_ + (else_dbg : Debuginfo.t) else_ = + make_shareable_cont then_dbg (fun shareable_then -> - transl_if env arg1 dbg1 Unknown - shareable_then - (transl_if env arg2 dbg2 approx shareable_then else_)) + transl_if env Unknown + arg1_dbg arg1 + then_dbg shareable_then + arg2_dbg (transl_if env approx + arg2_dbg arg2 + then_dbg shareable_then + else_dbg else_)) then_ (* This assumes that [arg] can be safely discarded if it is not used. *) @@ -2861,27 +3200,32 @@ and transl_letrec env bindings cont = List.map (fun (id, exp) -> (id, exp, expr_size V.empty exp)) bindings in - let op_alloc prim sz = - Cop(Cextcall(prim, typ_val, true, None), [int_const sz], dbg) in + let op_alloc prim args = + Cop(Cextcall(prim, typ_val, true, None), args, dbg) in let rec init_blocks = function | [] -> fill_nonrec bsz | (id, _exp, RHS_block sz) :: rem -> - Clet(id, op_alloc "caml_alloc_dummy" sz, + Clet(id, op_alloc "caml_alloc_dummy" [int_const dbg sz], init_blocks rem) + | (id, _exp, RHS_infix { blocksize; offset}) :: rem -> + Clet(id, op_alloc "caml_alloc_dummy_infix" + [int_const dbg blocksize; int_const dbg offset], + init_blocks rem) | (id, _exp, RHS_floatblock sz) :: rem -> - Clet(id, op_alloc "caml_alloc_dummy_float" sz, + Clet(id, op_alloc "caml_alloc_dummy_float" [int_const dbg sz], init_blocks rem) | (id, _exp, RHS_nonrec) :: rem -> - Clet (id, Cconst_int 0, init_blocks rem) + Clet (id, Cconst_int (0, dbg), init_blocks rem) and fill_nonrec = function | [] -> fill_blocks bsz - | (_id, _exp, (RHS_block _ | RHS_floatblock _)) :: rem -> + | (_id, _exp, + (RHS_block _ | RHS_infix _ | RHS_floatblock _)) :: rem -> fill_nonrec rem | (id, exp, RHS_nonrec) :: rem -> Clet(id, transl env exp, fill_nonrec rem) and fill_blocks = function | [] -> cont - | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> + | (id, exp, (RHS_block _ | RHS_infix _ | RHS_floatblock _)) :: rem -> let op = Cop(Cextcall("caml_update_dummy", typ_void, false, None), [Cvar (VP.var id); transl env exp], dbg) in @@ -2902,7 +3246,7 @@ let transl_function ~ppf_dump f = let cmm_body = let env = create_env ~environment_param:f.env in if !Clflags.afl_instrument then - Afl_instrument.instrument_function (transl env body) + Afl_instrument.instrument_function (transl env body) f.dbg else transl env body in let fun_codegen_options = @@ -2920,92 +3264,17 @@ let transl_function ~ppf_dump f = (* Translate all function definitions *) let rec transl_all_functions ~ppf_dump already_translated cont = - try - let f = Queue.take functions in - if String.Set.mem f.label already_translated then + match Cmmgen_state.next_function () with + | None -> cont, already_translated + | Some f -> + let sym = f.label in + if String.Set.mem sym already_translated then transl_all_functions ~ppf_dump already_translated cont else begin transl_all_functions ~ppf_dump - (String.Set.add f.label already_translated) + (String.Set.add sym already_translated) ((f.dbg, transl_function ~ppf_dump f) :: cont) end - with Queue.Empty -> - cont, already_translated - -let cdefine_symbol (symb, global) = - match global with - | Global -> [Cglobal_symbol symb; Cdefine_symbol symb] - | Not_global -> [Cdefine_symbol symb] - -(* Emit structured constants *) - -let rec emit_structured_constant symb cst cont = - let emit_block white_header symb cont = - (* Headers for structured constants must be marked black in case we - are in no-naked-pointers mode. See [caml_darken]. *) - let black_header = Nativeint.logor white_header caml_black in - Cint black_header :: cdefine_symbol symb @ cont - in - match cst with - | Uconst_float s-> - emit_block float_header symb (Cdouble s :: cont) - | Uconst_string s -> - emit_block (string_header (String.length s)) symb - (emit_string_constant s cont) - | Uconst_int32 n -> - emit_block boxedint32_header symb - (emit_boxed_int32_constant n cont) - | Uconst_int64 n -> - emit_block boxedint64_header symb - (emit_boxed_int64_constant n cont) - | Uconst_nativeint n -> - emit_block boxedintnat_header symb - (emit_boxed_nativeint_constant n cont) - | Uconst_block (tag, csts) -> - let cont = List.fold_right emit_constant csts cont in - emit_block (block_header tag (List.length csts)) symb cont - | Uconst_float_array fields -> - emit_block (floatarray_header (List.length fields)) symb - (Misc.map_end (fun f -> Cdouble f) fields cont) - | Uconst_closure(fundecls, lbl, fv) -> - assert(lbl = fst symb); - add_cmm_constant (Const_closure (symb, fundecls, fv)); - List.iter (fun f -> Queue.add f functions) fundecls; - cont - -and emit_constant cst cont = - match cst with - | Uconst_int n | Uconst_ptr n -> - cint_const n - :: cont - | Uconst_ref (label, _) -> - Csymbol_address label :: cont - -and emit_string_constant s cont = - let n = size_int - 1 - (String.length s) mod size_int in - Cstring s :: Cskip n :: Cint8 n :: cont - -and emit_boxed_int32_constant n cont = - let n = Nativeint.of_int32 n in - if size_int = 8 then - Csymbol_address("caml_int32_ops") :: Cint32 n :: Cint32 0n :: cont - else - Csymbol_address("caml_int32_ops") :: Cint n :: cont - -and emit_boxed_nativeint_constant n cont = - Csymbol_address("caml_nativeint_ops") :: Cint n :: cont - -and emit_boxed_int64_constant n cont = - let lo = Int64.to_nativeint n in - if size_int = 8 then - Csymbol_address("caml_int64_ops") :: Cint lo :: cont - else begin - let hi = Int64.to_nativeint (Int64.shift_right n 32) in - if big_endian then - Csymbol_address("caml_int64_ops") :: Cint hi :: Cint lo :: cont - else - Csymbol_address("caml_int64_ops") :: Cint lo :: Cint hi :: cont - end (* Emit constant closures *) @@ -3064,39 +3333,44 @@ let emit_constant_table symb elems = (* Emit all structured constants *) -let emit_constants cont (constants:Clambda.preallocated_constant list) = +let transl_clambda_constants (constants : Clambda.preallocated_constant list) + cont = let c = ref cont in + let emit_clambda_constant symbol global cst = + let cst = emit_structured_constant (symbol, global) cst [] in + c := (Cdata cst) :: !c + in List.iter - (fun { symbol = lbl; exported; definition = cst; provenance = _; } -> - let global = if exported then Global else Not_global in - let cst = emit_structured_constant (lbl, global) cst [] in - c:= Cdata(cst):: !c) + (fun { symbol; exported; definition = cst; provenance = _; } -> + let global : Cmmgen_state.is_global = + if exported then Global else Local + in + emit_clambda_constant symbol global cst) constants; - List.iter - (function - | Const_closure (symb, fundecls, clos_vars) -> - c := Cdata(emit_constant_closure symb fundecls clos_vars []) :: !c - | Const_table (symb, elems) -> - c := Cdata(emit_constant_table symb elems) :: !c) - !cmm_constants; - cmm_constants := []; !c -let emit_all_constants cont = - let constants = Compilenv.structured_constants () in - Compilenv.clear_structured_constants (); - emit_constants cont constants +let emit_cmm_data_items_for_constants cont = + let c = ref cont in + String.Map.iter (fun symbol (cst : Cmmgen_state.constant) -> + match cst with + | Const_closure (global, fundecls, clos_vars) -> + let cmm = + emit_constant_closure (symbol, global) fundecls clos_vars [] + in + c := (Cdata cmm) :: !c + | Const_table (global, elems) -> + c := (Cdata (emit_constant_table (symbol, global) elems)) :: !c) + (Cmmgen_state.constants ()); + Cdata (Cmmgen_state.data_items ()) :: !c -let transl_all_functions_and_emit_all_constants ~ppf_dump cont = +let transl_all_functions ~ppf_dump cont = let rec aux already_translated cont translated_functions = - if Compilenv.structured_constants () = [] && - Queue.is_empty functions + if Cmmgen_state.no_more_functions () then cont, translated_functions else let translated_functions, already_translated = transl_all_functions ~ppf_dump already_translated translated_functions in - let cont = emit_all_constants cont in aux already_translated cont translated_functions in let cont, translated_functions = @@ -3160,9 +3434,11 @@ let emit_preallocated_blocks preallocated_blocks cont = (* Translate a compilation unit *) let compunit ~ppf_dump (ulam, preallocated_blocks, constants) = + let dbg = Debuginfo.none in let init_code = if !Clflags.afl_instrument then Afl_instrument.instrument_initialiser (transl empty_env ulam) + (fun () -> dbg) else transl empty_env ulam in let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry"); @@ -3178,9 +3454,10 @@ let compunit ~ppf_dump (ulam, preallocated_blocks, constants) = ] else [ Reduce_code_size ]; fun_dbg = Debuginfo.none }] in - let c2 = emit_constants c1 constants in - let c3 = transl_all_functions_and_emit_all_constants ~ppf_dump c2 in - emit_preallocated_blocks preallocated_blocks c3 + let c2 = transl_clambda_constants constants c1 in + let c3 = transl_all_functions ~ppf_dump c2 in + let c4 = emit_preallocated_blocks preallocated_blocks c3 in + emit_cmm_data_items_for_constants c4 (* CAMLprim value caml_cache_public_method (value meths, value tag, value *cache) @@ -3198,22 +3475,23 @@ CAMLprim value caml_cache_public_method (value meths, value tag, value *cache) let cache_public_method meths tag cache dbg = let raise_num = next_raise_count () in - let li = V.create_local "li" and hi = V.create_local "hi" - and mi = V.create_local "mi" and tagged = V.create_local "tagged" in + let cconst_int i = Cconst_int (i, dbg) in + let li = V.create_local "*li*" and hi = V.create_local "*hi*" + and mi = V.create_local "*mi*" and tagged = V.create_local "*tagged*" in Clet ( - VP.create li, Cconst_int 3, + VP.create li, cconst_int 3, Clet ( VP.create hi, Cop(Cload (Word_int, Mutable), [meths], dbg), Csequence( ccatch (raise_num, [], - Cloop + create_loop (Clet( VP.create mi, Cop(Cor, - [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi], dbg); Cconst_int 1], + [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi], dbg); cconst_int 1], dbg); - Cconst_int 1], + cconst_int 1], dbg), Csequence( Cifthenelse @@ -3224,19 +3502,28 @@ let cache_public_method meths tag cache dbg = [meths; lsl_const (Cvar mi) log2_size_addr dbg], dbg)], dbg)], dbg), - Cassign(hi, Cop(Csubi, [Cvar mi; Cconst_int 2], dbg)), - Cassign(li, Cvar mi)), + dbg, Cassign(hi, Cop(Csubi, [Cvar mi; cconst_int 2], dbg)), + dbg, Cassign(li, Cvar mi), + dbg), Cifthenelse - (Cop(Ccmpi Cge, [Cvar li; Cvar hi], dbg), Cexit (raise_num, []), - Ctuple [])))), - Ctuple []), + (Cop(Ccmpi Cge, [Cvar li; Cvar hi], dbg), + dbg, Cexit (raise_num, []), + dbg, Ctuple [], + dbg)))) + dbg, + Ctuple [], + dbg), Clet ( VP.create tagged, Cop(Cadda, [lsl_const (Cvar li) log2_size_addr dbg; - Cconst_int(1 - 3 * size_addr)], dbg), + cconst_int(1 - 3 * size_addr)], dbg), Csequence(Cop (Cstore (Word_int, Assignment), [cache; Cvar tagged], dbg), Cvar tagged))))) +(* CR mshinwell: These will be filled in by later pull requests. *) +let placeholder_dbg () = Debuginfo.none +let placeholder_fun_dbg ~human_name:_ = Debuginfo.none + (* Generate an application function: (defun caml_applyN (a1 ... aN clos) (if (= clos.arity N) @@ -3249,7 +3536,7 @@ let cache_public_method meths tag cache dbg = *) let apply_function_body arity = - let dbg = Debuginfo.none in + let dbg = placeholder_dbg in let arg = Array.make arity (V.create_local "arg") in for i = 1 to arity - 1 do arg.(i) <- V.create_local "arg" done; let clos = V.create_local "clos" in @@ -3257,12 +3544,14 @@ let apply_function_body arity = let rec app_fun clos n = if n = arity-1 then Cop(Capply typ_val, - [get_field env (Cvar clos) 0 dbg; Cvar arg.(n); Cvar clos], dbg) + [get_field env (Cvar clos) 0 (dbg ()); Cvar arg.(n); Cvar clos], + dbg ()) else begin let newclos = V.create_local "clos" in Clet(VP.create newclos, Cop(Capply typ_val, - [get_field env (Cvar clos) 0 dbg; Cvar arg.(n); Cvar clos], dbg), + [get_field env (Cvar clos) 0 (dbg ()); Cvar arg.(n); Cvar clos], + dbg ()), app_fun newclos (n+1)) end in let args = Array.to_list arg in @@ -3270,14 +3559,20 @@ let apply_function_body arity = (args, clos, if arity = 1 then app_fun clos 0 else Cifthenelse( - Cop(Ccmpi Ceq, [get_field env (Cvar clos) 1 dbg; int_const arity], dbg), + Cop(Ccmpi Ceq, + [get_field env (Cvar clos) 1 (dbg ()); int_const (dbg ()) arity], dbg ()), + dbg (), Cop(Capply typ_val, - get_field env (Cvar clos) 2 dbg :: List.map (fun s -> Cvar s) all_args, - dbg), - app_fun clos 0)) + get_field env (Cvar clos) 2 (dbg ()) + :: List.map (fun s -> Cvar s) all_args, + dbg ()), + dbg (), + app_fun clos 0, + dbg ())) let send_function arity = - let dbg = Debuginfo.none in + let dbg = placeholder_dbg in + let cconst_int i = Cconst_int (i, dbg ()) in let (args, clos', body) = apply_function_body (1+arity) in let cache = V.create_local "cache" and obj = List.hd args @@ -3287,49 +3582,56 @@ let send_function arity = let cache = Cvar cache and obj = Cvar obj and tag = Cvar tag in let meths = V.create_local "meths" and cached = V.create_local "cached" in let real = V.create_local "real" in - let mask = get_field env (Cvar meths) 1 dbg in + let mask = get_field env (Cvar meths) 1 (dbg ()) in let cached_pos = Cvar cached in - let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths], dbg); - Cconst_int(3*size_addr-1)], dbg) in - let tag' = Cop(Cload (Word_int, Mutable), [tag_pos], dbg) in + let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths], dbg ()); + cconst_int(3*size_addr-1)], dbg ()) in + let tag' = Cop(Cload (Word_int, Mutable), [tag_pos], dbg ()) in Clet ( - VP.create meths, Cop(Cload (Word_val, Mutable), [obj], dbg), + VP.create meths, Cop(Cload (Word_val, Mutable), [obj], dbg ()), Clet ( VP.create cached, - Cop(Cand, [Cop(Cload (Word_int, Mutable), [cache], dbg); mask], dbg), + Cop(Cand, [Cop(Cload (Word_int, Mutable), [cache], dbg ()); mask], + dbg ()), Clet ( VP.create real, - Cifthenelse(Cop(Ccmpa Cne, [tag'; tag], dbg), - cache_public_method (Cvar meths) tag cache dbg, - cached_pos), + Cifthenelse(Cop(Ccmpa Cne, [tag'; tag], dbg ()), + dbg (), + cache_public_method (Cvar meths) tag cache (dbg ()), + dbg (), + cached_pos, + dbg ()), Cop(Cload (Word_val, Mutable), - [Cop(Cadda, [Cop (Cadda, [Cvar real; Cvar meths], dbg); - Cconst_int(2*size_addr-1)], dbg)], dbg)))) + [Cop(Cadda, [Cop (Cadda, [Cvar real; Cvar meths], dbg ()); + cconst_int(2*size_addr-1)], dbg ())], dbg ())))) in let body = Clet(VP.create clos', clos, body) in let cache = cache in + let fun_name = "caml_send" ^ Int.to_string arity in let fun_args = [obj, typ_val; tag, typ_int; cache, typ_val] @ List.map (fun id -> (id, typ_val)) (List.tl args) in - let fun_name = "caml_send" ^ Int.to_string arity in + let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in Cfunction {fun_name; fun_args = List.map (fun (arg, ty) -> VP.create arg, ty) fun_args; fun_body = body; fun_codegen_options = []; - fun_dbg = Debuginfo.none } + fun_dbg; + } let apply_function arity = let (args, clos, body) = apply_function_body arity in let all_args = args @ [clos] in let fun_name = "caml_apply" ^ Int.to_string arity in + let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in Cfunction {fun_name; fun_args = List.map (fun arg -> (VP.create arg, typ_val)) all_args; fun_body = body; fun_codegen_options = []; - fun_dbg = Debuginfo.none; + fun_dbg; } (* Generate tuplifying functions: @@ -3337,24 +3639,26 @@ let apply_function arity = (app clos.direct #0(arg) ... #N-1(arg) clos)) *) let tuplify_function arity = - let dbg = Debuginfo.none in + let dbg = placeholder_dbg in let arg = V.create_local "arg" in let clos = V.create_local "clos" in let env = empty_env in let rec access_components i = if i >= arity then [] - else get_field env (Cvar arg) i dbg :: access_components(i+1) in + else get_field env (Cvar arg) i (dbg ()) :: access_components(i+1) in let fun_name = "caml_tuplify" ^ Int.to_string arity in + let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in Cfunction {fun_name; fun_args = [VP.create arg, typ_val; VP.create clos, typ_val]; fun_body = Cop(Capply typ_val, - get_field env (Cvar clos) 2 dbg :: access_components 0 @ [Cvar clos], - dbg); + get_field env (Cvar clos) 2 (dbg ()) + :: access_components 0 @ [Cvar clos], + dbg ()); fun_codegen_options = []; - fun_dbg = Debuginfo.none; + fun_dbg; } (* Generate currying functions: @@ -3387,41 +3691,46 @@ let tuplify_function arity = let max_arity_optimized = 15 let final_curry_function arity = - let dbg = Debuginfo.none in + let dbg = placeholder_dbg in let last_arg = V.create_local "arg" in let last_clos = V.create_local "clos" in let env = empty_env in let rec curry_fun args clos n = if n = 0 then Cop(Capply typ_val, - get_field env (Cvar clos) 2 dbg :: + get_field env (Cvar clos) 2 (dbg ()) :: args @ [Cvar last_arg; Cvar clos], - dbg) + dbg ()) else if n = arity - 1 || arity > max_arity_optimized then begin let newclos = V.create_local "clos" in Clet(VP.create newclos, - get_field env (Cvar clos) 3 dbg, - curry_fun (get_field env (Cvar clos) 2 dbg :: args) newclos (n-1)) + get_field env (Cvar clos) 3 (dbg ()), + curry_fun (get_field env (Cvar clos) 2 (dbg ()) :: args) + newclos (n-1)) end else begin let newclos = V.create_local "clos" in Clet(VP.create newclos, - get_field env (Cvar clos) 4 dbg, - curry_fun (get_field env (Cvar clos) 3 dbg :: args) + get_field env (Cvar clos) 4 (dbg ()), + curry_fun (get_field env (Cvar clos) 3 (dbg ()) :: args) newclos (n-1)) end in + let fun_name = + "caml_curry" ^ Int.to_string arity ^ "_" ^ Int.to_string (arity-1) + in + let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in Cfunction - {fun_name = "caml_curry" ^ Int.to_string arity ^ - "_" ^ Int.to_string (arity-1); + {fun_name; fun_args = [VP.create last_arg, typ_val; VP.create last_clos, typ_val]; fun_body = curry_fun [] last_clos (arity-1); fun_codegen_options = []; - fun_dbg = Debuginfo.none } + fun_dbg; + } let rec intermediate_curry_functions arity num = - let dbg = Debuginfo.none in + let dbg = placeholder_dbg in let env = empty_env in if num = arity - 1 then [final_curry_function arity] @@ -3429,6 +3738,7 @@ let rec intermediate_curry_functions arity num = let name1 = "caml_curry" ^ Int.to_string arity in let name2 = if num = 0 then name1 else name1 ^ "_" ^ Int.to_string num in let arg = V.create_local "arg" and clos = V.create_local "clos" in + let fun_dbg = placeholder_fun_dbg ~human_name:name2 in Cfunction {fun_name = name2; fun_args = [VP.create arg, typ_val; VP.create clos, typ_val]; @@ -3436,19 +3746,21 @@ let rec intermediate_curry_functions arity num = if arity - num > 2 && arity <= max_arity_optimized then Cop(Calloc, [alloc_closure_header 5 Debuginfo.none; - Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1)); - int_const (arity - num - 1); - Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1) ^ "_app"); + Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1), dbg ()); + int_const (dbg ()) (arity - num - 1); + Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1) ^ "_app", + dbg ()); Cvar arg; Cvar clos], - dbg) + dbg ()) else Cop(Calloc, - [alloc_closure_header 4 Debuginfo.none; - Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1)); - int_const 1; Cvar arg; Cvar clos], - dbg); + [alloc_closure_header 4 (dbg ()); + Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1), dbg ()); + int_const (dbg ()) 1; Cvar arg; Cvar clos], + dbg ()); fun_codegen_options = []; - fun_dbg = Debuginfo.none } + fun_dbg; + } :: (if arity <= max_arity_optimized && arity - num > 2 then let rec iter i = @@ -3461,26 +3773,30 @@ let rec intermediate_curry_functions arity num = let rec iter i args clos = if i = 0 then Cop(Capply typ_val, - (get_field env (Cvar clos) 2 dbg) :: args @ [Cvar clos], - dbg) + (get_field env (Cvar clos) 2 (dbg ())) :: args @ [Cvar clos], + dbg ()) else let newclos = V.create_local "clos" in Clet(VP.create newclos, - get_field env (Cvar clos) 4 dbg, - iter (i-1) (get_field env (Cvar clos) 3 dbg :: args) newclos) + get_field env (Cvar clos) 4 (dbg ()), + iter (i-1) (get_field env (Cvar clos) 3 (dbg ()) :: args) + newclos) in let fun_args = List.map (fun (arg, ty) -> VP.create arg, ty) (direct_args @ [clos, typ_val]) in + let fun_name = name1 ^ "_" ^ Int.to_string (num+1) ^ "_app" in + let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in let cf = Cfunction - {fun_name = name1 ^ "_" ^ Int.to_string (num+1) ^ "_app"; + {fun_name; fun_args; fun_body = iter (num+1) (List.map (fun (arg,_) -> Cvar arg) direct_args) clos; fun_codegen_options = []; - fun_dbg = Debuginfo.none } + fun_dbg; + } in cf :: intermediate_curry_functions arity (num+1) else @@ -3517,28 +3833,31 @@ let generic_functions shared units = (* Generate the entry point *) let entry_point namelist = - (* CR mshinwell: review all of these "None"s. We should be able to at - least have filenames for these. *) - let dbg = Debuginfo.none in - let incr_global_inited = + let dbg = placeholder_dbg in + let cconst_int i = Cconst_int (i, dbg ()) in + let cconst_symbol sym = Cconst_symbol (sym, dbg ()) in + let incr_global_inited () = Cop(Cstore (Word_int, Assignment), - [Cconst_symbol "caml_globals_inited"; + [cconst_symbol "caml_globals_inited"; Cop(Caddi, [Cop(Cload (Word_int, Mutable), - [Cconst_symbol "caml_globals_inited"], dbg); - Cconst_int 1], dbg)], dbg) in + [cconst_symbol "caml_globals_inited"], dbg ()); + cconst_int 1], dbg ())], dbg ()) in let body = List.fold_right (fun name next -> let entry_sym = Compilenv.make_symbol ~unitname:name (Some "entry") in Csequence(Cop(Capply typ_void, - [Cconst_symbol entry_sym], dbg), - Csequence(incr_global_inited, next))) - namelist (Cconst_int 1) in - Cfunction {fun_name = "caml_program"; + [cconst_symbol entry_sym], dbg ()), + Csequence(incr_global_inited (), next))) + namelist (cconst_int 1) in + let fun_name = "caml_program" in + let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in + Cfunction {fun_name; fun_args = []; fun_body = body; fun_codegen_options = [Reduce_code_size]; - fun_dbg = Debuginfo.none } + fun_dbg; + } (* Generate the table of globals *) @@ -3607,16 +3926,21 @@ let code_segment_table namelist = (* Initialize a predefined exception *) let predef_exception i name = - let symname = "caml_exn_" ^ name in - let cst = Uconst_string name in - let label = Compilenv.new_const_symbol () in - let cont = emit_structured_constant (label, Not_global) cst [] in - Cdata(emit_structured_constant (symname, Global) - (Uconst_block(Obj.object_tag, - [ - Uconst_ref(label, Some cst); - Uconst_int (-i-1); - ])) cont) + let name_sym = Compilenv.new_const_symbol () in + let data_items = + emit_block name_sym Local (string_header (String.length name)) + (emit_string_constant name []) + in + let exn_sym = "caml_exn_" ^ name in + let tag = Obj.object_tag in + let size = 2 in + let fields = + (Csymbol_address name_sym) + :: (cint_const (-i - 1)) + :: data_items + in + let data_items = emit_block exn_sym Global (block_header tag size) fields in + Cdata data_items (* Header for a plugin *) @@ -3630,3 +3954,6 @@ let plugin_header units = } in global_data "caml_plugin_header" { dynu_magic = Config.cmxs_magic_number; dynu_units = List.map mk units } + +let reset () = + Cmmgen_state.reset () diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli index 6c33da95..b7388a3f 100644 --- a/asmcomp/cmmgen.mli +++ b/asmcomp/cmmgen.mli @@ -38,3 +38,5 @@ val code_segment_table: string list -> Cmm.phrase val predef_exception: int -> string -> Cmm.phrase val plugin_header: (Cmx_format.unit_infos * Digest.t) list -> Cmm.phrase val black_block_header: (*tag:*)int -> (*size:*)int -> nativeint + +val reset : unit -> unit diff --git a/asmcomp/cmmgen_state.ml b/asmcomp/cmmgen_state.ml new file mode 100644 index 00000000..b40375a6 --- /dev/null +++ b/asmcomp/cmmgen_state.ml @@ -0,0 +1,66 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2019 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +module S = Misc.Stdlib.String + +type is_global = Global | Local + +type constant = + | Const_closure of is_global * Clambda.ufunction list * Clambda.uconstant list + | Const_table of is_global * Cmm.data_item list + +type t = { + mutable constants : constant S.Map.t; + mutable data_items : Cmm.data_item list list; + functions : Clambda.ufunction Queue.t; +} + +let empty = { + constants = S.Map.empty; + data_items = []; + functions = Queue.create (); +} + +let state = empty + +let reset () = + state.constants <- S.Map.empty; + state.data_items <- []; + Queue.clear state.functions + +let add_constant sym cst = + state.constants <- S.Map.add sym cst state.constants + +let add_data_items items = + state.data_items <- items :: state.data_items + +let add_function func = + Queue.add func state.functions + +let constants () = state.constants + +let data_items () = List.concat (List.rev state.data_items) + +let next_function () = + match Queue.take state.functions with + | exception Queue.Empty -> None + | func -> Some func + +let no_more_functions () = + Queue.is_empty state.functions diff --git a/asmcomp/cmmgen_state.mli b/asmcomp/cmmgen_state.mli new file mode 100644 index 00000000..aa9de814 --- /dev/null +++ b/asmcomp/cmmgen_state.mli @@ -0,0 +1,42 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2019 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Mutable state used by [Cmmgen]. *) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +val reset : unit -> unit + +type is_global = Global | Local + +type constant = + | Const_closure of is_global * Clambda.ufunction list * Clambda.uconstant list + | Const_table of is_global * Cmm.data_item list + +val add_constant : Misc.Stdlib.String.t -> constant -> unit + +val add_data_items : Cmm.data_item list -> unit + +val add_function : Clambda.ufunction -> unit + +val constants : unit -> constant Misc.Stdlib.String.Map.t + +val data_items : unit -> Cmm.data_item list + +val next_function : unit -> Clambda.ufunction option + +val no_more_functions : unit -> bool diff --git a/asmcomp/cmx_format.mli b/asmcomp/cmx_format.mli deleted file mode 100644 index 0e3cf285..00000000 --- a/asmcomp/cmx_format.mli +++ /dev/null @@ -1,72 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2010 Institut National de Recherche en Informatique et *) -(* en Automatique *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Format of .cmx, .cmxa and .cmxs files *) - -(* Each .o file has a matching .cmx file that provides the following infos - on the compilation unit: - - list of other units imported, with MD5s of their .cmx files - - approximation of the structure implemented - (includes descriptions of known functions: arity and direct entry - points) - - list of currying functions and application functions needed - The .cmx file contains these infos (as an externed record) plus a MD5 - of these infos *) - -type export_info = - | Clambda of Clambda.value_approximation - | Flambda of Export_info.t - -type unit_infos = - { mutable ui_name: string; (* Name of unit implemented *) - mutable ui_symbol: string; (* Prefix for symbols *) - mutable ui_defines: string list; (* Unit and sub-units implemented *) - mutable ui_imports_cmi: - (string * Digest.t option) list; (* Interfaces imported *) - mutable ui_imports_cmx:(string * Digest.t option) list; (* Infos imported *) - mutable ui_curry_fun: int list; (* Currying functions needed *) - mutable ui_apply_fun: int list; (* Apply functions needed *) - mutable ui_send_fun: int list; (* Send functions needed *) - mutable ui_export_info: export_info; - mutable ui_force_link: bool } (* Always linked *) - -(* Each .a library has a matching .cmxa file that provides the following - infos on the library: *) - -type library_infos = - { lib_units: (unit_infos * Digest.t) list; (* List of unit infos w/ MD5s *) - lib_ccobjs: string list; (* C object files needed *) - lib_ccopts: string list } (* Extra opts to C compiler *) - -(* Each .cmxs dynamically-loaded plugin contains a symbol - "caml_plugin_header" containing the following info - (as an externed record) *) - -type dynunit = { - dynu_name: string; - dynu_crc: Digest.t; - dynu_imports_cmi: (string * Digest.t option) list; - dynu_imports_cmx: (string * Digest.t option) list; - dynu_defines: string list; -} - -type dynheader = { - dynu_magic: string; - dynu_units: dynunit list; -} diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml index b10edd2a..29ee15b3 100644 --- a/asmcomp/comballoc.ml +++ b/asmcomp/comballoc.ml @@ -74,10 +74,6 @@ let rec combine i allocstate = let newnext = combine_restart i.next in (instr_cons (Iswitch(table, newcases)) i.arg i.res newnext, allocated_size allocstate) - | Iloop(body) -> - let newbody = combine_restart body in - (instr_cons (Iloop(newbody)) i.arg i.res i.next, - allocated_size allocstate) | Icatch(rec_flag, handlers, body) -> let (newbody, sz) = combine body allocstate in let newhandlers = diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml deleted file mode 100644 index add4e90e..00000000 --- a/asmcomp/compilenv.ml +++ /dev/null @@ -1,452 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2010 Institut National de Recherche en Informatique et *) -(* en Automatique *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Compilation environments for compilation units *) - -[@@@ocaml.warning "+a-4-9-40-41-42"] - -open Config -open Cmx_format - -type error = - Not_a_unit_info of string - | Corrupted_unit_info of string - | Illegal_renaming of string * string * string - -exception Error of error - -let global_infos_table = - (Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t) -let export_infos_table = - (Hashtbl.create 10 : (string, Export_info.t) Hashtbl.t) - -let imported_sets_of_closures_table = - (Set_of_closures_id.Tbl.create 10 - : Simple_value_approx.function_declarations option - Set_of_closures_id.Tbl.t) - -module CstMap = - Map.Make(struct - type t = Clambda.ustructured_constant - let compare = Clambda.compare_structured_constants - (* PR#6442: it is incorrect to use Stdlib.compare on values of type t - because it compares "0.0" and "-0.0" equal. *) - end) - -type structured_constants = - { - strcst_shared: string CstMap.t; - strcst_all: (string * Clambda.ustructured_constant) list; - } - -let structured_constants_empty = - { - strcst_shared = CstMap.empty; - strcst_all = []; - } - -let structured_constants = ref structured_constants_empty - - -let exported_constants = Hashtbl.create 17 - -let merged_environment = ref Export_info.empty - -let default_ui_export_info = - if Config.flambda then - Cmx_format.Flambda Export_info.empty - else - Cmx_format.Clambda Value_unknown - -let current_unit = - { ui_name = ""; - ui_symbol = ""; - ui_defines = []; - ui_imports_cmi = []; - ui_imports_cmx = []; - ui_curry_fun = []; - ui_apply_fun = []; - ui_send_fun = []; - ui_force_link = false; - ui_export_info = default_ui_export_info } - -let symbolname_for_pack pack name = - match pack with - | None -> name - | Some p -> - let b = Buffer.create 64 in - for i = 0 to String.length p - 1 do - match p.[i] with - | '.' -> Buffer.add_string b "__" - | c -> Buffer.add_char b c - done; - Buffer.add_string b "__"; - Buffer.add_string b name; - Buffer.contents b - -let unit_id_from_name name = Ident.create_persistent name - -let concat_symbol unitname id = - unitname ^ "__" ^ id - -let make_symbol ?(unitname = current_unit.ui_symbol) idopt = - let prefix = "caml" ^ unitname in - match idopt with - | None -> prefix - | Some id -> concat_symbol prefix id - -let current_unit_linkage_name () = - Linkage_name.create (make_symbol ~unitname:current_unit.ui_symbol None) - -let reset ?packname name = - Hashtbl.clear global_infos_table; - Set_of_closures_id.Tbl.clear imported_sets_of_closures_table; - let symbol = symbolname_for_pack packname name in - current_unit.ui_name <- name; - current_unit.ui_symbol <- symbol; - current_unit.ui_defines <- [symbol]; - current_unit.ui_imports_cmi <- []; - current_unit.ui_imports_cmx <- []; - current_unit.ui_curry_fun <- []; - current_unit.ui_apply_fun <- []; - current_unit.ui_send_fun <- []; - current_unit.ui_force_link <- !Clflags.link_everything; - Hashtbl.clear exported_constants; - structured_constants := structured_constants_empty; - current_unit.ui_export_info <- default_ui_export_info; - merged_environment := Export_info.empty; - Hashtbl.clear export_infos_table; - let compilation_unit = - Compilation_unit.create - (Ident.create_persistent name) - (current_unit_linkage_name ()) - in - Compilation_unit.set_current compilation_unit - -let current_unit_infos () = - current_unit - -let current_unit_name () = - current_unit.ui_name - -let symbol_in_current_unit name = - let prefix = "caml" ^ current_unit.ui_symbol in - name = prefix || - (let lp = String.length prefix in - String.length name >= 2 + lp - && String.sub name 0 lp = prefix - && name.[lp] = '_' - && name.[lp + 1] = '_') - -let read_unit_info filename = - let ic = open_in_bin filename in - try - let buffer = really_input_string ic (String.length cmx_magic_number) in - if buffer <> cmx_magic_number then begin - close_in ic; - raise(Error(Not_a_unit_info filename)) - end; - let ui = (input_value ic : unit_infos) in - let crc = Digest.input ic in - close_in ic; - (ui, crc) - with End_of_file | Failure _ -> - close_in ic; - raise(Error(Corrupted_unit_info(filename))) - -let read_library_info filename = - let ic = open_in_bin filename in - let buffer = really_input_string ic (String.length cmxa_magic_number) in - if buffer <> cmxa_magic_number then - raise(Error(Not_a_unit_info filename)); - let infos = (input_value ic : library_infos) in - close_in ic; - infos - - -(* Read and cache info on global identifiers *) - -let get_global_info global_ident = ( - let modname = Ident.name global_ident in - if modname = current_unit.ui_name then - Some current_unit - else begin - try - Hashtbl.find global_infos_table modname - with Not_found -> - let (infos, crc) = - if Env.is_imported_opaque modname then (None, None) - else begin - try - let filename = - Load_path.find_uncap (modname ^ ".cmx") in - let (ui, crc) = read_unit_info filename in - if ui.ui_name <> modname then - raise(Error(Illegal_renaming(modname, ui.ui_name, filename))); - (Some ui, Some crc) - with Not_found -> - let warn = Warnings.No_cmx_file modname in - Location.prerr_warning Location.none warn; - (None, None) - end - in - current_unit.ui_imports_cmx <- - (modname, crc) :: current_unit.ui_imports_cmx; - Hashtbl.add global_infos_table modname infos; - infos - end -) - -let cache_unit_info ui = - Hashtbl.add global_infos_table ui.ui_name (Some ui) - -(* Return the approximation of a global identifier *) - -let get_clambda_approx ui = - assert(not Config.flambda); - match ui.ui_export_info with - | Flambda _ -> assert false - | Clambda approx -> approx - -let toplevel_approx : - (string, Clambda.value_approximation) Hashtbl.t = Hashtbl.create 16 - -let record_global_approx_toplevel () = - Hashtbl.add toplevel_approx current_unit.ui_name - (get_clambda_approx current_unit) - -let global_approx id = - if Ident.is_predef id then Clambda.Value_unknown - else try Hashtbl.find toplevel_approx (Ident.name id) - with Not_found -> - match get_global_info id with - | None -> Clambda.Value_unknown - | Some ui -> get_clambda_approx ui - -(* Return the symbol used to refer to a global identifier *) - -let symbol_for_global id = - if Ident.is_predef id then - "caml_exn_" ^ Ident.name id - else begin - let unitname = Ident.name id in - match - try ignore (Hashtbl.find toplevel_approx unitname); None - with Not_found -> get_global_info id - with - | None -> make_symbol ~unitname:(Ident.name id) None - | Some ui -> make_symbol ~unitname:ui.ui_symbol None - end - -(* Register the approximation of the module being compiled *) - -let unit_for_global id = - let sym_label = Linkage_name.create (symbol_for_global id) in - Compilation_unit.create id sym_label - -let predefined_exception_compilation_unit = - Compilation_unit.create (Ident.create_persistent "__dummy__") - (Linkage_name.create "__dummy__") - -let is_predefined_exception sym = - Compilation_unit.equal - predefined_exception_compilation_unit - (Symbol.compilation_unit sym) - -let symbol_for_global' id = - let sym_label = Linkage_name.create (symbol_for_global id) in - if Ident.is_predef id then - Symbol.of_global_linkage predefined_exception_compilation_unit sym_label - else - Symbol.of_global_linkage (unit_for_global id) sym_label - -let set_global_approx approx = - assert(not Config.flambda); - current_unit.ui_export_info <- Clambda approx - -(* Exporting and importing cross module information *) - -let get_flambda_export_info ui = - assert(Config.flambda); - match ui.ui_export_info with - | Clambda _ -> assert false - | Flambda ei -> ei - -let set_export_info export_info = - assert(Config.flambda); - current_unit.ui_export_info <- Flambda export_info - -let approx_for_global comp_unit = - let id = Compilation_unit.get_persistent_ident comp_unit in - if (Compilation_unit.equal - predefined_exception_compilation_unit - comp_unit) - || Ident.is_predef id - || not (Ident.global id) - then invalid_arg (Format.asprintf "approx_for_global %a" Ident.print id); - let modname = Ident.name id in - match Hashtbl.find export_infos_table modname with - | otherwise -> Some otherwise - | exception Not_found -> - match get_global_info id with - | None -> None - | Some ui -> - let exported = get_flambda_export_info ui in - Hashtbl.add export_infos_table modname exported; - merged_environment := Export_info.merge !merged_environment exported; - Some exported - -let approx_env () = !merged_environment - -(* Record that a currying function or application function is needed *) - -let need_curry_fun n = - if not (List.mem n current_unit.ui_curry_fun) then - current_unit.ui_curry_fun <- n :: current_unit.ui_curry_fun - -let need_apply_fun n = - assert(n > 0); - if not (List.mem n current_unit.ui_apply_fun) then - current_unit.ui_apply_fun <- n :: current_unit.ui_apply_fun - -let need_send_fun n = - if not (List.mem n current_unit.ui_send_fun) then - current_unit.ui_send_fun <- n :: current_unit.ui_send_fun - -(* Write the description of the current unit *) - -let write_unit_info info filename = - let oc = open_out_bin filename in - output_string oc cmx_magic_number; - output_value oc info; - flush oc; - let crc = Digest.file filename in - Digest.output oc crc; - close_out oc - -let save_unit_info filename = - current_unit.ui_imports_cmi <- Env.imports(); - write_unit_info current_unit filename - -let current_unit () = - match Compilation_unit.get_current () with - | Some current_unit -> current_unit - | None -> Misc.fatal_error "Compilenv.current_unit" - -let current_unit_symbol () = - Symbol.of_global_linkage (current_unit ()) (current_unit_linkage_name ()) - -let const_label = ref 0 - -let new_const_symbol () = - incr const_label; - make_symbol (Some (Int.to_string !const_label)) - -let snapshot () = !structured_constants -let backtrack s = structured_constants := s - -let new_structured_constant cst ~shared = - let {strcst_shared; strcst_all} = !structured_constants in - if shared then - try - CstMap.find cst strcst_shared - with Not_found -> - let lbl = new_const_symbol() in - structured_constants := - { - strcst_shared = CstMap.add cst lbl strcst_shared; - strcst_all = (lbl, cst) :: strcst_all; - }; - lbl - else - let lbl = new_const_symbol() in - structured_constants := - { - strcst_shared; - strcst_all = (lbl, cst) :: strcst_all; - }; - lbl - -let add_exported_constant s = - Hashtbl.replace exported_constants s () - -let clear_structured_constants () = - structured_constants := structured_constants_empty - -let structured_constants () = - let provenance : Clambda.usymbol_provenance = - { original_idents = []; - module_path = - Path.Pident (Ident.create_persistent (current_unit_name ())); - } - in - List.map - (fun (symbol, definition) -> - { - Clambda.symbol; - exported = Hashtbl.mem exported_constants symbol; - definition; - provenance = Some provenance; - }) - (!structured_constants).strcst_all - -let closure_symbol fv = - let compilation_unit = Closure_id.get_compilation_unit fv in - let unitname = - Linkage_name.to_string (Compilation_unit.get_linkage_name compilation_unit) - in - let linkage_name = - concat_symbol unitname ((Closure_id.unique_name fv) ^ "_closure") - in - Symbol.of_global_linkage compilation_unit (Linkage_name.create linkage_name) - -let function_label fv = - let compilation_unit = Closure_id.get_compilation_unit fv in - let unitname = - Linkage_name.to_string - (Compilation_unit.get_linkage_name compilation_unit) - in - (concat_symbol unitname (Closure_id.unique_name fv)) - -let require_global global_ident = - if not (Ident.is_predef global_ident) then - ignore (get_global_info global_ident : Cmx_format.unit_infos option) - -(* Error report *) - -open Format - -let report_error ppf = function - | Not_a_unit_info filename -> - fprintf ppf "%a@ is not a compilation unit description." - Location.print_filename filename - | Corrupted_unit_info filename -> - fprintf ppf "Corrupted compilation unit description@ %a" - Location.print_filename filename - | Illegal_renaming(name, modname, filename) -> - fprintf ppf "%a@ contains the description for unit\ - @ %s when %s was expected" - Location.print_filename filename name modname - -let () = - Location.register_error_of_exn - (function - | Error err -> Some (Location.error_of_printer_file report_error err) - | _ -> None - ) diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli deleted file mode 100644 index 569d51ea..00000000 --- a/asmcomp/compilenv.mli +++ /dev/null @@ -1,153 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2010 Institut National de Recherche en Informatique et *) -(* en Automatique *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Compilation environments for compilation units *) - -open Cmx_format - -(* CR-soon mshinwell: this is a bit ugly - mshinwell: deferred CR, this has been addressed in the export info - improvement feature. -*) -val imported_sets_of_closures_table - : Simple_value_approx.function_declarations option Set_of_closures_id.Tbl.t - (* flambda-only *) - -val reset: ?packname:string -> string -> unit - (* Reset the environment and record the name of the unit being - compiled (arg). Optional argument is [-for-pack] prefix. *) - -val unit_id_from_name: string -> Ident.t - (* flambda-only *) - -val current_unit_infos: unit -> unit_infos - (* Return the infos for the unit being compiled *) - -val current_unit_name: unit -> string - (* Return the name of the unit being compiled - clambda-only *) - -val current_unit_linkage_name: unit -> Linkage_name.t - (* Return the linkage_name of the unit being compiled. - flambda-only *) - -val current_unit: unit -> Compilation_unit.t - (* flambda-only *) - -val current_unit_symbol: unit -> Symbol.t - (* flambda-only *) - -val make_symbol: ?unitname:string -> string option -> string - (* [make_symbol ~unitname:u None] returns the asm symbol that - corresponds to the compilation unit [u] (default: the current unit). - [make_symbol ~unitname:u (Some id)] returns the asm symbol that - corresponds to symbol [id] in the compilation unit [u] - (or the current unit). *) - -val symbol_in_current_unit: string -> bool - (* Return true if the given asm symbol belongs to the - current compilation unit, false otherwise. *) - -val is_predefined_exception: Symbol.t -> bool - (* flambda-only *) - -val unit_for_global: Ident.t -> Compilation_unit.t - (* flambda-only *) - -val symbol_for_global: Ident.t -> string - (* Return the asm symbol that refers to the given global identifier - flambda-only *) -val symbol_for_global': Ident.t -> Symbol.t - (* flambda-only *) -val global_approx: Ident.t -> Clambda.value_approximation - (* Return the approximation for the given global identifier - clambda-only *) -val set_global_approx: Clambda.value_approximation -> unit - (* Record the approximation of the unit being compiled - clambda-only *) -val record_global_approx_toplevel: unit -> unit - (* Record the current approximation for the current toplevel phrase - clambda-only *) - -val set_export_info: Export_info.t -> unit - (* Record the information of the unit being compiled - flambda-only *) -val approx_env: unit -> Export_info.t - (* Returns all the information loaded from external compilation units - flambda-only *) -val approx_for_global: Compilation_unit.t -> Export_info.t option - (* Loads the exported information declaring the compilation_unit - flambda-only *) - -val need_curry_fun: int -> unit -val need_apply_fun: int -> unit -val need_send_fun: int -> unit - (* Record the need of a currying (resp. application, - message sending) function with the given arity *) - -val new_const_symbol : unit -> string -val closure_symbol : Closure_id.t -> Symbol.t - (* Symbol of a function if the function is - closed (statically allocated) - flambda-only *) -val function_label : Closure_id.t -> string - (* linkage name of the code of a function - flambda-only *) - -val new_structured_constant: - Clambda.ustructured_constant -> - shared:bool -> (* can be shared with another structurally equal constant *) - string -val structured_constants: - unit -> Clambda.preallocated_constant list -val clear_structured_constants: unit -> unit -val add_exported_constant: string -> unit - (* clambda-only *) -type structured_constants - (* clambda-only *) -val snapshot: unit -> structured_constants - (* clambda-only *) -val backtrack: structured_constants -> unit - (* clambda-only *) - -val read_unit_info: string -> unit_infos * Digest.t - (* Read infos and MD5 from a [.cmx] file. *) -val write_unit_info: unit_infos -> string -> unit - (* Save the given infos in the given file *) -val save_unit_info: string -> unit - (* Save the infos for the current unit in the given file *) -val cache_unit_info: unit_infos -> unit - (* Enter the given infos in the cache. The infos will be - honored by [symbol_for_global] and [global_approx] - without looking at the corresponding .cmx file. *) - -val require_global: Ident.t -> unit - (* Enforce a link dependency of the current compilation - unit to the required module *) - -val read_library_info: string -> library_infos - -type error = - Not_a_unit_info of string - | Corrupted_unit_info of string - | Illegal_renaming of string * string * string - -exception Error of error - -val report_error: Format.formatter -> error -> unit diff --git a/asmcomp/deadcode.ml b/asmcomp/deadcode.ml index c713b64b..d803a008 100644 --- a/asmcomp/deadcode.ml +++ b/asmcomp/deadcode.ml @@ -54,10 +54,6 @@ let rec deadcode i = let (s, _) = deadcode i.next in ({i with desc = Iswitch(index, cases'); next = s}, Reg.add_set_array i.live arg) - | Iloop(body) -> - let (body', _) = deadcode body in - let (s, _) = deadcode i.next in - ({i with desc = Iloop body'; next = s}, i.live) | Icatch(rec_flag, handlers, body) -> let (body', _) = deadcode body in let handlers' = diff --git a/asmcomp/debug/available_regs.ml b/asmcomp/debug/available_regs.ml index 9886f772..6ca2544b 100644 --- a/asmcomp/debug/available_regs.ml +++ b/asmcomp/debug/available_regs.ml @@ -225,22 +225,6 @@ let rec available_regs (instr : M.instruction) Some (ok avail_across), ok avail_after | Iifthenelse (_, ifso, ifnot) -> join [ifso; ifnot] ~avail_before | Iswitch (_, cases) -> join (Array.to_list cases) ~avail_before - | Iloop body -> - let avail_after = ref (ok avail_before) in - begin try - while true do - let avail_after' = - RAS.inter !avail_after - (available_regs body ~avail_before:!avail_after) - in - if RAS.equal !avail_after avail_after' then begin - raise Exit - end; - avail_after := avail_after' - done - with Exit -> () - end; - None, unreachable | Icatch (recursive, handlers, body) -> List.iter (fun (nfail, _handler) -> (* In case there are nested [Icatch] expressions with the same diff --git a/asmcomp/debug/compute_ranges.ml b/asmcomp/debug/compute_ranges.ml new file mode 100644 index 00000000..734eca50 --- /dev/null +++ b/asmcomp/debug/compute_ranges.ml @@ -0,0 +1,514 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2014--2019 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +open! Int_replace_polymorphic_compare + +module L = Linearize + +module Make (S : Compute_ranges_intf.S_functor) = struct + module Subrange_state = S.Subrange_state + module Subrange_info = S.Subrange_info + module Range_info = S.Range_info + + let rewrite_label env label = + match Numbers.Int.Map.find label env with + | exception Not_found -> label + | label -> label + + module Subrange = struct + (* CR-soon mshinwell: Check that function epilogues, including returns + in the middle of functions, work ok in the debugger. *) + type t = { + start_pos : L.label; + start_pos_offset : int; + end_pos : L.label; + end_pos_offset : int; + subrange_info : Subrange_info.t; + } + + let create ~(start_insn : Linearize.instruction) + ~start_pos ~start_pos_offset + ~end_pos ~end_pos_offset + ~subrange_info = + match start_insn.desc with + | Llabel _ -> + { start_pos; + start_pos_offset; + end_pos; + end_pos_offset; + subrange_info; + } + | _ -> + Misc.fatal_errorf "Subrange.create: bad [start_insn]: %a" + Printlinear.instr start_insn + + let start_pos t = t.start_pos + let start_pos_offset t = t.start_pos_offset + let end_pos t = t.end_pos + let end_pos_offset t = t.end_pos_offset + let info t = t.subrange_info + + let rewrite_labels t ~env = + let start_pos = rewrite_label env t.start_pos in + let end_pos = rewrite_label env t.end_pos in + if start_pos = end_pos + && t.start_pos_offset = 0 + && t.end_pos_offset = 0 + then None + else + Some { + t with + start_pos; + end_pos; + } + end + + module Range = struct + type t = { + mutable subranges : Subrange.t list; + mutable min_pos_and_offset : (L.label * int) option; + range_info : Range_info.t; + } + + let create range_info = + { subranges = []; + min_pos_and_offset = None; + range_info; + } + + let info t = t.range_info + + let add_subrange t ~subrange = + let start_pos = Subrange.start_pos subrange in + let start_pos_offset = Subrange.start_pos_offset subrange in + begin match t.min_pos_and_offset with + | None -> t.min_pos_and_offset <- Some (start_pos, start_pos_offset) + | Some (min_pos, min_pos_offset) -> + (* This may seem dubious, but is correct by virtue of the way label + counters are allocated sequentially and the fact that, below, + we go through the code from lowest (code) address to highest. As + such the label with the highest integer value should be the one with + the highest address, and vice-versa. (Note that we also exploit the + ordering when constructing DWARF-4 location lists, to ensure that + they are sorted in increasing program counter order by start + address.) *) + let c = compare start_pos min_pos in + if c < 0 + || (c = 0 && start_pos_offset < min_pos_offset) + then begin + t.min_pos_and_offset <- Some (start_pos, start_pos_offset) + end + end; + t.subranges <- subrange::t.subranges + + let estimate_lowest_address t = + (* See assumption described in compute_ranges_intf.ml. *) + t.min_pos_and_offset + + let fold t ~init ~f = + List.fold_left f init t.subranges + + let no_subranges t = + match t.subranges with + | [] -> true + | _ -> false + + let rewrite_labels_and_remove_empty_subranges t ~env = + let subranges = + List.filter_map (fun subrange -> + Subrange.rewrite_labels subrange ~env) + t.subranges + in + match subranges with + | [] -> + { t with + subranges; + min_pos_and_offset = None; + } + | subranges -> + let min_pos_and_offset = + Option.map + (fun (label, offset) -> rewrite_label env label, offset) + t.min_pos_and_offset + in + { t with + subranges; + min_pos_and_offset; + } + end + + type t = { + ranges : Range.t S.Index.Tbl.t; + } + + module KM = S.Key.Map + module KS = S.Key.Set + + (* Whilst this pass is not DWARF-specific, the output of this pass uses + the conventions of the DWARF specification (e.g. DWARF-4 spec. + section 2.6.2, page 30) in the sense that starting addresses of ranges + are treated as inclusive and ending addresses as exclusive. + + Imagine that, for a given [key], the program counter (PC) is exactly at the + start of [insn]; that instruction has not yet been executed. Assume + a immediately-previous instruction exists called [prev_insn]. Intuitively, + this function calculates which available subranges are to start and stop at + that point, but these notions are subtle. + + There are eight cases, referenced in the code below. + + 1. First four cases: [key] is currently unavailable, i.e. it is not a + member of (roughly speaking) [S.available_across prev_insn]. + + (a) [key] is not in [S.available_before insn] and neither is it in + [S.available_across insn]. There is nothing to do. + + (b) [key] is not in [S.available_before insn] but it is in + [S.available_across insn]. A new range is created with the starting + position being one byte after the first machine instruction of [insn] + and left open. + + It might seem like this case 1 (b) is impossible, likewise for 2 (b) + below, since "available across" should always be a subset of + "available before". However this does not hold in general: see the + comment in available_ranges_vars.ml. + + (c) [key] is in [S.available_before insn] but it is not in + [S.available_across insn]. A new range is created with the starting + position being the first machine instruction of [insn] and the ending + position being the next machine address after that. + + (d) [key] is in [S.available_before insn] and it is also in + [S.available_across insn]. A new range is created with the starting + position being the first machine instruction of [insn] and left open. + + 2. Second four cases: [key] is already available, i.e. a member of + [S.available_across prev_insn]. + + (a) [key] is not in [S.available_before insn] and neither is it in + [S.available_across insn]. The range endpoint is given as the address + of the first machine instruction of [insn]. Since endpoint bounds are + exclusive (see above) then [key] will not be shown as available when + the debugger is standing on [insn]. + + (b) [key] is not in [S.available_before insn] but it is in + [S.available_across insn]. The range endpoint is given as the address + of the first machine instruction of [insn]; and a new range is opened + in the same way as for case 1 (b), above. + + (c) [key] is in [S.available_before insn] but it is not in + [S.available_across insn]. This will only happen when calculating + variables' available ranges for operation (i.e. [Lop]) instructions + (for example calls or allocations). To give a good user experience it + is necessary to show availability when the debugger is standing on the + very first instruction of the operation but not thereafter. As such we + terminate the range one byte beyond the first machine instruction of + [insn]. + + (d) [key] is in [S.available_before insn] and it is also in + it is in [S.available_across insn]. The existing range remains open. + *) + + type action = + | Open_one_byte_subrange + | Open_subrange + | Open_subrange_one_byte_after + | Close_subrange + | Close_subrange_one_byte_after + + (* CR mshinwell: Move to [Clflags] *) + let check_invariants = ref true + + let actions_at_instruction ~(insn : L.instruction) + ~(prev_insn : L.instruction option) = + let available_before = S.available_before insn in + let available_across = S.available_across insn in + let opt_available_across_prev_insn = + match prev_insn with + | None -> KS.empty + | Some prev_insn -> S.available_across prev_insn + in + let case_1b = + KS.diff available_across + (KS.union opt_available_across_prev_insn available_before) + in + let case_1c = + KS.diff available_before + (KS.union opt_available_across_prev_insn available_across) + in + let case_1d = + KS.diff (KS.inter available_before available_across) + opt_available_across_prev_insn + in + let case_2a = + KS.diff opt_available_across_prev_insn + (KS.union available_before available_across) + in + let case_2b = + KS.inter opt_available_across_prev_insn + (KS.diff available_across available_before) + in + let case_2c = + KS.diff + (KS.inter opt_available_across_prev_insn available_before) + available_across + in + let handle case action result = + (* We use [K.all_parents] here to circumvent a potential performance + problem. In the case of lexical blocks, there may be long chains + of blocks and their parents, yet the innermost block determines the + rest of the chain. As such [S] (which comes from + lexical_block_ranges.ml) only needs to use the innermost blocks in + the "available before" sets, keeping things fast---but we still + populate ranges for all parent blocks, thus avoiding any + post-processing, by using [K.all_parents] here. *) + KS.fold (fun key result -> + List.fold_left (fun result key -> + (key, action) :: result) + result + (key :: (S.Key.all_parents key))) + case + result + in + let actions = + (* Ranges must be closed before they are opened---otherwise, when a + variable moves between registers at a range boundary, we might end up + with no open range for that variable. Note that the pipeline below + constructs the [actions] list in reverse order---later functions in + the pipeline produce actions nearer the head of the list. *) + [] + |> handle case_1b Open_subrange_one_byte_after + |> handle case_1c Open_one_byte_subrange + |> handle case_1d Open_subrange + |> handle case_2a Close_subrange + |> handle case_2b Open_subrange_one_byte_after + |> handle case_2b Close_subrange + |> handle case_2c Close_subrange_one_byte_after + in + let must_restart = + if S.must_restart_ranges_upon_any_change () + && match actions with + | [] -> false + | _::_ -> true + then + KS.inter opt_available_across_prev_insn available_before + else + KS.empty + in + actions, must_restart + + let rec process_instruction t (fundecl : L.fundecl) + ~(first_insn : L.instruction) ~(insn : L.instruction) + ~(prev_insn : L.instruction option) + ~currently_open_subranges ~subrange_state = + let used_label = ref None in + let get_label () = + match !used_label with + | Some label_and_insn -> label_and_insn + | None -> + (* Note that we can't reuse an existing label in the code since we rely + on the ordering of range-related labels. *) + let label = Cmm.new_label () in + let label_insn : L.instruction = + { desc = Llabel label; + next = insn; + arg = [| |]; + res = [| |]; + dbg = insn.dbg; + live = insn.live; + } + in + used_label := Some (label, label_insn); + label, label_insn + in + let open_subrange key ~start_pos_offset ~currently_open_subranges = + (* If the range is later discarded, the inserted label may actually be + useless, but this doesn't matter. It does not generate any code. *) + let label, label_insn = get_label () in + KM.add key (label, start_pos_offset, label_insn) currently_open_subranges + in + let close_subrange key ~end_pos_offset ~currently_open_subranges = + match KM.find key currently_open_subranges with + | exception Not_found -> + Misc.fatal_errorf "No subrange is open for key %a" + S.Key.print key + | start_pos, start_pos_offset, start_insn -> + let currently_open_subranges = KM.remove key currently_open_subranges in + match Range_info.create fundecl key ~start_insn with + | None -> currently_open_subranges + | Some (index, range_info) -> + let range = + match S.Index.Tbl.find t.ranges index with + | range -> range + | exception Not_found -> + let range = Range.create range_info in + S.Index.Tbl.add t.ranges index range; + range + in + let label, _label_insn = get_label () in + let subrange_info = Subrange_info.create key subrange_state in + let subrange = + Subrange.create ~start_insn + ~start_pos ~start_pos_offset + ~end_pos:label ~end_pos_offset + ~subrange_info + in + Range.add_subrange range ~subrange; + currently_open_subranges + in + let actions, must_restart = actions_at_instruction ~insn ~prev_insn in + (* Restart ranges if needed *) + let currently_open_subranges = + KS.fold (fun key currently_open_subranges -> + let currently_open_subranges = + close_subrange key ~end_pos_offset:0 ~currently_open_subranges + in + open_subrange key ~start_pos_offset:0 ~currently_open_subranges) + must_restart + currently_open_subranges + in + (* Apply actions *) + let currently_open_subranges = + List.fold_left (fun currently_open_subranges (key, (action : action)) -> + match action with + | Open_one_byte_subrange -> + let currently_open_subranges = + open_subrange key ~start_pos_offset:0 ~currently_open_subranges + in + close_subrange key ~end_pos_offset:1 ~currently_open_subranges + | Open_subrange -> + open_subrange key ~start_pos_offset:0 ~currently_open_subranges + | Open_subrange_one_byte_after -> + open_subrange key ~start_pos_offset:1 ~currently_open_subranges + | Close_subrange -> + close_subrange key ~end_pos_offset:0 ~currently_open_subranges + | Close_subrange_one_byte_after -> + close_subrange key ~end_pos_offset:1 ~currently_open_subranges) + currently_open_subranges + actions + in + (* Close all subranges if at last instruction *) + let currently_open_subranges = + match insn.desc with + | Lend -> + let currently_open_subranges = + KM.fold (fun key _ currently_open_subranges -> + close_subrange key ~end_pos_offset:0 ~currently_open_subranges) + currently_open_subranges + currently_open_subranges + in + assert (KM.is_empty currently_open_subranges); + currently_open_subranges + | _ -> currently_open_subranges + in + let first_insn = + match !used_label with + | None -> first_insn + | Some (_label, label_insn) -> + assert (label_insn.L.next == insn); + (* (Note that by virtue of [Lprologue], we can insert labels prior to + the first assembly instruction of the function.) *) + begin match prev_insn with + | None -> + (* The label becomes the new first instruction. *) + label_insn + | Some prev_insn -> + assert (prev_insn.L.next == insn); + prev_insn.next <- label_insn; + first_insn + end + in + if !check_invariants then begin + let currently_open_subranges = + KS.of_list ( + List.map (fun (key, _datum) -> key) + (KM.bindings currently_open_subranges)) + in + let should_be_open = S.available_across insn in + let not_open_but_should_be = + KS.diff should_be_open currently_open_subranges + in + if not (KS.is_empty not_open_but_should_be) then begin + Misc.fatal_errorf "%s: ranges for %a are not open across the following \ + instruction:\n%a\navailable_across:@ %a\n\ + currently_open_subranges: %a" + fundecl.fun_name + KS.print not_open_but_should_be + Printlinear.instr { insn with L.next = L.end_instr; } + KS.print should_be_open + KS.print currently_open_subranges + end + end; + match insn.desc with + | Lend -> first_insn + | Lprologue | Lop _ | Lreloadretaddr | Lreturn | Llabel _ + | Lbranch _ | Lcondbranch _ | Lcondbranch3 _ | Lswitch _ + | Lentertrap | Lpushtrap _ | Lpoptrap | Lraise _ -> + let subrange_state = + Subrange_state.advance_over_instruction subrange_state insn + in + process_instruction t fundecl ~first_insn ~insn:insn.next + ~prev_insn:(Some insn) ~currently_open_subranges ~subrange_state + + let process_instructions t fundecl ~first_insn = + let subrange_state = Subrange_state.create () in + process_instruction t fundecl ~first_insn ~insn:first_insn + ~prev_insn:None ~currently_open_subranges:KM.empty ~subrange_state + + let all_indexes t = + S.Index.Set.of_list (List.map fst (S.Index.Tbl.to_list t.ranges)) + + let empty = + { ranges = S.Index.Tbl.create 1; + } + + let create (fundecl : L.fundecl) = + let t = + { ranges = S.Index.Tbl.create 42; + } + in + let first_insn = + process_instructions t fundecl ~first_insn:fundecl.fun_body + in + let fundecl : L.fundecl = + { fundecl with fun_body = first_insn; } + in + t, fundecl + + let iter t ~f = + S.Index.Tbl.iter (fun index range -> f index range) + t.ranges + + let fold t ~init ~f = + S.Index.Tbl.fold (fun index range acc -> f acc index range) + t.ranges + init + + let find t index = S.Index.Tbl.find t.ranges index + + let rewrite_labels_and_remove_empty_subranges_and_ranges t ~env = + let ranges = S.Index.Tbl.create 42 in + S.Index.Tbl.iter (fun index range -> + let range = + Range.rewrite_labels_and_remove_empty_subranges range ~env + in + if not (Range.no_subranges range) then begin + S.Index.Tbl.add ranges index range + end) + t.ranges; + { ranges; + } +end diff --git a/asmcomp/debug/compute_ranges.mli b/asmcomp/debug/compute_ranges.mli new file mode 100644 index 00000000..695529f3 --- /dev/null +++ b/asmcomp/debug/compute_ranges.mli @@ -0,0 +1,28 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2014--2018 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Coalescing of per-instruction information into possibly-discontiguous + regions of code delimited by labels. This is used for collating + register availability and lexical block scoping information into a + concise form. *) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +module Make (S : Compute_ranges_intf.S_functor) + : Compute_ranges_intf.S + with module Index := S.Index + with module Key := S.Key + with module Subrange_state := S.Subrange_state + with module Subrange_info := S.Subrange_info + with module Range_info := S.Range_info diff --git a/asmcomp/debug/compute_ranges_intf.ml b/asmcomp/debug/compute_ranges_intf.ml new file mode 100644 index 00000000..69d82069 --- /dev/null +++ b/asmcomp/debug/compute_ranges_intf.ml @@ -0,0 +1,274 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2014--2019 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +(** This file defines types that are used to specify the interface of + [Compute_ranges]. The description of [Compute_ranges] is: + + "Coalescing of per-instruction information into possibly-discontiguous + regions of code delimited by labels. This is used for collating register + availability and lexical block scoping information into a concise form." + + [Compute_ranges] defines a functor, whose argument has type [S_functor], and + whose result has type [S]. Both [S_functor] and [S] are defined here. + + It is suggested that those unfamiliar with this module start by reading + the documentation on module type [S], below. +*) + +module L = Linearize + +(** The type of caller-defined contextual state associated with subranges. + This may be used to track information throughout the range-computing + process. *) +module type S_subrange_state = sig + type t + + val create : unit -> t + val advance_over_instruction : t -> L.instruction -> t +end + +(** The type of caller-defined information associated with subranges. *) +module type S_subrange_info = sig + type t + type key + type subrange_state + + val create : key -> subrange_state -> t +end + +(** The type of caller-defined information associated with ranges. *) +module type S_range_info = sig + type t + type key + type index + + val create + : L.fundecl + -> key + -> start_insn:L.instruction + -> (index * t) option +end + +(** This module type specifies what the caller has to provide in order to + instantiate a module to compute ranges. *) +module type S_functor = sig + (** The module [Index] is used to filter and group the generated subranges. + Inclusion of a computed subrange in the result is conditional upon the + existence of an index that can be associated to it. To give a concrete + example, the keys associated to ranges might be pseudoregisters, and the + indexes variable names (c.f. [Available_ranges_vars]). Every register that + is not known to hold the value of some variable is dropped from the + result. + + As the name suggests, values of type [Index.t] also serve as indices for + accessing ranges in the result. The result may actually contain no + reference to keys (only [Subrange_info.t] may reliably contain it), and + subranges with different keys will be coalesced into a single range if all + their keys are associated to the same index. *) + module Index : Identifiable.S + + (** The module [Key] corresponds to the identifiers that define the ranges in + [Linearize] instructions. Each instruction should have two sets of keys, + [available_before] and [available_across], with accessor functions of + these names being provided to retrieve them. The notion of "availability" + is not prescribed. The availability sets are used to compute subranges + associated to each key. *) + module Key : sig + (** The type of identifiers that define ranges. *) + type t + + module Set : sig + include Set.S with type elt = t + val print : Format.formatter -> t -> unit + end + + module Map : Map.S with type key = t + + (** Print a representation (typically sexp) of the given key to the given + formatter. *) + val print : Format.formatter -> t -> unit + + (** In some situations, for performance reasons, an "available" set may only + contain a subset of all keys that need to be tracked. For example, when + using a notion of availability that describes which lexical block a + given instruction lies in, using a standard notion of nested lexical + blocks, the innermost lexical block uniquely determines the chain of its + parents. (This is exploited in [Lexical_block_ranges].) The + [all_parents] function must return, given an "available" [key], all + those other keys that are also available and uniquely determined by + [key]. *) + val all_parents : t -> t list + end + + (** The module [Range_info] is used to store additional information on a range + that is associated to a range at its creation and can be retrieved from + the result. The association between keys and indices is also done here: + [Range_info.create] serves both as a map between keys and indices; and + also as the creator of the [Range_info.t] structure. When several + subranges are contained in a single range, the associated [Range_info.t] + will correspond to the first closed subrange. *) + module Range_info : S_range_info + with type key := Key.t + with type index := Index.t + + (** The module [Subrange_state] describes information that needs to be + propagated and passed to [Subrange_info.create]. The state that will be + used for subrange creation is the state at the end of the subrange, not at + the beginning. *) + module Subrange_state : S_subrange_state + + (** The module [Subrange_info] has a similar purpose to [Range_info], but for + subranges. Its distinguishing property is that it can store information + about its context using the additional [subrange_state] parameter of its + [create] function. *) + module Subrange_info : S_subrange_info + with type key := Key.t + with type subrange_state := Subrange_state.t + + (** How to retrieve from an instruction those keys that are available + immediately before the instruction starts executing. *) + val available_before : L.instruction -> Key.Set.t + + (** How to retrieve from an instruction those keys that are available + between the points at which the instruction reads its arguments and + writes its results. *) + val available_across : L.instruction -> Key.Set.t + + (** This [must_restart_ranges_upon_any_change] boolean exists because some + consumers of the range information may require that two subranges are + disjoint rather than including one in another. When this function returns + [true], whenever a subrange is opened or closed, all other overlapping + subranges will be split in two at the same point. *) + val must_restart_ranges_upon_any_change : unit -> bool +end + +(** This module type is the result type of the [Compute_ranges.Make] functor. + + The _ranges_ being computed are composed of contiguous _subranges_ delimited + by two labels (of type [Linearize.label]). These labels will be added by + this pass to the code being inspected, which is why the [create] function in + the result of the functor returns not only the ranges but also the updated + function with the labels added. The [start_pos_offset] and [end_pos_offset] + components of the subranges are there to allow a distinction between ranges + starting (or ending) right at the start of the corresponding instruction + (offset of zero), and ranges starting or ending one byte after the actual + instruction (offset of one). *) +module type S = sig + (** Corresponds to [Index] in the [S_functor] module type. *) + module Index : Identifiable.S + + (** Corresponds to [Key] in the [S_functor] module type. *) + module Key : sig + type t + module Set : Set.S with type elt = t + module Map : Map.S with type key = t + end + + (** Corresponds to [Subrange_state] in the [S_functor] module type. *) + module Subrange_state : S_subrange_state + + (** Corresponds to [Subrange_info] in the [S_functor] module type. *) + module Subrange_info : S_subrange_info + with type key := Key.t + with type subrange_state := Subrange_state.t + + (** Corresponds to [Range_info] in the [S_functor] module type. *) + module Range_info : S_range_info + with type key := Key.t + with type index := Index.t + + module Subrange : sig + (** The type of subranges. Each subrange is a contiguous region of + code delimited by labels. *) + type t + + (** The caller's information about the subrange. *) + val info : t -> Subrange_info.t + + (** The label at the start of the range. *) + val start_pos : t -> Linearize.label + + (** How many bytes from the label at [start_pos] the range actually + commences. If this value is zero, then the first byte of the range + has the address of the label given by [start_pos]. *) + val start_pos_offset : t -> int + + (** The label at the end of the range. *) + val end_pos : t -> Linearize.label + + (** Like [start_pos_offset], but analogously for the end of the range. (The + sense is not inverted; a positive [end_pos_offset] means the range ends + at an address higher than the address of the [end_pos], just like a + positive [start_pos_offset] means the range starts at an address higher + than the [start_pos]. *) + val end_pos_offset : t -> int + end + + module Range : sig + (** The type of ranges. Each range is a list of subranges, so a + possibly-discontiguous region of code. *) + type t + + (** The caller's information about the range. *) + val info : t -> Range_info.t + + (** Estimate the pair of ([start_pos], [start_pos_offset]) (c.f. [Subrange], + above) found amongst the given ranges that yields the lowest machine + address. The assumption is made that no [start_pos_offset] or + [end_pos_offset] will cause the corresponding extremity of a range to + cross an extremity of any other range. (This should be satisfied in + typical uses because the offsets are typically zero or one.) If there + are no ranges supplied then [None] is returned. *) + val estimate_lowest_address : t -> (Linearize.label * int) option + + (** Fold over all subranges within the given range. *) + val fold + : t + -> init:'a + -> f:('a -> Subrange.t -> 'a) + -> 'a + end + + (** The type holding information on computed ranges. *) + type t + + (** A value of type [t] that holds no range information. *) + val empty : t + + (** Compute ranges for the code in the given linearized function + declaration, returning the ranges as a value of type [t] and the + rewritten code that must go forward for emission. *) + val create : Linearize.fundecl -> t * Linearize.fundecl + + (** Iterate through ranges. Each range is associated with an index. *) + val iter : t -> f:(Index.t -> Range.t -> unit) -> unit + + (** Like [iter], but a fold. *) + val fold : t -> init:'a -> f:('a -> Index.t -> Range.t -> 'a) -> 'a + + (** Find the range for the given index, or raise an exception. *) + val find : t -> Index.t -> Range.t + + (** All indexes for which the given value of type [t] contains ranges. *) + val all_indexes : t -> Index.Set.t + + (** An internal function used by [Coalesce_labels]. + The [env] should come from [Coalesce_labels.fundecl]. *) + val rewrite_labels_and_remove_empty_subranges_and_ranges + : t + -> env:int Numbers.Int.Map.t + -> t +end diff --git a/asmcomp/export_info.ml b/asmcomp/export_info.ml deleted file mode 100644 index 22dbb6c5..00000000 --- a/asmcomp/export_info.ml +++ /dev/null @@ -1,555 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -module A = Simple_value_approx - -type value_string_contents = - | Contents of string - | Unknown_or_mutable - -type value_string = { - contents : value_string_contents; - size : int; -} - -type value_float_array_contents = - | Contents of float option array - | Unknown_or_mutable - -type value_float_array = { - contents : value_float_array_contents; - size : int; -} - -type descr = - | Value_block of Tag.t * approx array - | Value_mutable_block of Tag.t * int - | Value_int of int - | Value_char of char - | Value_constptr of int - | Value_float of float - | Value_float_array of value_float_array - | Value_boxed_int : 'a A.boxed_int * 'a -> descr - | Value_string of value_string - | Value_closure of value_closure - | Value_set_of_closures of value_set_of_closures - | Value_unknown_descr - -and value_closure = { - closure_id : Closure_id.t; - set_of_closures : value_set_of_closures; -} - -and value_set_of_closures = { - set_of_closures_id : Set_of_closures_id.t; - bound_vars : approx Var_within_closure.Map.t; - free_vars : Flambda.specialised_to Variable.Map.t; - results : approx Closure_id.Map.t; - aliased_symbol : Symbol.t option; -} - -and approx = - | Value_unknown - | Value_id of Export_id.t - | Value_symbol of Symbol.t - -let equal_approx (a1:approx) (a2:approx) = - match a1, a2 with - | Value_unknown, Value_unknown -> - true - | Value_id id1, Value_id id2 -> - Export_id.equal id1 id2 - | Value_symbol s1, Value_symbol s2 -> - Symbol.equal s1 s2 - | (Value_unknown | Value_symbol _ | Value_id _), - (Value_unknown | Value_symbol _ | Value_id _) -> - false - -let equal_array eq a1 a2 = - Array.length a1 = Array.length a2 && - try - Array.iteri (fun i v1 -> if not (eq a2.(i) v1) then raise Exit) a1; - true - with Exit -> false - -let equal_option eq o1 o2 = - match o1, o2 with - | None, None -> true - | Some v1, Some v2 -> eq v1 v2 - | Some _, None | None, Some _ -> false - -let equal_set_of_closures (s1:value_set_of_closures) - (s2:value_set_of_closures) = - Set_of_closures_id.equal s1.set_of_closures_id s2.set_of_closures_id && - Var_within_closure.Map.equal equal_approx s1.bound_vars s2.bound_vars && - Closure_id.Map.equal equal_approx s1.results s2.results && - equal_option Symbol.equal s1.aliased_symbol s2.aliased_symbol - -let equal_descr (d1:descr) (d2:descr) : bool = - match d1, d2 with - | Value_unknown_descr, Value_unknown_descr -> - true - | Value_block (t1, f1), Value_block (t2, f2) -> - Tag.equal t1 t2 && equal_array equal_approx f1 f2 - | Value_mutable_block (t1, s1), Value_mutable_block (t2, s2) -> - Tag.equal t1 t2 && - s1 = s2 - | Value_int i1, Value_int i2 -> - i1 = i2 - | Value_char c1, Value_char c2 -> - c1 = c2 - | Value_constptr i1, Value_constptr i2 -> - i1 = i2 - | Value_float f1, Value_float f2 -> - f1 = f2 - | Value_float_array s1, Value_float_array s2 -> - s1 = s2 - | Value_boxed_int (t1, v1), Value_boxed_int (t2, v2) -> - A.equal_boxed_int t1 v1 t2 v2 - | Value_string s1, Value_string s2 -> - s1 = s2 - | Value_closure c1, Value_closure c2 -> - Closure_id.equal c1.closure_id c2.closure_id && - equal_set_of_closures c1.set_of_closures c2.set_of_closures - | Value_set_of_closures s1, Value_set_of_closures s2 -> - equal_set_of_closures s1 s2 - | ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _ - | Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _ - | Value_boxed_int _ | Value_string _ | Value_closure _ - | Value_set_of_closures _ - | Value_unknown_descr ), - ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _ - | Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _ - | Value_boxed_int _ | Value_string _ | Value_closure _ - | Value_set_of_closures _ - | Value_unknown_descr ) -> - false - -type t = { - sets_of_closures : A.function_declarations Set_of_closures_id.Map.t; - values : descr Export_id.Map.t Compilation_unit.Map.t; - symbol_id : Export_id.t Symbol.Map.t; - offset_fun : int Closure_id.Map.t; - offset_fv : int Var_within_closure.Map.t; - constant_closures : Closure_id.Set.t; - invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; - recursive : Variable.Set.t Set_of_closures_id.Map.t; -} - -type transient = { - sets_of_closures : A.function_declarations Set_of_closures_id.Map.t; - values : descr Export_id.Map.t Compilation_unit.Map.t; - symbol_id : Export_id.t Symbol.Map.t; - invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; - recursive : Variable.Set.t Set_of_closures_id.Map.t; - relevant_local_closure_ids : Closure_id.Set.t; - relevant_imported_closure_ids : Closure_id.Set.t; - relevant_local_vars_within_closure : Var_within_closure.Set.t; - relevant_imported_vars_within_closure : Var_within_closure.Set.t; -} - -let empty : t = { - sets_of_closures = Set_of_closures_id.Map.empty; - values = Compilation_unit.Map.empty; - symbol_id = Symbol.Map.empty; - offset_fun = Closure_id.Map.empty; - offset_fv = Var_within_closure.Map.empty; - constant_closures = Closure_id.Set.empty; - invariant_params = Set_of_closures_id.Map.empty; - recursive = Set_of_closures_id.Map.empty; -} - -let opaque_transient ~compilation_unit ~root_symbol : transient = - let export_id = Export_id.create compilation_unit in - let values = - let map = Export_id.Map.singleton export_id Value_unknown_descr in - Compilation_unit.Map.singleton compilation_unit map - in - let symbol_id = Symbol.Map.singleton root_symbol export_id in - { sets_of_closures = Set_of_closures_id.Map.empty; - values; - symbol_id; - invariant_params = Set_of_closures_id.Map.empty; - recursive = Set_of_closures_id.Map.empty; - relevant_local_closure_ids = Closure_id.Set.empty; - relevant_imported_closure_ids = Closure_id.Set.empty; - relevant_local_vars_within_closure = Var_within_closure.Set.empty; - relevant_imported_vars_within_closure = Var_within_closure.Set.empty; - } - -let create ~sets_of_closures ~values ~symbol_id - ~offset_fun ~offset_fv ~constant_closures - ~invariant_params ~recursive = - { sets_of_closures; - values; - symbol_id; - offset_fun; - offset_fv; - constant_closures; - invariant_params; - recursive; - } - -let create_transient - ~sets_of_closures ~values ~symbol_id ~invariant_params ~recursive - ~relevant_local_closure_ids ~relevant_imported_closure_ids - ~relevant_local_vars_within_closure - ~relevant_imported_vars_within_closure = - { sets_of_closures; - values; - symbol_id; - invariant_params; - recursive; - relevant_local_closure_ids; - relevant_imported_closure_ids; - relevant_local_vars_within_closure; - relevant_imported_vars_within_closure; - } - -let t_of_transient transient - ~program:_ - ~local_offset_fun ~local_offset_fv - ~imported_offset_fun ~imported_offset_fv - ~constant_closures = - let offset_fun = - let fold_map set = - Closure_id.Map.fold (fun key value unchanged -> - if Closure_id.Set.mem key set then - Closure_id.Map.add key value unchanged - else - unchanged) - in - Closure_id.Map.empty - |> fold_map transient.relevant_local_closure_ids local_offset_fun - |> fold_map transient.relevant_imported_closure_ids imported_offset_fun - in - let offset_fv = - let fold_map set = - Var_within_closure.Map.fold (fun key value unchanged -> - if Var_within_closure.Set.mem key set then - Var_within_closure.Map.add key value unchanged - else - unchanged) - in - Var_within_closure.Map.empty - |> fold_map transient.relevant_local_vars_within_closure local_offset_fv - |> fold_map transient.relevant_imported_vars_within_closure - imported_offset_fv - in - { sets_of_closures = transient.sets_of_closures; - values = transient.values; - symbol_id = transient.symbol_id; - invariant_params = transient.invariant_params; - recursive = transient.recursive; - offset_fun; - offset_fv; - constant_closures; - } - -let merge (t1 : t) (t2 : t) : t = - let eidmap_disjoint_union ?eq map1 map2 = - Compilation_unit.Map.merge (fun _id map1 map2 -> - match map1, map2 with - | None, None -> None - | None, Some map - | Some map, None -> Some map - | Some map1, Some map2 -> - Some (Export_id.Map.disjoint_union ?eq map1 map2)) - map1 map2 - in - let int_eq (i : int) j = i = j in - { values = eidmap_disjoint_union ~eq:equal_descr t1.values t2.values; - sets_of_closures = - Set_of_closures_id.Map.disjoint_union t1.sets_of_closures - t2.sets_of_closures; - symbol_id = - Symbol.Map.disjoint_union ~print:Export_id.print t1.symbol_id - t2.symbol_id; - offset_fun = Closure_id.Map.disjoint_union - ~eq:int_eq t1.offset_fun t2.offset_fun; - offset_fv = Var_within_closure.Map.disjoint_union - ~eq:int_eq t1.offset_fv t2.offset_fv; - constant_closures = - Closure_id.Set.union t1.constant_closures t2.constant_closures; - invariant_params = - Set_of_closures_id.Map.disjoint_union - ~print:(Variable.Map.print Variable.Set.print) - ~eq:(Variable.Map.equal Variable.Set.equal) - t1.invariant_params t2.invariant_params; - recursive = - Set_of_closures_id.Map.disjoint_union - ~print:Variable.Set.print - ~eq:Variable.Set.equal - t1.recursive t2.recursive; - } - -let find_value eid map = - let unit_map = - Compilation_unit.Map.find (Export_id.get_compilation_unit eid) map - in - Export_id.Map.find eid unit_map - -let find_description (t : t) eid = - find_value eid t.values - -let nest_eid_map map = - let add_map eid v map = - let unit = Export_id.get_compilation_unit eid in - let m = - try Compilation_unit.Map.find unit map - with Not_found -> Export_id.Map.empty - in - Compilation_unit.Map.add unit (Export_id.Map.add eid v m) map - in - Export_id.Map.fold add_map map Compilation_unit.Map.empty - -let print_raw_approx ppf approx = - let fprintf = Format.fprintf in - match approx with - | Value_unknown -> fprintf ppf "(Unknown)" - | Value_id export_id -> fprintf ppf "(Id %a)" Export_id.print export_id - | Value_symbol symbol -> fprintf ppf "(Symbol %a)" Symbol.print symbol - -let print_value_set_of_closures ppf (t : value_set_of_closures) = - let print_bound_vars ppf bound_vars = - Format.fprintf ppf "(%a)" - (Var_within_closure.Map.print print_raw_approx) - bound_vars - in - let print_free_vars ppf free_vars = - Format.fprintf ppf "(%a)" - (Variable.Map.print Flambda.print_specialised_to) - free_vars - in - let print_results ppf results = - Format.fprintf ppf "(%a)" (Closure_id.Map.print print_raw_approx) results - in - let print_aliased_symbol ppf aliased_symbol = - match aliased_symbol with - | None -> Format.fprintf ppf "" - | Some symbol -> Format.fprintf ppf "(%a)" Symbol.print symbol - in - Format.fprintf ppf - "((set_of_closures_id %a) \ - (bound_vars %a) \ - (free_vars %a) \ - (results %a) \ - (aliased_symbol %a))" - Set_of_closures_id.print t.set_of_closures_id - print_bound_vars t.bound_vars - print_free_vars t.free_vars - print_results t.results - print_aliased_symbol t.aliased_symbol - -let print_value_closure ppf (t : value_closure) = - Format.fprintf ppf "((closure_id %a) (set_of_closures %a))" - Closure_id.print t.closure_id - print_value_set_of_closures t.set_of_closures - -let print_value_float_array_contents - ppf (value : value_float_array_contents) = - match value with - | Unknown_or_mutable -> Format.fprintf ppf "(Unknown_or_mutable)" - | Contents _ -> Format.fprintf ppf "(Contents ...)" - -let print_value_float_array ppf (value : value_float_array) = - Format.fprintf ppf "((size %d) (contents %a))" - value.size - print_value_float_array_contents value.contents - -let print_value_string_contents ppf (value : value_string_contents) = - match value with - | Unknown_or_mutable -> Format.fprintf ppf "(Unknown_or_mutable)" - | Contents _ -> Format.fprintf ppf "(Contents ...)" - -let print_value_string ppf (value : value_string) = - Format.fprintf ppf "((size %d) (contents %a))" - value.size - print_value_string_contents value.contents - -let print_raw_descr ppf descr = - let fprintf = Format.fprintf in - let print_approx_array ppf arr = - Array.iter (fun approx -> fprintf ppf "%a " print_raw_approx approx) arr - in - match descr with - | Value_block (tag, approx_array) -> - fprintf ppf "(Value_block (%a %a))" - Tag.print tag - print_approx_array approx_array - | Value_mutable_block (tag, i) -> - fprintf ppf "(Value_mutable-block (%a %d))" Tag.print tag i - | Value_int i -> fprintf ppf "(Value_int %d)" i - | Value_char c -> fprintf ppf "(Value_char %c)" c - | Value_constptr p -> fprintf ppf "(Value_constptr %d)" p - | Value_float f -> fprintf ppf "(Value_float %.3f)" f - | Value_float_array value_float_array -> - fprintf ppf "(Value_float_array %a)" - print_value_float_array value_float_array - | Value_boxed_int _ -> - fprintf ppf "(Value_Boxed_int)" - | Value_string value_string -> - fprintf ppf "(Value_string %a)" print_value_string value_string - | Value_closure value_closure -> - fprintf ppf "(Value_closure %a)" - print_value_closure value_closure - | Value_set_of_closures value_set_of_closures -> - fprintf ppf "(Value_set_of_closures %a)" - print_value_set_of_closures value_set_of_closures - | Value_unknown_descr -> fprintf ppf "(Value_unknown_descr)" - -let print_approx_components ppf ~symbol_id ~values - (root_symbols : Symbol.t list) = - let fprintf = Format.fprintf in - let printed = ref Export_id.Set.empty in - let recorded_symbol = ref Symbol.Set.empty in - let symbols_to_print = Queue.create () in - let printed_set_of_closures = ref Set_of_closures_id.Set.empty in - let rec print_approx ppf (approx : approx) = - match approx with - | Value_unknown -> fprintf ppf "?" - | Value_id id -> - if Export_id.Set.mem id !printed then - fprintf ppf "(%a: _)" Export_id.print id - else begin - try - let descr = find_value id values in - printed := Export_id.Set.add id !printed; - fprintf ppf "@[(%a:@ %a)@]" - Export_id.print id print_descr descr - with Not_found -> - fprintf ppf "(%a: Not available)" Export_id.print id - end - | Value_symbol sym -> - if not (Symbol.Set.mem sym !recorded_symbol) then begin - recorded_symbol := Symbol.Set.add sym !recorded_symbol; - Queue.push sym symbols_to_print; - end; - Symbol.print ppf sym - and print_descr ppf (descr : descr) = - match descr with - | Value_int i -> Format.pp_print_int ppf i - | Value_char c -> fprintf ppf "%c" c - | Value_constptr i -> fprintf ppf "%ip" i - | Value_block (tag, fields) -> - fprintf ppf "[%a:%a]" Tag.print tag print_fields fields - | Value_mutable_block (tag, size) -> - fprintf ppf "[mutable %a:%i]" Tag.print tag size - | Value_closure {closure_id; set_of_closures} -> - fprintf ppf "(closure %a, %a)" Closure_id.print closure_id - print_set_of_closures set_of_closures - | Value_set_of_closures set_of_closures -> - fprintf ppf "(set_of_closures %a)" print_set_of_closures set_of_closures - | Value_string { contents; size } -> - begin match contents with - | Unknown_or_mutable -> Format.fprintf ppf "string %i" size - | Contents s -> - let s = - if size > 10 - then String.sub s 0 8 ^ "..." - else s - in - Format.fprintf ppf "string %i %S" size s - end - | Value_float f -> Format.pp_print_float ppf f - | Value_float_array float_array -> - Format.fprintf ppf "float_array%s %i" - (match float_array.contents with - | Unknown_or_mutable -> "" - | Contents _ -> "_imm") - float_array.size - | Value_boxed_int (t, i) -> - begin match t with - | A.Int32 -> Format.fprintf ppf "%li" i - | A.Int64 -> Format.fprintf ppf "%Li" i - | A.Nativeint -> Format.fprintf ppf "%ni" i - end - | Value_unknown_descr -> Format.fprintf ppf "?" - and print_fields ppf fields = - Array.iter (fun approx -> fprintf ppf "%a@ " print_approx approx) fields - and print_set_of_closures ppf - { set_of_closures_id; bound_vars; aliased_symbol; results } = - if Set_of_closures_id.Set.mem set_of_closures_id !printed_set_of_closures - then fprintf ppf "%a" Set_of_closures_id.print set_of_closures_id - else begin - printed_set_of_closures := - Set_of_closures_id.Set.add set_of_closures_id !printed_set_of_closures; - let print_alias ppf = function - | None -> () - | Some symbol -> - Format.fprintf ppf "@ (alias: %a)" Symbol.print symbol - in - fprintf ppf "{%a: %a%a => %a}" - Set_of_closures_id.print set_of_closures_id - print_binding bound_vars - print_alias aliased_symbol - (Closure_id.Map.print print_approx) results - end - and print_binding ppf bound_vars = - Var_within_closure.Map.iter (fun clos_id approx -> - fprintf ppf "%a -> %a,@ " - Var_within_closure.print clos_id - print_approx approx) - bound_vars - in - let rec print_recorded_symbols () = - if not (Queue.is_empty symbols_to_print) then begin - let sym = Queue.pop symbols_to_print in - begin match Symbol.Map.find sym symbol_id with - | exception Not_found -> () - | id -> - fprintf ppf "@[%a:@ %a@];@ " - Symbol.print sym - print_approx (Value_id id) - end; - print_recorded_symbols (); - end - in - List.iter (fun s -> Queue.push s symbols_to_print) root_symbols; - fprintf ppf "@[Globals:@ "; - fprintf ppf "@]@ @[Symbols:@ "; - print_recorded_symbols (); - fprintf ppf "@]" - -let print_approx ppf ((t : t), symbols) = - let symbol_id = t.symbol_id in - let values = t.values in - print_approx_components ppf ~symbol_id ~values symbols - -let print_offsets ppf (t : t) = - Format.fprintf ppf "@[offset_fun:@ "; - Closure_id.Map.iter (fun cid off -> - Format.fprintf ppf "%a -> %i@ " - Closure_id.print cid off) t.offset_fun; - Format.fprintf ppf "@]@ @[offset_fv:@ "; - Var_within_closure.Map.iter (fun vid off -> - Format.fprintf ppf "%a -> %i@ " - Var_within_closure.print vid off) t.offset_fv; - Format.fprintf ppf "@]@ " - -let print_functions ppf (t : t) = - Set_of_closures_id.Map.print - A.print_function_declarations ppf - t.sets_of_closures - -let print_all ppf ((t, root_symbols) : t * Symbol.t list) = - let fprintf = Format.fprintf in - fprintf ppf "approxs@ %a@.@." - print_approx (t, root_symbols); - fprintf ppf "functions@ %a@.@." - print_functions t diff --git a/asmcomp/export_info.mli b/asmcomp/export_info.mli deleted file mode 100644 index f93698be..00000000 --- a/asmcomp/export_info.mli +++ /dev/null @@ -1,195 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Exported information (that is to say, information written into a .cmx - file) about a compilation unit. *) - -module A = Simple_value_approx - -type value_string_contents = - | Contents of string - | Unknown_or_mutable - -type value_string = { - contents : value_string_contents; - size : int; -} - -type value_float_array_contents = - | Contents of float option array - | Unknown_or_mutable - -type value_float_array = { - contents : value_float_array_contents; - size : int; -} - -type descr = - | Value_block of Tag.t * approx array - | Value_mutable_block of Tag.t * int - | Value_int of int - | Value_char of char - | Value_constptr of int - | Value_float of float - | Value_float_array of value_float_array - | Value_boxed_int : 'a A.boxed_int * 'a -> descr - | Value_string of value_string - | Value_closure of value_closure - | Value_set_of_closures of value_set_of_closures - | Value_unknown_descr - -and value_closure = { - closure_id : Closure_id.t; - set_of_closures : value_set_of_closures; -} - -and value_set_of_closures = { - set_of_closures_id : Set_of_closures_id.t; - bound_vars : approx Var_within_closure.Map.t; - free_vars : Flambda.specialised_to Variable.Map.t; - results : approx Closure_id.Map.t; - aliased_symbol : Symbol.t option; -} - -(* CR-soon mshinwell: Fix the export information so we can correctly - propagate "unresolved due to..." in the manner of [Simple_value_approx]. - Unfortunately this seems to be complicated by the fact that, during - [Import_approx], resolution can fail not only due to missing symbols but - also due to missing export IDs. The argument type of - [Simple_value_approx.t] may need updating to reflect this (make the - symbol optional? It's only for debugging anyway.) *) -and approx = - | Value_unknown - | Value_id of Export_id.t - | Value_symbol of Symbol.t - -(** A structure that describes what a single compilation unit exports. *) -type t = private { - sets_of_closures : A.function_declarations Set_of_closures_id.Map.t; - (** Code of exported functions indexed by set of closures IDs. *) - values : descr Export_id.Map.t Compilation_unit.Map.t; - (** Structure of exported values. *) - symbol_id : Export_id.t Symbol.Map.t; - (** Associates symbols and values. *) - offset_fun : int Closure_id.Map.t; - (** Positions of function pointers in their closures. *) - offset_fv : int Var_within_closure.Map.t; - (** Positions of value pointers in their closures. *) - constant_closures : Closure_id.Set.t; - (* CR-soon mshinwell for pchambart: Add comment *) - invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; - (* Function parameters known to be invariant (see [Invariant_params]) - indexed by set of closures ID. *) - recursive : Variable.Set.t Set_of_closures_id.Map.t; -} - -type transient = private { - sets_of_closures : A.function_declarations Set_of_closures_id.Map.t; - values : descr Export_id.Map.t Compilation_unit.Map.t; - symbol_id : Export_id.t Symbol.Map.t; - invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; - recursive : Variable.Set.t Set_of_closures_id.Map.t; - relevant_local_closure_ids : Closure_id.Set.t; - relevant_imported_closure_ids : Closure_id.Set.t; - relevant_local_vars_within_closure : Var_within_closure.Set.t; - relevant_imported_vars_within_closure : Var_within_closure.Set.t; -} - -(** Export information for a compilation unit that exports nothing. *) -val empty : t - -val opaque_transient - : compilation_unit:Compilation_unit.t - -> root_symbol:Symbol.t - -> transient - -(** Create a new export information structure. *) -val create - : sets_of_closures:(A.function_declarations Set_of_closures_id.Map.t) - -> values:descr Export_id.Map.t Compilation_unit.Map.t - -> symbol_id:Export_id.t Symbol.Map.t - -> offset_fun:int Closure_id.Map.t - -> offset_fv:int Var_within_closure.Map.t - -> constant_closures:Closure_id.Set.t - -> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t - -> recursive:Variable.Set.t Set_of_closures_id.Map.t - -> t - -val create_transient - : sets_of_closures:(A.function_declarations Set_of_closures_id.Map.t) - -> values:descr Export_id.Map.t Compilation_unit.Map.t - -> symbol_id:Export_id.t Symbol.Map.t - -> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t - -> recursive:Variable.Set.t Set_of_closures_id.Map.t - -> relevant_local_closure_ids: Closure_id.Set.t - -> relevant_imported_closure_ids : Closure_id.Set.t - -> relevant_local_vars_within_closure : Var_within_closure.Set.t - -> relevant_imported_vars_within_closure : Var_within_closure.Set.t - -> transient - -(* CR-someday pchambart: Should we separate [t] in 2 types: one created by the - current [create] function, returned by [Build_export_info]. And - another built using t and offset_informations returned by - [flambda_to_clambda] ? - mshinwell: I think we should, but after we've done the first release. -*) -(** Record information about the layout of closures and which sets of - closures are constant. These are all worked out during the - [Flambda_to_clambda] pass. *) -val t_of_transient - : transient - -> program: Flambda.program - -> local_offset_fun:int Closure_id.Map.t - -> local_offset_fv:int Var_within_closure.Map.t - -> imported_offset_fun:int Closure_id.Map.t - -> imported_offset_fv:int Var_within_closure.Map.t - -> constant_closures:Closure_id.Set.t - -> t - -(** Union of export information. Verifies that there are no identifier - clashes. *) -val merge : t -> t -> t - -(** Look up the description of an exported value given its export ID. *) -val find_description - : t - -> Export_id.t - -> descr - -(** Partition a mapping from export IDs by compilation unit. *) -val nest_eid_map - : 'a Export_id.Map.t - -> 'a Export_id.Map.t Compilation_unit.Map.t - -(**/**) -(* Debug printing functions. *) -val print_approx_components - : Format.formatter - -> symbol_id: Export_id.t Symbol.Map.t - -> values: descr Export_id.Map.t Compilation_unit.Map.t - -> Symbol.t list - -> unit -val print_approx : Format.formatter -> t * Symbol.t list -> unit -val print_functions : Format.formatter -> t -> unit -val print_offsets : Format.formatter -> t -> unit -val print_all : Format.formatter -> t * Symbol.t list -> unit - -(** Prints approx and descr as it is, without recursively looking up - [Export_id.t] *) -val print_raw_approx : Format.formatter -> approx -> unit -val print_raw_descr : Format.formatter -> descr -> unit diff --git a/asmcomp/export_info_for_pack.ml b/asmcomp/export_info_for_pack.ml deleted file mode 100644 index 42a81553..00000000 --- a/asmcomp/export_info_for_pack.ml +++ /dev/null @@ -1,231 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -module A = Simple_value_approx - -let rename_id_state = Export_id.Tbl.create 100 -let rename_set_of_closures_id_state = Set_of_closures_id.Tbl.create 10 -let imported_function_declarations_table = - (Set_of_closures_id.Tbl.create 10 - : A.function_declarations Set_of_closures_id.Tbl.t) - -(* Rename export identifiers' compilation units to denote that they now - live within a pack. *) -let import_eid_for_pack units pack id = - try Export_id.Tbl.find rename_id_state id - with Not_found -> - let unit_id = Export_id.get_compilation_unit id in - let id' = - if Compilation_unit.Set.mem unit_id units - then Export_id.create ?name:(Export_id.name id) pack - else id - in - Export_id.Tbl.add rename_id_state id id'; - id' - -(* Similar to [import_eid_for_pack], but for symbols. *) -let import_symbol_for_pack units pack symbol = - let compilation_unit = Symbol.compilation_unit symbol in - if Compilation_unit.Set.mem compilation_unit units - then Symbol.import_for_pack ~pack symbol - else symbol - -let import_approx_for_pack units pack (approx : Export_info.approx) - : Export_info.approx = - match approx with - | Value_symbol sym -> Value_symbol (import_symbol_for_pack units pack sym) - | Value_id eid -> Value_id (import_eid_for_pack units pack eid) - | Value_unknown -> Value_unknown - -let import_set_of_closures_id_for_pack units pack - (set_of_closures_id : Set_of_closures_id.t) - : Set_of_closures_id.t = - let compilation_unit = - Set_of_closures_id.get_compilation_unit set_of_closures_id - in - if Compilation_unit.Set.mem compilation_unit units then - Set_of_closures_id.Tbl.memoize - rename_set_of_closures_id_state - (fun _ -> - Set_of_closures_id.create - ?name:(Set_of_closures_id.name set_of_closures_id) - pack) - set_of_closures_id - else set_of_closures_id - -let import_set_of_closures_origin_for_pack units pack - (set_of_closures_origin : Set_of_closures_origin.t) - : Set_of_closures_origin.t = - Set_of_closures_origin.rename - (import_set_of_closures_id_for_pack units pack) - set_of_closures_origin - -let import_set_of_closures units pack - (set_of_closures : Export_info.value_set_of_closures) - : Export_info.value_set_of_closures = - { set_of_closures_id = - import_set_of_closures_id_for_pack units pack - set_of_closures.set_of_closures_id; - bound_vars = - Var_within_closure.Map.map (import_approx_for_pack units pack) - set_of_closures.bound_vars; - free_vars = set_of_closures.free_vars; - results = - Closure_id.Map.map (import_approx_for_pack units pack) - set_of_closures.results; - aliased_symbol = - Misc.may_map - (import_symbol_for_pack units pack) - set_of_closures.aliased_symbol; - } - -let import_descr_for_pack units pack (descr : Export_info.descr) - : Export_info.descr = - match descr with - | Value_int _ - | Value_char _ - | Value_constptr _ - | Value_string _ - | Value_float _ - | Value_float_array _ - | Export_info.Value_boxed_int _ - | Value_mutable_block _ as desc -> desc - | Value_block (tag, fields) -> - Value_block (tag, Array.map (import_approx_for_pack units pack) fields) - | Value_closure { closure_id; set_of_closures } -> - Value_closure { - closure_id; - set_of_closures = import_set_of_closures units pack set_of_closures; - } - | Value_set_of_closures set_of_closures -> - Value_set_of_closures (import_set_of_closures units pack set_of_closures) - | Value_unknown_descr -> Value_unknown_descr - -let rec import_code_for_pack units pack expr = - Flambda_iterators.map_named (function - | Symbol sym -> Symbol (import_symbol_for_pack units pack sym) - | Read_symbol_field (sym, field) -> - Read_symbol_field (import_symbol_for_pack units pack sym, field) - | Set_of_closures set_of_closures -> - let set_of_closures = - Flambda.create_set_of_closures - ~free_vars:set_of_closures.free_vars - ~specialised_args:set_of_closures.specialised_args - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - ~function_decls: - (import_function_declarations_for_pack_aux units pack - set_of_closures.function_decls) - in - Set_of_closures set_of_closures - | e -> e) - expr - -and import_function_declarations_for_pack_aux units pack - (function_decls : Flambda.function_declarations) = - let funs = - Variable.Map.map - (fun (function_decl : Flambda.function_declaration) -> - Flambda.create_function_declaration ~params:function_decl.params - ~body:(import_code_for_pack units pack function_decl.body) - ~stub:function_decl.stub ~dbg:function_decl.dbg - ~inline:function_decl.inline - ~specialise:function_decl.specialise - ~is_a_functor:function_decl.is_a_functor - ~closure_origin:function_decl.closure_origin) - function_decls.funs - in - Flambda.import_function_declarations_for_pack - (Flambda.update_function_declarations function_decls ~funs) - (import_set_of_closures_id_for_pack units pack) - (import_set_of_closures_origin_for_pack units pack) - -let import_function_declarations_for_pack_aux units pack - (function_decls : A.function_declarations) : A.function_declarations = - let funs = - Variable.Map.map - (fun (function_decl : A.function_declaration) -> - A.update_function_declaration_body function_decl - (fun body -> import_code_for_pack units pack body)) - function_decls.funs - in - A.import_function_declarations_for_pack - (A.update_function_declarations function_decls ~funs) - (import_set_of_closures_id_for_pack units pack) - (import_set_of_closures_origin_for_pack units pack) - -let import_function_declarations_approx_for_pack units pack - (function_decls: A.function_declarations) = - let original_set_of_closures_id = function_decls.set_of_closures_id in - try - Set_of_closures_id.Tbl.find imported_function_declarations_table - original_set_of_closures_id - with Not_found -> - let function_decls = - import_function_declarations_for_pack_aux units pack function_decls - in - Set_of_closures_id.Tbl.add - imported_function_declarations_table - original_set_of_closures_id - function_decls; - function_decls - -let import_eidmap_for_pack units pack f map = - Export_info.nest_eid_map - (Compilation_unit.Map.fold - (fun _ map acc -> Export_id.Map.disjoint_union map acc) - (Compilation_unit.Map.map (fun map -> - Export_id.Map.map_keys (import_eid_for_pack units pack) - (Export_id.Map.map f map)) - map) - Export_id.Map.empty) - -let import_for_pack ~pack_units ~pack (exp : Export_info.t) = - let import_sym = import_symbol_for_pack pack_units pack in - let import_descr = import_descr_for_pack pack_units pack in - let import_eid = import_eid_for_pack pack_units pack in - let import_eidmap f map = import_eidmap_for_pack pack_units pack f map in - let import_set_of_closures_id = - import_set_of_closures_id_for_pack pack_units pack - in - let import_function_declarations = - import_function_declarations_approx_for_pack pack_units pack - in - let sets_of_closures = - Set_of_closures_id.Map.map_keys import_set_of_closures_id - (Set_of_closures_id.Map.map - import_function_declarations - exp.sets_of_closures) - in - Export_info.create ~sets_of_closures - ~offset_fun:exp.offset_fun - ~offset_fv:exp.offset_fv - ~values:(import_eidmap import_descr exp.values) - ~symbol_id:(Symbol.Map.map_keys import_sym - (Symbol.Map.map import_eid exp.symbol_id)) - ~constant_closures:exp.constant_closures - ~invariant_params: - (Set_of_closures_id.Map.map_keys import_set_of_closures_id - exp.invariant_params) - ~recursive: - (Set_of_closures_id.Map.map_keys import_set_of_closures_id - exp.recursive) - -let clear_import_state () = - Set_of_closures_id.Tbl.clear imported_function_declarations_table; - Set_of_closures_id.Tbl.clear rename_set_of_closures_id_state; - Export_id.Tbl.clear rename_id_state diff --git a/asmcomp/export_info_for_pack.mli b/asmcomp/export_info_for_pack.mli deleted file mode 100644 index 2ba3a35d..00000000 --- a/asmcomp/export_info_for_pack.mli +++ /dev/null @@ -1,34 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Transformations on export information that are only used for the - building of packs. *) - -(** Transform the information from [exported] to be - suitable to be reexported as the information for a pack named [pack] - containing units [pack_units]. - It mainly changes symbols of units [pack_units] to refer to - [pack] instead. *) -val import_for_pack - : pack_units:Compilation_unit.Set.t - -> pack:Compilation_unit.t - -> Export_info.t - -> Export_info.t - -(** Drops the state after importing several units in the same pack. *) -val clear_import_state : unit -> unit diff --git a/asmcomp/flambda_to_clambda.ml b/asmcomp/flambda_to_clambda.ml deleted file mode 100644 index e1b0f446..00000000 --- a/asmcomp/flambda_to_clambda.ml +++ /dev/null @@ -1,749 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -module V = Backend_var -module VP = Backend_var.With_provenance - -type 'a for_one_or_more_units = { - fun_offset_table : int Closure_id.Map.t; - fv_offset_table : int Var_within_closure.Map.t; - constant_closures : Closure_id.Set.t; - closures: Closure_id.Set.t; -} - -type t = { - current_unit : - Set_of_closures_id.t for_one_or_more_units; - imported_units : - Simple_value_approx.function_declarations for_one_or_more_units; -} - -let get_fun_offset t closure_id = - let fun_offset_table = - if Closure_id.in_compilation_unit closure_id (Compilenv.current_unit ()) - then - t.current_unit.fun_offset_table - else - t.imported_units.fun_offset_table - in - try Closure_id.Map.find closure_id fun_offset_table - with Not_found -> - Misc.fatal_errorf "Flambda_to_clambda: missing offset for closure %a" - Closure_id.print closure_id - -let get_fv_offset t var_within_closure = - let fv_offset_table = - if Var_within_closure.in_compilation_unit var_within_closure - (Compilenv.current_unit ()) - then t.current_unit.fv_offset_table - else t.imported_units.fv_offset_table - in - try Var_within_closure.Map.find var_within_closure fv_offset_table - with Not_found -> - Misc.fatal_errorf "Flambda_to_clambda: missing offset for variable %a" - Var_within_closure.print var_within_closure - -let is_function_constant t closure_id = - if Closure_id.Set.mem closure_id t.current_unit.closures then - Closure_id.Set.mem closure_id t.current_unit.constant_closures - else if Closure_id.Set.mem closure_id t.imported_units.closures then - Closure_id.Set.mem closure_id t.imported_units.constant_closures - else - Misc.fatal_errorf "Flambda_to_clambda: missing closure %a" - Closure_id.print closure_id - -(* Instrumentation of closure and field accesses to try to catch compiler - bugs. *) - -let check_closure ulam named : Clambda.ulambda = - if not !Clflags.clambda_checks then ulam - else - let desc = - Primitive.simple ~name:"caml_check_value_is_closure" - ~arity:2 ~alloc:false - in - let str = Format.asprintf "%a" Flambda.print_named named in - let str_const = - Compilenv.new_structured_constant (Uconst_string str) ~shared:true - in - Uprim (Pccall desc, - [ulam; Clambda.Uconst (Uconst_ref (str_const, None))], - Debuginfo.none) - -let check_field ulam pos named_opt : Clambda.ulambda = - if not !Clflags.clambda_checks then ulam - else - let desc = - Primitive.simple ~name:"caml_check_field_access" - ~arity:3 ~alloc:false - in - let str = - match named_opt with - | None -> "" - | Some named -> Format.asprintf "%a" Flambda.print_named named - in - let str_const = - Compilenv.new_structured_constant (Uconst_string str) ~shared:true - in - Uprim (Pccall desc, [ulam; Clambda.Uconst (Uconst_int pos); - Clambda.Uconst (Uconst_ref (str_const, None))], - Debuginfo.none) - -module Env : sig - type t - - val empty : t - - val add_subst : t -> Variable.t -> Clambda.ulambda -> t - val find_subst_exn : t -> Variable.t -> Clambda.ulambda - - val add_fresh_ident : t -> Variable.t -> V.t * t - val ident_for_var_exn : t -> Variable.t -> V.t - - val add_fresh_mutable_ident : t -> Mutable_variable.t -> V.t * t - val ident_for_mutable_var_exn : t -> Mutable_variable.t -> V.t - - val add_allocated_const : t -> Symbol.t -> Allocated_const.t -> t - val allocated_const_for_symbol : t -> Symbol.t -> Allocated_const.t option - - val keep_only_symbols : t -> t -end = struct - type t = - { subst : Clambda.ulambda Variable.Map.t; - var : V.t Variable.Map.t; - mutable_var : V.t Mutable_variable.Map.t; - toplevel : bool; - allocated_constant_for_symbol : Allocated_const.t Symbol.Map.t; - } - - let empty = - { subst = Variable.Map.empty; - var = Variable.Map.empty; - mutable_var = Mutable_variable.Map.empty; - toplevel = false; - allocated_constant_for_symbol = Symbol.Map.empty; - } - - let add_subst t id subst = - { t with subst = Variable.Map.add id subst t.subst } - - let find_subst_exn t id = Variable.Map.find id t.subst - - let ident_for_var_exn t id = Variable.Map.find id t.var - - let add_fresh_ident t var = - let id = V.create_local (Variable.name var) in - id, { t with var = Variable.Map.add var id t.var } - - let ident_for_mutable_var_exn t mut_var = - Mutable_variable.Map.find mut_var t.mutable_var - - let add_fresh_mutable_ident t mut_var = - let id = V.create_local (Mutable_variable.name mut_var) in - let mutable_var = Mutable_variable.Map.add mut_var id t.mutable_var in - id, { t with mutable_var; } - - let add_allocated_const t sym cons = - { t with - allocated_constant_for_symbol = - Symbol.Map.add sym cons t.allocated_constant_for_symbol; - } - - let allocated_const_for_symbol t sym = - try - Some (Symbol.Map.find sym t.allocated_constant_for_symbol) - with Not_found -> None - - let keep_only_symbols t = - { empty with - allocated_constant_for_symbol = t.allocated_constant_for_symbol; - } -end - -let subst_var env var : Clambda.ulambda = - try Env.find_subst_exn env var - with Not_found -> - try Uvar (Env.ident_for_var_exn env var) - with Not_found -> - Misc.fatal_errorf "Flambda_to_clambda: unbound variable %a@." - Variable.print var - -let subst_vars env vars = List.map (subst_var env) vars - -let build_uoffset ulam offset : Clambda.ulambda = - if offset = 0 then ulam - else Uoffset (ulam, offset) - -let to_clambda_allocated_constant (const : Allocated_const.t) - : Clambda.ustructured_constant = - match const with - | Float f -> Uconst_float f - | Int32 i -> Uconst_int32 i - | Int64 i -> Uconst_int64 i - | Nativeint i -> Uconst_nativeint i - | Immutable_string s | String s -> Uconst_string s - | Immutable_float_array a | Float_array a -> Uconst_float_array a - -let to_uconst_symbol env symbol : Clambda.ustructured_constant option = - match Env.allocated_const_for_symbol env symbol with - | Some ((Float _ | Int32 _ | Int64 _ | Nativeint _) as const) -> - Some (to_clambda_allocated_constant const) - | None (* CR-soon mshinwell: Try to make this an error. *) - | Some _ -> None - -let to_clambda_symbol' env sym : Clambda.uconstant = - let lbl = Linkage_name.to_string (Symbol.label sym) in - Uconst_ref (lbl, to_uconst_symbol env sym) - -let to_clambda_symbol env sym : Clambda.ulambda = - Uconst (to_clambda_symbol' env sym) - -let to_clambda_const env (const : Flambda.constant_defining_value_block_field) - : Clambda.uconstant = - match const with - | Symbol symbol -> to_clambda_symbol' env symbol - | Const (Int i) -> Uconst_int i - | Const (Char c) -> Uconst_int (Char.code c) - | Const (Const_pointer i) -> Uconst_ptr i - -let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda = - match flam with - | Var var -> subst_var env var - | Let { var; defining_expr; body; _ } -> - (* TODO: synthesize proper value_kind *) - let id, env_body = Env.add_fresh_ident env var in - Ulet (Immutable, Pgenval, VP.create id, - to_clambda_named t env var defining_expr, - to_clambda t env_body body) - | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> - let id, env_body = Env.add_fresh_mutable_ident env mut_var in - let def = subst_var env var in - Ulet (Mutable, contents_kind, VP.create id, def, to_clambda t env_body body) - | Let_rec (defs, body) -> - let env, defs = - List.fold_right (fun (var, def) (env, defs) -> - let id, env = Env.add_fresh_ident env var in - env, (id, var, def) :: defs) - defs (env, []) - in - let defs = - List.map (fun (id, var, def) -> - VP.create id, to_clambda_named t env var def) - defs - in - Uletrec (defs, to_clambda t env body) - | Apply { func; args; kind = Direct direct_func; dbg = dbg } -> - (* The closure _parameter_ of the function is added by cmmgen. - At the call site, for a direct call, the closure argument must be - explicitly added (by [to_clambda_direct_apply]); there is no special - handling of such in the direct call primitive. - For an indirect call, we do not need to do anything here; Cmmgen will - do the equivalent of the previous paragraph when it generates a direct - call to [caml_apply]. *) - to_clambda_direct_apply t func args direct_func dbg env - | Apply { func; args; kind = Indirect; dbg = dbg } -> - let callee = subst_var env func in - Ugeneric_apply (check_closure callee (Flambda.Expr (Var func)), - subst_vars env args, dbg) - | Switch (arg, sw) -> - let aux () : Clambda.ulambda = - let const_index, const_actions = - to_clambda_switch t env sw.consts sw.numconsts sw.failaction - in - let block_index, block_actions = - to_clambda_switch t env sw.blocks sw.numblocks sw.failaction - in - Uswitch (subst_var env arg, - { us_index_consts = const_index; - us_actions_consts = const_actions; - us_index_blocks = block_index; - us_actions_blocks = block_actions; - }, - Debuginfo.none) (* debug info will be added by GPR#855 *) - in - (* Check that the [failaction] may be duplicated. If this is not the - case, share it through a static raise / static catch. *) - (* CR-someday pchambart for pchambart: This is overly simplified. - We should verify that this does not generates too bad code. - If it the case, handle some let cases. - *) - begin match sw.failaction with - | None -> aux () - | Some (Static_raise _) -> aux () - | Some failaction -> - let exn = Static_exception.create () in - let sw = - { sw with - failaction = Some (Flambda.Static_raise (exn, [])); - } - in - let expr : Flambda.t = - Static_catch (exn, [], Switch (arg, sw), failaction) - in - to_clambda t env expr - end - | String_switch (arg, sw, def) -> - let arg = subst_var env arg in - let sw = List.map (fun (s, e) -> s, to_clambda t env e) sw in - let def = Misc.may_map (to_clambda t env) def in - Ustringswitch (arg, sw, def) - | Static_raise (static_exn, args) -> - Ustaticfail (Static_exception.to_int static_exn, - List.map (subst_var env) args) - | Static_catch (static_exn, vars, body, handler) -> - let env_handler, ids = - List.fold_right (fun var (env, ids) -> - let id, env = Env.add_fresh_ident env var in - env, (VP.create id, Lambda.Pgenval) :: ids) - vars (env, []) - in - Ucatch (Static_exception.to_int static_exn, ids, - to_clambda t env body, to_clambda t env_handler handler) - | Try_with (body, var, handler) -> - let id, env_handler = Env.add_fresh_ident env var in - Utrywith (to_clambda t env body, VP.create id, - to_clambda t env_handler handler) - | If_then_else (arg, ifso, ifnot) -> - Uifthenelse (subst_var env arg, to_clambda t env ifso, - to_clambda t env ifnot) - | While (cond, body) -> - Uwhile (to_clambda t env cond, to_clambda t env body) - | For { bound_var; from_value; to_value; direction; body } -> - let id, env_body = Env.add_fresh_ident env bound_var in - Ufor (VP.create id, subst_var env from_value, subst_var env to_value, - direction, to_clambda t env_body body) - | Assign { being_assigned; new_value } -> - let id = - try Env.ident_for_mutable_var_exn env being_assigned - with Not_found -> - Misc.fatal_errorf "Unbound mutable variable %a in [Assign]: %a" - Mutable_variable.print being_assigned - Flambda.print flam - in - Uassign (id, subst_var env new_value) - | Send { kind; meth; obj; args; dbg } -> - Usend (kind, subst_var env meth, subst_var env obj, - subst_vars env args, dbg) - | Proved_unreachable -> Uunreachable - -and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda = - match named with - | Symbol sym -> to_clambda_symbol env sym - | Const (Const_pointer n) -> Uconst (Uconst_ptr n) - | Const (Int n) -> Uconst (Uconst_int n) - | Const (Char c) -> Uconst (Uconst_int (Char.code c)) - | Allocated_const _ -> - Misc.fatal_errorf "[Allocated_const] should have been lifted to a \ - [Let_symbol] construction before [Flambda_to_clambda]: %a = %a" - Variable.print var - Flambda.print_named named - | Read_mutable mut_var -> - begin try Uvar (Env.ident_for_mutable_var_exn env mut_var) - with Not_found -> - Misc.fatal_errorf "Unbound mutable variable %a in [Read_mutable]: %a" - Mutable_variable.print mut_var - Flambda.print_named named - end - | Read_symbol_field (symbol, field) -> - Uprim (Pfield field, [to_clambda_symbol env symbol], Debuginfo.none) - | Set_of_closures set_of_closures -> - to_clambda_set_of_closures t env set_of_closures - | Project_closure { set_of_closures; closure_id } -> - (* Note that we must use [build_uoffset] to ensure that we do not generate - a [Uoffset] construction in the event that the offset is zero, otherwise - we might break pattern matches in Cmmgen (in particular for the - compilation of "let rec"). *) - check_closure ( - build_uoffset - (check_closure (subst_var env set_of_closures) - (Flambda.Expr (Var set_of_closures))) - (get_fun_offset t closure_id)) - named - | Move_within_set_of_closures { closure; start_from; move_to } -> - check_closure (build_uoffset - (check_closure (subst_var env closure) - (Flambda.Expr (Var closure))) - ((get_fun_offset t move_to) - (get_fun_offset t start_from))) - named - | Project_var { closure; var; closure_id } -> - let ulam = subst_var env closure in - let fun_offset = get_fun_offset t closure_id in - let var_offset = get_fv_offset t var in - let pos = var_offset - fun_offset in - Uprim (Pfield pos, - [check_field (check_closure ulam (Expr (Var closure))) pos (Some named)], - Debuginfo.none) - | Prim (Pfield index, [block], dbg) -> - Uprim (Pfield index, [check_field (subst_var env block) index None], dbg) - | Prim (Psetfield (index, maybe_ptr, init), [block; new_value], dbg) -> - Uprim (Psetfield (index, maybe_ptr, init), [ - check_field (subst_var env block) index None; - subst_var env new_value; - ], dbg) - | Prim (Popaque, args, dbg) -> - Uprim (Pidentity, subst_vars env args, dbg) - | Prim (p, args, dbg) -> - Uprim (p, subst_vars env args, dbg) - | Expr expr -> to_clambda t env expr - -and to_clambda_switch t env cases num_keys default = - let num_keys = - if Numbers.Int.Set.cardinal num_keys = 0 then 0 - else Numbers.Int.Set.max_elt num_keys + 1 - in - let store = Flambda_utils.Switch_storer.mk_store () in - let default_action = - match default with - | Some def when List.length cases < num_keys -> - store.act_store () def - | _ -> -1 - in - let index = Array.make num_keys default_action in - let smallest_key = ref num_keys in - List.iter - (fun (key, lam) -> - index.(key) <- store.act_store () lam; - smallest_key := min key !smallest_key - ) - cases; - if !smallest_key < num_keys then begin - let action = ref index.(!smallest_key) in - Array.iteri - (fun i act -> - if act >= 0 then action := act else index.(i) <- !action) - index - end; - let actions = Array.map (to_clambda t env) (store.act_get ()) in - match actions with - | [| |] -> [| |], [| |] (* May happen when [default] is [None]. *) - | _ -> index, actions - -and to_clambda_direct_apply t func args direct_func dbg env : Clambda.ulambda = - let closed = is_function_constant t direct_func in - let label = Compilenv.function_label direct_func in - let uargs = - let uargs = subst_vars env args in - (* Remove the closure argument if the closure is closed. (Note that the - closure argument is always a variable, so we can be sure we are not - dropping any side effects.) *) - if closed then uargs else uargs @ [subst_var env func] - in - Udirect_apply (label, uargs, dbg) - -(* Describe how to build a runtime closure block that corresponds to the - given Flambda set of closures. - - For instance the closure for the following set of closures: - - let rec fun_a x = - if x <= 0 then 0 else fun_b (x-1) v1 - and fun_b x y = - if x <= 0 then 0 else v1 + v2 + y + fun_a (x-1) - - will be represented in memory as: - - [ closure header; fun_a; - 1; infix header; fun caml_curry_2; - 2; fun_b; v1; v2 ] - - fun_a and fun_b will take an additional parameter 'env' to - access their closure. It will be arranged such that in the body - of each function the env parameter points to its own code - pointer. For example, in fun_b it will be shifted by 3 words. - - Hence accessing v1 in the body of fun_a is accessing the - 6th field of 'env' and in the body of fun_b the 1st field. -*) -and to_clambda_set_of_closures t env - (({ function_decls; free_vars } : Flambda.set_of_closures) - as set_of_closures) : Clambda.ulambda = - let all_functions = Variable.Map.bindings function_decls.funs in - let env_var = V.create_local "env" in - let to_clambda_function - (closure_id, (function_decl : Flambda.function_declaration)) - : Clambda.ufunction = - let closure_id = Closure_id.wrap closure_id in - let fun_offset = - Closure_id.Map.find closure_id t.current_unit.fun_offset_table - in - let env = - (* Inside the body of the function, we cannot access variables - declared outside, so start with a suitably clean environment. - Note that we must not forget the information about which allocated - constants contain which unboxed values. *) - let env = Env.keep_only_symbols env in - (* Add the Clambda expressions for the free variables of the function - to the environment. *) - let add_env_free_variable id _ env = - let var_offset = - try - Var_within_closure.Map.find - (Var_within_closure.wrap id) t.current_unit.fv_offset_table - with Not_found -> - Misc.fatal_errorf "Clambda.to_clambda_set_of_closures: offset for \ - free variable %a is unknown. Set of closures: %a" - Variable.print id - Flambda.print_set_of_closures set_of_closures - in - let pos = var_offset - fun_offset in - Env.add_subst env id - (Uprim (Pfield pos, [Clambda.Uvar env_var], Debuginfo.none)) - in - let env = Variable.Map.fold add_env_free_variable free_vars env in - (* Add the Clambda expressions for all functions defined in the current - set of closures to the environment. The various functions may be - retrieved by moving within the runtime closure, starting from the - current function's closure. *) - let add_env_function pos env (id, _) = - let offset = - Closure_id.Map.find (Closure_id.wrap id) - t.current_unit.fun_offset_table - in - let exp : Clambda.ulambda = Uoffset (Uvar env_var, offset - pos) in - Env.add_subst env id exp - in - List.fold_left (add_env_function fun_offset) env all_functions - in - let env_body, params = - List.fold_right (fun var (env, params) -> - let id, env = Env.add_fresh_ident env (Parameter.var var) in - env, id :: params) - function_decl.params (env, []) - in - { label = Compilenv.function_label closure_id; - arity = Flambda_utils.function_arity function_decl; - params = - List.map - (fun var -> VP.create var, Lambda.Pgenval) - (params @ [env_var]); - return = Lambda.Pgenval; - body = to_clambda t env_body function_decl.body; - dbg = function_decl.dbg; - env = Some env_var; - } - in - let funs = List.map to_clambda_function all_functions in - let free_vars = - Variable.Map.bindings (Variable.Map.map ( - fun (free_var : Flambda.specialised_to) -> - subst_var env free_var.var) free_vars) - in - Uclosure (funs, List.map snd free_vars) - -and to_clambda_closed_set_of_closures t env symbol - ({ function_decls; } : Flambda.set_of_closures) - : Clambda.ustructured_constant = - let functions = Variable.Map.bindings function_decls.funs in - let to_clambda_function (id, (function_decl : Flambda.function_declaration)) - : Clambda.ufunction = - (* All that we need in the environment, for translating one closure from - a closed set of closures, is the substitutions for variables bound to - the various closures in the set. Such closures will always be - referenced via symbols. *) - let env = - List.fold_left (fun env (var, _) -> - let closure_id = Closure_id.wrap var in - let symbol = Compilenv.closure_symbol closure_id in - Env.add_subst env var (to_clambda_symbol env symbol)) - (Env.keep_only_symbols env) - functions - in - let env_body, params = - List.fold_right (fun var (env, params) -> - let id, env = Env.add_fresh_ident env (Parameter.var var) in - env, id :: params) - function_decl.params (env, []) - in - { label = Compilenv.function_label (Closure_id.wrap id); - arity = Flambda_utils.function_arity function_decl; - params = List.map (fun var -> VP.create var, Lambda.Pgenval) params; - return = Lambda.Pgenval; - body = to_clambda t env_body function_decl.body; - dbg = function_decl.dbg; - env = None; - } - in - let ufunct = List.map to_clambda_function functions in - let closure_lbl = Linkage_name.to_string (Symbol.label symbol) in - Uconst_closure (ufunct, closure_lbl, []) - -let to_clambda_initialize_symbol t env symbol fields : Clambda.ulambda = - let fields = - List.map (fun (index, expr) -> index, to_clambda t env expr) fields - in - let build_setfield (index, field) : Clambda.ulambda = - (* Note that this will never cause a write barrier hit, owing to - the [Initialization]. *) - Uprim (Psetfield (index, Pointer, Root_initialization), - [to_clambda_symbol env symbol; field], - Debuginfo.none) - in - match fields with - | [] -> Uconst (Uconst_ptr 0) - | h :: t -> - List.fold_left (fun acc (p, field) -> - Clambda.Usequence (build_setfield (p, field), acc)) - (build_setfield h) t - -let accumulate_structured_constants t env symbol - (c : Flambda.constant_defining_value) acc = - match c with - | Allocated_const c -> - Symbol.Map.add symbol (to_clambda_allocated_constant c) acc - | Block (tag, fields) -> - let fields = List.map (to_clambda_const env) fields in - Symbol.Map.add symbol (Clambda.Uconst_block (Tag.to_int tag, fields)) acc - | Set_of_closures set_of_closures -> - let to_clambda_set_of_closures = - to_clambda_closed_set_of_closures t env symbol set_of_closures - in - Symbol.Map.add symbol to_clambda_set_of_closures acc - | Project_closure _ -> acc - -let to_clambda_program t env constants (program : Flambda.program) = - let rec loop env constants (program : Flambda.program_body) - : Clambda.ulambda * - Clambda.ustructured_constant Symbol.Map.t * - Clambda.preallocated_block list = - match program with - | Let_symbol (symbol, alloc, program) -> - (* Useful only for unboxing. Since floats and boxed integers will - never be part of a Let_rec_symbol, handling only the Let_symbol - is sufficient. *) - let env = - match alloc with - | Allocated_const const -> Env.add_allocated_const env symbol const - | _ -> env - in - let constants = - accumulate_structured_constants t env symbol alloc constants - in - loop env constants program - | Let_rec_symbol (defs, program) -> - let constants = - List.fold_left (fun constants (symbol, alloc) -> - accumulate_structured_constants t env symbol alloc constants) - constants defs - in - loop env constants program - | Initialize_symbol (symbol, tag, fields, program) -> - let fields = - List.mapi (fun i field -> - i, field, - Initialize_symbol_to_let_symbol.constant_field field) - fields - in - let init_fields = - List.filter_map (function - | (i, field, None) -> Some (i, field) - | (_, _, Some _) -> None) - fields - in - let constant_fields = - List.map (fun (_, _, constant_field) -> - match constant_field with - | None -> None - | Some (Flambda.Const const) -> - let n = - match const with - | Int i -> i - | Char c -> Char.code c - | Const_pointer i -> i - in - Some (Clambda.Uconst_field_int n) - | Some (Flambda.Symbol sym) -> - let lbl = Linkage_name.to_string (Symbol.label sym) in - Some (Clambda.Uconst_field_ref lbl)) - fields - in - let e1 = to_clambda_initialize_symbol t env symbol init_fields in - let preallocated_block : Clambda.preallocated_block = - { symbol = Linkage_name.to_string (Symbol.label symbol); - exported = true; - tag = Tag.to_int tag; - fields = constant_fields; - provenance = None; - } - in - let e2, constants, preallocated_blocks = loop env constants program in - Usequence (e1, e2), constants, preallocated_block :: preallocated_blocks - | Effect (expr, program) -> - let e1 = to_clambda t env expr in - let e2, constants, preallocated_blocks = loop env constants program in - Usequence (e1, e2), constants, preallocated_blocks - | End _ -> - Uconst (Uconst_ptr 0), constants, [] - in - loop env constants program.program_body - -type result = { - expr : Clambda.ulambda; - preallocated_blocks : Clambda.preallocated_block list; - structured_constants : Clambda.ustructured_constant Symbol.Map.t; - exported : Export_info.t; -} - -let convert (program, exported_transient) : result = - let current_unit = - let closures = - Closure_id.Map.keys (Flambda_utils.make_closure_map program) - in - let constant_closures = - Flambda_utils.all_lifted_constant_closures program - in - let offsets = Closure_offsets.compute program in - { fun_offset_table = offsets.function_offsets; - fv_offset_table = offsets.free_variable_offsets; - constant_closures; - closures; - } - in - let imported_units = - let imported = Compilenv.approx_env () in - let closures = - Set_of_closures_id.Map.fold - (fun (_ : Set_of_closures_id.t) fun_decls acc -> - Variable.Map.fold - (fun var (_ : Simple_value_approx.function_declaration) acc -> - let closure_id = Closure_id.wrap var in - Closure_id.Set.add closure_id acc) - fun_decls.Simple_value_approx.funs - acc) - imported.sets_of_closures - Closure_id.Set.empty - in - { fun_offset_table = imported.offset_fun; - fv_offset_table = imported.offset_fv; - constant_closures = imported.constant_closures; - closures; - } - in - let t = { current_unit; imported_units; } in - let expr, structured_constants, preallocated_blocks = - to_clambda_program t Env.empty Symbol.Map.empty program - in - let exported = - Export_info.t_of_transient exported_transient - ~program - ~local_offset_fun:current_unit.fun_offset_table - ~local_offset_fv:current_unit.fv_offset_table - ~imported_offset_fun:imported_units.fun_offset_table - ~imported_offset_fv:imported_units.fv_offset_table - ~constant_closures:current_unit.constant_closures - in - { expr; preallocated_blocks; structured_constants; exported; } diff --git a/asmcomp/flambda_to_clambda.mli b/asmcomp/flambda_to_clambda.mli deleted file mode 100644 index 8c493d40..00000000 --- a/asmcomp/flambda_to_clambda.mli +++ /dev/null @@ -1,38 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -type result = { - expr : Clambda.ulambda; - preallocated_blocks : Clambda.preallocated_block list; - structured_constants : Clambda.ustructured_constant Symbol.Map.t; - exported : Export_info.t; -} - -(** Convert an Flambda program, with associated proto-export information, - to Clambda. - This yields a Clambda expression together with augmented export - information and details about required statically-allocated values - (preallocated blocks, for [Initialize_symbol], and structured - constants). - - It is during this process that accesses to variables within - closures are transformed to field accesses within closure values. - For direct calls, the hidden closure parameter is added. Switch - tables are also built. -*) -val convert : Flambda.program * Export_info.transient -> result diff --git a/asmcomp/i386/NOTES.md b/asmcomp/i386/NOTES.md index 6f1e1839..69567cbd 100644 --- a/asmcomp/i386/NOTES.md +++ b/asmcomp/i386/NOTES.md @@ -4,10 +4,13 @@ Intel and AMD x86 processors in 32-bit mode. The baseline is the 80486, also known as `i486`. (Debian's baseline is now the Pentium 1.) +In OCaml versions 3.09.2 to 4.08, MacOS was supported by this port. Support +was removed in OCaml 4.09. + Floating-point architecture: x87. (SSE2 not available in Debian's baseline.) -Operating systems: Linux, BSD, MacOS X, MS Windows. +Operating systems: Linux, BSD, MS Windows. Debian architecture name: `i386` @@ -18,5 +21,3 @@ Debian architecture name: `i386` * ELF application binary interface: _System V Application Binary Interface, Intel386 Architecture Processor Supplement_ -* MacOS X application binary interface: - _OS X ABI Function Call Guide: IA-32 Function Calling Conventions_ diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml index 23f54232..ba76a825 100644 --- a/asmcomp/i386/arch.ml +++ b/asmcomp/i386/arch.ml @@ -163,5 +163,4 @@ let stack_alignment = match Config.system with | "win32" -> 4 (* MSVC *) | _ -> 16 -(* PR#6038: GCC and Clang seem to require 16-byte alignment nowadays, - even if only MacOS X's ABI formally requires it *) + (* PR#6038: GCC and Clang seem to require 16-byte alignment nowadays *) diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index 654b5629..9f55cd29 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -467,41 +467,18 @@ let emit_global_label s = let function_name = ref "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 -(* Record references to external C functions (for MacOSX) *) -let external_symbols_direct = ref String.Set.empty -let external_symbols_indirect = ref String.Set.empty - -(* Emission of the profiling prelude *) - -let call_mcount mcount = - I.push eax; - I.mov esp ebp; - I.push ecx; - I.push edx; - I.call (sym mcount); - I.pop edx; - I.pop ecx; - I.pop eax - -let emit_profile () = - match system with - | S_linux_elf | S_gnu -> call_mcount "mcount" - | S_bsd_elf -> call_mcount ".mcount" - | S_macosx -> call_mcount "Lmcount$stub" - | _ -> () (*unsupported yet*) let emit_instr fallthrough i = emit_debug_info i.dbg; match i.desc with | Lend -> () | Lprologue -> - if !Clflags.gprofile then emit_profile(); + assert (Proc.prologue_required ()); let n = frame_size() - 4 in if n > 0 then begin I.sub (int n) esp; cfi_adjust_cfa_offset n; end; - def_label !tailrec_entry_point | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in if src.loc <> dst.loc then begin @@ -564,24 +541,11 @@ let emit_instr fallthrough i = | Lop(Iextcall { func; alloc; label_after; }) -> add_used_symbol func; if alloc then begin - if system <> S_macosx then - I.mov (immsym func) eax - else begin - external_symbols_indirect := - String.Set.add func !external_symbols_indirect; - I.mov (mem_sym DWORD (Printf.sprintf "L%s$non_lazy_ptr" - (emit_symbol func))) eax - end; + I.mov (immsym func) eax; emit_call "caml_c_call"; record_frame i.live false i.dbg ~label:label_after end else begin - if system <> S_macosx then - emit_call func - else begin - external_symbols_direct := - String.Set.add func !external_symbols_direct; - I.call (sym (Printf.sprintf "L%s$stub" (emit_symbol func))) - end + emit_call func end | Lop(Istackoffset n) -> if n < 0 @@ -880,9 +844,10 @@ let emit_instr fallthrough i = D.long (ConstLabel (emit_label jumptbl.(i))) done; D.text () - | Lsetuptrap lbl -> - I.call (label lbl) - | Lpushtrap -> + | Lentertrap -> + () + | Lpushtrap { lbl_handler; } -> + I.push (label lbl_handler); if trap_frame_size > 8 then I.sub (int (trap_frame_size - 8)) esp; I.push (sym32 "caml_exception_pointer"); @@ -904,7 +869,8 @@ let emit_instr fallthrough i = I.pop (sym32 "caml_exception_pointer"); if trap_frame_size > 8 then I.add (int (trap_frame_size - 8)) esp; - I.ret () + I.pop ebx; + I.jmp ebx end let rec emit_all fallthrough i = @@ -916,38 +882,12 @@ let rec emit_all fallthrough i = (system = S_win32 || Linearize.has_fallthrough i.desc) i.next -(* Emission of external symbol references (for MacOSX) *) - -let emit_external_symbol_direct s = - _label (Printf.sprintf "L%s$stub" (emit_symbol s)); - D.indirect_symbol (emit_symbol s); - I.hlt (); I.hlt (); I.hlt (); I.hlt () ; I.hlt () - -let emit_external_symbol_indirect s = - _label (Printf.sprintf "L%s$non_lazy_ptr" (emit_symbol s)); - D.indirect_symbol (emit_symbol s); - D.long (const 0) - -let emit_external_symbols () = - D.section [ "__IMPORT"; "__pointers"] None ["non_lazy_symbol_pointers" ]; - String.Set.iter emit_external_symbol_indirect !external_symbols_indirect; - external_symbols_indirect := String.Set.empty; - D.section [ "__IMPORT"; "__jump_table"] None - [ "symbol_stubs"; "self_modifying_code+pure_instructions"; "5" ]; - String.Set.iter emit_external_symbol_direct !external_symbols_direct; - external_symbols_direct := String.Set.empty; - if !Clflags.gprofile then begin - _label "Lmcount$stub"; - D.indirect_symbol "mcount"; - I.hlt (); I.hlt (); I.hlt () ; I.hlt () ; I.hlt () - end - (* Emission of a function declaration *) let fundecl fundecl = function_name := fundecl.fun_name; fastcode_flag := fundecl.fun_fast; - tailrec_entry_point := new_label(); + tailrec_entry_point := fundecl.fun_tailrec_entry_point_label; stack_offset := 0; call_gc_sites := []; bound_error_sites := []; @@ -955,13 +895,7 @@ let fundecl fundecl = D.text (); add_def_symbol fundecl.fun_name; D.align (if system = S_win32 then 4 else 16); - if system = S_macosx - && not !Clflags.output_c_object - && is_generic_function fundecl.fun_name - then (* PR#4690 *) - D.private_extern (emit_symbol fundecl.fun_name) - else - D.global (emit_symbol fundecl.fun_name); + D.global (emit_symbol fundecl.fun_name); D.label (emit_symbol fundecl.fun_name); emit_debug_info fundecl.fun_dbg; cfi_startproc (); @@ -1027,9 +961,7 @@ let begin_assembly() = emit_global_label "data_begin"; D.text (); - emit_global_label "code_begin"; - if system = S_macosx then I.nop (); (* PR#4690 *) - () + emit_global_label "code_begin" let end_assembly() = if !float_constants <> [] then begin @@ -1038,8 +970,6 @@ let end_assembly() = end; D.text (); - if system = S_macosx then I.nop (); - (* suppress "ld warning: atom sorting error" *) emit_global_label "code_end"; @@ -1066,7 +996,6 @@ let end_assembly() = efa_string = (fun s -> D.bytes (s ^ "\000")) }; - if system = S_macosx then emit_external_symbols (); if system = S_linux_elf then (* Mark stack as non-executable, PR#4564 *) D.section [".note.GNU-stack"] (Some "") ["%progbits"]; diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml index 29290d0d..0b333af4 100644 --- a/asmcomp/i386/proc.ml +++ b/asmcomp/i386/proc.ml @@ -241,6 +241,17 @@ let op_is_pure = function let num_stack_slots = [| 0; 0 |] let contains_calls = ref false +let frame_required () = + let frame_size_at_top_of_function = + (* cf. [frame_size] in emit.mlp. *) + Misc.align (4*num_stack_slots.(0) + 8*num_stack_slots.(1) + 4) + stack_alignment + in + frame_size_at_top_of_function > 4 + +let prologue_required () = + frame_required () + (* Calling the assembler *) let assemble_file infile outfile = diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml index efde628d..9e4e949a 100644 --- a/asmcomp/i386/selection.ml +++ b/asmcomp/i386/selection.ml @@ -32,25 +32,25 @@ type addressing_expr = let rec select_addr exp = match exp with - Cconst_symbol s -> + Cconst_symbol (s, _) -> (Asymbol s, 0) - | Cop((Caddi | Caddv | Cadda), [arg; Cconst_int m], _) -> + | Cop((Caddi | Caddv | Cadda), [arg; Cconst_int (m, _)], _) -> let (a, n) = select_addr arg in (a, n + m) - | Cop(Csubi, [arg; Cconst_int m], _) -> + | Cop(Csubi, [arg; Cconst_int (m, _)], _) -> let (a, n) = select_addr arg in (a, n - m) - | Cop((Caddi | Caddv | Cadda), [Cconst_int m; arg], _) -> + | Cop((Caddi | Caddv | Cadda), [Cconst_int (m, _); arg], _) -> let (a, n) = select_addr arg in (a, n + m) - | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)], _) -> + | Cop(Clsl, [arg; Cconst_int ((1|2|3 as shift), _)], _) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift) | _ -> (Alinear exp, 0) end - | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)], _) -> + | Cop(Cmuli, [arg; Cconst_int ((2|4|8 as mult), _)], _) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, mult), n * mult) | _ -> (Alinear exp, 0) end - | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg], _) -> + | Cop(Cmuli, [Cconst_int ((2|4|8 as mult), _); arg], _) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, mult), n * mult) | _ -> (Alinear exp, 0) @@ -192,15 +192,15 @@ method select_addressing _chunk exp = method! select_store is_assign addr exp = match exp with - Cconst_int n -> + Cconst_int (n, _) -> (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) - | (Cconst_natint n | Cblockheader (n, _)) -> + | (Cconst_natint (n, _) | Cblockheader (n, _)) -> (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) - | Cconst_pointer n -> + | Cconst_pointer (n, _) -> (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) - | Cconst_natpointer n -> + | Cconst_natpointer (n, _) -> (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) - | Cconst_symbol s -> + | Cconst_symbol (s, _) -> (Ispecific(Istore_symbol(s, addr, is_assign)), Ctuple []) | _ -> super#select_store is_assign addr exp @@ -229,7 +229,7 @@ method! select_operation op args dbg = (* Recognize store instructions *) | Cstore ((Word_int | Word_val) as chunk, _) -> begin match args with - [loc; Cop(Caddi, [Cop(Cload _, [loc'], _); Cconst_int n], _)] + [loc; Cop(Caddi, [Cop(Cload _, [loc'], _); Cconst_int (n, _)], _)] when loc = loc' -> let (addr, arg) = self#select_addressing chunk loc in (Ispecific(Ioffset_loc(n, addr)), [arg]) @@ -270,28 +270,29 @@ method select_floatarith regular_op reversed_op mem_op mem_rev_op args = (* Deal with register constraints *) -method! insert_op_debug op dbg rs rd = +method! insert_op_debug env op dbg rs rd = try let (rsrc, rdst, move_res) = pseudoregs_for_operation op rs rd in - self#insert_moves rs rsrc; - self#insert_debug (Iop op) dbg rsrc rdst; + self#insert_moves env rs rsrc; + self#insert_debug env (Iop op) dbg rsrc rdst; if move_res then begin - self#insert_moves rdst rd; + self#insert_moves env rdst rd; rd end else rdst with Use_default -> - super#insert_op_debug op dbg rs rd + super#insert_op_debug env op dbg rs rd (* Selection of push instructions for external calls *) method select_push exp = match exp with - Cconst_int n -> (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple []) - | Cconst_natint n -> (Ispecific(Ipush_int n), Ctuple []) - | Cconst_pointer n -> (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple []) - | Cconst_natpointer n -> (Ispecific(Ipush_int n), Ctuple []) - | Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple []) + Cconst_int (n, _) -> (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple []) + | Cconst_natint (n, _) -> (Ispecific(Ipush_int n), Ctuple []) + | Cconst_pointer (n, _) -> + (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple []) + | Cconst_natpointer (n, _) -> (Ispecific(Ipush_int n), Ctuple []) + | Cconst_symbol (s, _) -> (Ispecific(Ipush_symbol s), Ctuple []) | Cop(Cload ((Word_int | Word_val as chunk), _), [loc], _) -> let (addr, arg) = self#select_addressing chunk loc in (Ispecific(Ipush_load addr), arg) @@ -312,13 +313,13 @@ method! emit_extcall_args env args = let rec emit_pushes = function | [] -> if sz2 > sz1 then - self#insert (Iop (Istackoffset (sz2 - sz1))) [||] [||] + self#insert env (Iop (Istackoffset (sz2 - sz1))) [||] [||] | e :: el -> emit_pushes el; let (op, arg) = self#select_push e in match self#emit_expr env arg with | None -> () - | Some r -> self#insert (Iop op) r [||] in + | Some r -> self#insert env (Iop op) r [||] in emit_pushes args; ([||], sz2) diff --git a/asmcomp/import_approx.ml b/asmcomp/import_approx.ml deleted file mode 100644 index 64fbbb8b..00000000 --- a/asmcomp/import_approx.ml +++ /dev/null @@ -1,222 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -module A = Simple_value_approx - -let import_set_of_closures = - let import_function_declarations (clos : A.function_declarations) - : A.function_declarations = - (* CR-soon mshinwell for pchambart: Do we still need to do this - rewriting? I'm wondering if maybe we don't have to any more. *) - let sym_to_fun_var_map (clos : A.function_declarations) = - Variable.Map.fold (fun fun_var _ acc -> - let closure_id = Closure_id.wrap fun_var in - let sym = Compilenv.closure_symbol closure_id in - Symbol.Map.add sym fun_var acc) - clos.funs Symbol.Map.empty - in - let sym_map = sym_to_fun_var_map clos in - let f_named (named : Flambda.named) = - match named with - | Symbol sym -> - begin try Flambda.Expr (Var (Symbol.Map.find sym sym_map)) with - | Not_found -> named - end - | named -> named - in - let funs = - Variable.Map.map (fun (function_decl : A.function_declaration) -> - A.update_function_declaration_body function_decl - (Flambda_iterators.map_toplevel_named f_named)) - clos.funs - in - A.update_function_declarations clos ~funs - in - let aux set_of_closures_id = - match - Compilenv.approx_for_global - (Set_of_closures_id.get_compilation_unit set_of_closures_id) - with - | None -> None - | Some ex_info -> - try - let function_declarations = - Set_of_closures_id.Map.find set_of_closures_id - ex_info.sets_of_closures - in - Some (import_function_declarations function_declarations) - with Not_found -> - Misc.fatal_error "Cannot find set of closures" - in - Set_of_closures_id.Tbl.memoize Compilenv.imported_sets_of_closures_table aux - -let rec import_ex ex = - let import_value_set_of_closures ~set_of_closures_id ~bound_vars ~free_vars - ~(ex_info : Export_info.t) ~what : A.value_set_of_closures option = - let bound_vars = Var_within_closure.Map.map import_approx bound_vars in - match import_set_of_closures set_of_closures_id with - | None -> None - | Some function_decls -> - (* CR-someday xclerc: add a test to the test suite to ensure that - classic mode behaves as expected. *) - let is_classic_mode = function_decls.is_classic_mode in - let invariant_params = - match - Set_of_closures_id.Map.find set_of_closures_id - ex_info.invariant_params - with - | exception Not_found -> - if is_classic_mode then - Variable.Map.empty - else - Misc.fatal_errorf "Set of closures ID %a not found in \ - invariant_params (when importing [%a: %s])" - Set_of_closures_id.print set_of_closures_id - Export_id.print ex - what - | found -> found - in - let recursive = - match - Set_of_closures_id.Map.find set_of_closures_id ex_info.recursive - with - | exception Not_found -> - if is_classic_mode then - Variable.Set.empty - else - Misc.fatal_errorf "Set of closures ID %a not found in \ - recursive (when importing [%a: %s])" - Set_of_closures_id.print set_of_closures_id - Export_id.print ex - what - | found -> found - in - Some (A.create_value_set_of_closures - ~function_decls - ~bound_vars - ~free_vars - ~invariant_params:(lazy invariant_params) - ~recursive:(lazy recursive) - ~specialised_args:Variable.Map.empty - ~freshening:Freshening.Project_var.empty - ~direct_call_surrogates:Closure_id.Map.empty) - in - let compilation_unit = Export_id.get_compilation_unit ex in - match Compilenv.approx_for_global compilation_unit with - | None -> A.value_unknown Other - | Some ex_info -> - match Export_info.find_description ex_info ex with - | exception Not_found -> - Misc.fatal_errorf "Cannot find export id %a" Export_id.print ex - | Value_unknown_descr -> A.value_unknown Other - | Value_int i -> A.value_int i - | Value_char c -> A.value_char c - | Value_constptr i -> A.value_constptr i - | Value_float f -> A.value_float f - | Value_float_array float_array -> - begin match float_array.contents with - | Unknown_or_mutable -> - A.value_mutable_float_array ~size:float_array.size - | Contents contents -> - A.value_immutable_float_array - (Array.map (function - | None -> A.value_any_float - | Some f -> A.value_float f) - contents) - end - | Export_info.Value_boxed_int (t, i) -> A.value_boxed_int t i - | Value_string { size; contents } -> - let contents = - match contents with - | Unknown_or_mutable -> None - | Contents contents -> Some contents - in - A.value_string size contents - | Value_mutable_block _ -> A.value_unknown Other - | Value_block (tag, fields) -> - A.value_block tag (Array.map import_approx fields) - | Value_closure { closure_id; - set_of_closures = - { set_of_closures_id; bound_vars; free_vars; aliased_symbol } } -> - let value_set_of_closures = - import_value_set_of_closures - ~set_of_closures_id ~bound_vars ~free_vars ~ex_info - ~what:(Format.asprintf "Value_closure %a" Closure_id.print closure_id) - in - begin match value_set_of_closures with - | None -> A.value_unresolved (Set_of_closures_id set_of_closures_id) - | Some value_set_of_closures -> - A.value_closure ?set_of_closures_symbol:aliased_symbol - value_set_of_closures closure_id - end - | Value_set_of_closures - { set_of_closures_id; bound_vars; free_vars; aliased_symbol } -> - let value_set_of_closures = - import_value_set_of_closures ~set_of_closures_id - ~bound_vars ~free_vars ~ex_info ~what:"Value_set_of_closures" - in - match value_set_of_closures with - | None -> - A.value_unresolved (Set_of_closures_id set_of_closures_id) - | Some value_set_of_closures -> - let approx = A.value_set_of_closures value_set_of_closures in - match aliased_symbol with - | None -> approx - | Some symbol -> A.augment_with_symbol approx symbol - -and import_approx (ap : Export_info.approx) = - match ap with - | Value_unknown -> A.value_unknown Other - | Value_id ex -> A.value_extern ex - | Value_symbol sym -> A.value_symbol sym - -let import_symbol sym = - if Compilenv.is_predefined_exception sym then - A.value_unknown Other - else begin - let compilation_unit = Symbol.compilation_unit sym in - match Compilenv.approx_for_global compilation_unit with - | None -> A.value_unresolved (Symbol sym) - | Some export_info -> - match Symbol.Map.find sym export_info.symbol_id with - | approx -> A.augment_with_symbol (import_ex approx) sym - | exception Not_found -> - Misc.fatal_errorf - "Compilation unit = %a Cannot find symbol %a" - Compilation_unit.print compilation_unit - Symbol.print sym - end - -(* Note for code reviewers: Observe that [really_import] iterates until - the approximation description is fully resolved (or a necessary .cmx - file is missing). *) - -let rec really_import (approx : A.descr) = - match approx with - | Value_extern ex -> really_import_ex ex - | Value_symbol sym -> really_import_symbol sym - | r -> r - -and really_import_ex ex = - really_import (import_ex ex).descr - -and really_import_symbol sym = - really_import (import_symbol sym).descr - -let really_import_approx (approx : Simple_value_approx.t) = - A.replace_description approx (really_import approx.descr) diff --git a/asmcomp/import_approx.mli b/asmcomp/import_approx.mli deleted file mode 100644 index 23d9d294..00000000 --- a/asmcomp/import_approx.mli +++ /dev/null @@ -1,34 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Create simple value approximations from the export information in - .cmx files. *) - -(** Given an approximation description, load .cmx files (possibly more - than one) until the description is fully resolved. If a necessary .cmx - file cannot be found, "unresolved" will be returned. *) -val really_import : Simple_value_approx.descr -> Simple_value_approx.descr - -(** Maps the description of the given approximation through [really_import]. *) -val really_import_approx : Simple_value_approx.t -> Simple_value_approx.t - -(** Read and convert the approximation of a given symbol from the - relevant .cmx file. Unlike the "really_" functions, this does not - continue to load .cmx files until the approximation is fully - resolved. *) -val import_symbol : Symbol.t -> Simple_value_approx.t diff --git a/asmcomp/interf.ml b/asmcomp/interf.ml index 7d569c5b..a1cdb921 100644 --- a/asmcomp/interf.ml +++ b/asmcomp/interf.ml @@ -105,8 +105,6 @@ let build_graph fundecl = interf cases.(i) done; interf i.next - | Iloop body -> - interf body; interf i.next | Icatch(_rec_flag, handlers, body) -> interf body; List.iter (fun (_, handler) -> interf handler) handlers; @@ -177,10 +175,6 @@ let build_graph fundecl = prefer (weight / 2) cases.(i) done; prefer weight i.next - | Iloop body -> - (* Avoid overflow of weight and spill_cost *) - prefer (if weight < 1000 then 8 * weight else weight) body; - prefer weight i.next | Icatch(rec_flag, handlers, body) -> prefer weight body; List.iter (fun (_nfail, handler) -> diff --git a/asmcomp/interval.ml b/asmcomp/interval.ml index 01f49a30..956ac4f7 100644 --- a/asmcomp/interval.ml +++ b/asmcomp/interval.ml @@ -148,10 +148,6 @@ let build_intervals fd = insert_destroyed_at_oper intervals i !pos; Array.iter walk_instruction cases; walk_instruction i.next - | Iloop body -> - insert_destroyed_at_oper intervals i !pos; - walk_instruction body; - walk_instruction i.next | Icatch(_, handlers, body) -> insert_destroyed_at_oper intervals i !pos; List.iter (fun (_, i) -> walk_instruction i) handlers; diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index a5a39aa5..38d3d6ac 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -39,8 +39,8 @@ and instruction_desc = | Lcondbranch of test * label | Lcondbranch3 of label option * label option * label option | Lswitch of label array - | Lsetuptrap of label - | Lpushtrap + | Lentertrap + | Lpushtrap of { lbl_handler : label; } | Lpoptrap | Lraise of Cmm.raise_kind @@ -55,6 +55,7 @@ type fundecl = fun_fast: bool; fun_dbg : Debuginfo.t; fun_spacetime_shape : Mach.spacetime_shape option; + fun_tailrec_entry_point_label : label; } (* Invert a test *) @@ -130,7 +131,7 @@ let rec discard_dead_code n = | Llabel _ -> n (* Do not discard Lpoptrap/Lpushtrap or Istackoffset instructions, as this may cause a stack imbalance later during assembler generation. *) - | Lpoptrap | Lpushtrap -> n + | Lpoptrap | Lpushtrap _ -> n | Lop(Istackoffset _) -> n | _ -> discard_dead_code n.next @@ -249,11 +250,6 @@ let rec linear i n = i !n2 end else copy_instr (Lswitch(Array.map (fun n -> lbl_cases.(n)) index)) i !n2 - | Iloop body -> - let lbl_head = Cmm.new_label() in - let n1 = linear i.Mach.next n in - let n2 = linear body (cons_instr (Lbranch lbl_head) n1) in - cons_instr (Llabel lbl_head) n2 | Icatch(_rec_flag, handlers, body) -> let (lbl_end, n1) = get_label(linear i.Mach.next n) in (* CR mshinwell for pchambart: @@ -272,7 +268,8 @@ let rec linear i n = let n2 = List.fold_left2 (fun n (_nfail, handler) lbl_handler -> match handler.Mach.desc with | Iend -> n - | _ -> cons_instr (Llabel lbl_handler) (linear handler n)) + | _ -> cons_instr (Llabel lbl_handler) + (linear handler (add_branch lbl_end n))) n1 handlers labels_at_entry_to_handlers in let n3 = linear body (add_branch lbl_end n2) in @@ -286,9 +283,11 @@ let rec linear i n = only to inform the later pass about this stack offset (corresponding to N traps). *) + let lbl_dummy = lbl in let rec loop i tt = if t = tt then i - else loop (cons_instr Lpushtrap i) (tt - 1) + else + loop (cons_instr (Lpushtrap { lbl_handler = lbl_dummy; }) i) (tt - 1) in let n1 = loop (linear i.Mach.next n) !try_depth in let rec loop i tt = @@ -298,32 +297,89 @@ let rec linear i n = loop (add_branch lbl n1) !try_depth | Itrywith(body, handler) -> let (lbl_join, n1) = get_label (linear i.Mach.next n) in + let (lbl_handler, n2) = + get_label (cons_instr Lentertrap (linear handler n1)) + in incr try_depth; assert (i.Mach.arg = [| |] || Config.spacetime); - let (lbl_body, n2) = - get_label (instr_cons Lpushtrap i.Mach.arg [| |] - (linear body (cons_instr Lpoptrap n1))) in + let n3 = cons_instr (Lpushtrap { lbl_handler; }) + (linear body + (cons_instr + Lpoptrap + (add_branch lbl_join n2))) in decr try_depth; - instr_cons (Lsetuptrap lbl_body) i.Mach.arg [| |] - (linear handler (add_branch lbl_join n2)) + n3 + | Iraise k -> copy_instr (Lraise k) i (discard_dead_code n) let add_prologue first_insn = - let insn = first_insn in - { desc = Lprologue; - next = insn; - arg = [| |]; - res = [| |]; - dbg = insn.dbg; - live = insn.live; - } + (* The prologue needs to come after any [Iname_for_debugger] operations that + refer to parameters. (Such operations always come in a contiguous + block, cf. [Selectgen].) *) + let rec skip_naming_ops (insn : instruction) : label * instruction = + match insn.desc with + | Lop (Iname_for_debugger _) -> + let tailrec_entry_point_label, next = skip_naming_ops insn.next in + tailrec_entry_point_label, { insn with next; } + | _ -> + let tailrec_entry_point_label = Cmm.new_label () in + let tailrec_entry_point = + { desc = Llabel tailrec_entry_point_label; + next = insn; + arg = [| |]; + res = [| |]; + dbg = insn.dbg; + live = insn.live; + } + in + (* We expect [Lprologue] to expand to at least one instruction---as such, + if no prologue is required, we avoid adding the instruction here. + The reason is subtle: an empty expansion of [Lprologue] can cause + two labels, one either side of the [Lprologue], to point at the same + location. This means that we lose the property (cf. [Coalesce_labels]) + that we can check if two labels point at the same location by + comparing them for equality. This causes trouble when the function + whose prologue is in question lands at the top of the object file + and we are emitting DWARF debugging information: + foo_code_begin: + foo: + .L1: + ; empty prologue + .L2: + ... + If we were to emit a location list entry from L1...L2, not realising + that they point at the same location, then the beginning and ending + points of the range would be both equal to each other and (relative to + "foo_code_begin") equal to zero. This appears to confuse objdump, + which seemingly misinterprets the entry as an end-of-list entry + (which is encoded with two zero words), then complaining about a + "hole in location list" (as it ignores any remaining list entries + after the misinterpreted entry). *) + if Proc.prologue_required () then + let prologue = + { desc = Lprologue; + next = tailrec_entry_point; + arg = [| |]; + res = [| |]; + dbg = tailrec_entry_point.dbg; + live = Reg.Set.empty; (* will not be used *) + } + in + tailrec_entry_point_label, prologue + else + tailrec_entry_point_label, tailrec_entry_point + in + skip_naming_ops first_insn let fundecl f = - let fun_body = add_prologue (linear f.Mach.fun_body end_instr) in + let fun_tailrec_entry_point_label, fun_body = + add_prologue (linear f.Mach.fun_body end_instr) + in { fun_name = f.Mach.fun_name; fun_body; fun_fast = not (List.mem Cmm.Reduce_code_size f.Mach.fun_codegen_options); fun_dbg = f.Mach.fun_dbg; fun_spacetime_shape = f.Mach.fun_spacetime_shape; + fun_tailrec_entry_point_label; } diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli index e30996fe..d1662295 100644 --- a/asmcomp/linearize.mli +++ b/asmcomp/linearize.mli @@ -36,8 +36,8 @@ and instruction_desc = | Lcondbranch of Mach.test * label | Lcondbranch3 of label option * label option * label option | Lswitch of label array - | Lsetuptrap of label - | Lpushtrap + | Lentertrap + | Lpushtrap of { lbl_handler : label; } | Lpoptrap | Lraise of Cmm.raise_kind @@ -53,6 +53,7 @@ type fundecl = fun_fast: bool; fun_dbg : Debuginfo.t; fun_spacetime_shape : Mach.spacetime_shape option; + fun_tailrec_entry_point_label : label; } val fundecl: Mach.fundecl -> fundecl diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml index 28c5868c..2da5b160 100644 --- a/asmcomp/liveness.ml +++ b/asmcomp/liveness.ml @@ -89,20 +89,6 @@ let rec live i finally = done; i.live <- !at_fork; Reg.add_set_array !at_fork arg - | Iloop(body) -> - let at_top = ref Reg.Set.empty in - (* Yes, there are better algorithms, but we'll just iterate till - reaching a fixpoint. *) - begin try - while true do - let new_at_top = Reg.Set.union !at_top (live body !at_top) in - if Reg.Set.equal !at_top new_at_top then raise Exit; - at_top := new_at_top - done - with Exit -> () - end; - i.live <- !at_top; - !at_top | Icatch(rec_flag, handlers, body) -> let at_join = live i.next finally in let aux (nfail,handler) (nfail', before_handler) = diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index 17a5ba7e..bfed9f7e 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -81,7 +81,6 @@ and instruction_desc = | Ireturn | Iifthenelse of test * instruction * instruction | Iswitch of int array * instruction array - | Iloop of instruction | Icatch of Cmm.rec_flag * (int * instruction) list * instruction | Iexit of int | Itrywith of instruction * instruction @@ -153,8 +152,6 @@ let rec instr_iter f i = instr_iter f cases.(i) done; instr_iter f i.next - | Iloop(body) -> - instr_iter f body; instr_iter f i.next | Icatch(_, handlers, body) -> instr_iter f body; List.iter (fun (_n, handler) -> instr_iter f handler) handlers; @@ -197,7 +194,7 @@ let spacetime_node_hole_pointer_is_live_before insn = | Ifloatofint | Iintoffloat | Iname_for_debugger _ -> false end - | Iend | Ireturn | Iifthenelse _ | Iswitch _ | Iloop _ | Icatch _ + | Iend | Ireturn | Iifthenelse _ | Iswitch _ | Icatch _ | Iexit _ | Itrywith _ | Iraise _ -> false let operation_can_raise op = diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index f32d8604..6ad4cda4 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -97,7 +97,6 @@ and instruction_desc = | Ireturn | Iifthenelse of test * instruction * instruction | Iswitch of int array * instruction array - | Iloop of instruction | Icatch of Cmm.rec_flag * (int * instruction) list * instruction | Iexit of int | Itrywith of instruction * instruction diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index b489fa99..558d1a1e 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -198,8 +198,11 @@ let emit_toctable () = `{emit_label lbl}: .quad {emit_tocentry entry}\n`) tocref_entries -(* Emit a load from a TOC entry *) +(* Emit a load from a TOC entry. + The [dest] should not be r0, since [dest] is used as the index register for a + ld instruction, but r0 reads as zero when used as an index register. +*) let emit_tocload emit_dest dest entry = let lbl = label_for_tocref entry in if !big_toc || !Clflags.for_package <> None then begin @@ -502,8 +505,8 @@ module BR = Branch_relaxation.Make (struct + (if lbl1 = None then 0 else 1) + (if lbl2 = None then 0 else 1) | Lswitch _ -> size 7 (5 + tocload_size()) (5 + tocload_size()) - | Lsetuptrap _ -> size 1 2 2 - | Lpushtrap -> size 4 5 5 + | Lentertrap -> size 0 (tocload_size()) (tocload_size()) + | Lpushtrap _ -> size 5 (4 + tocload_size()) (4 + tocload_size()) | Lpoptrap -> 2 | Lraise _ -> 6 @@ -517,28 +520,6 @@ module BR = Branch_relaxation.Make (struct let relax_intop_imm_checkbound ~bound:_ ~label_after_error:_ = assert false end) -(* Emission of the profiling prelude *) - -let emit_profile () = - match abi with - | ELF32 -> - ` mflr 0\n`; - ` addi 1, 1, -16\n`; - ` stw 0, 4(1)\n`; - (* _mcount preserves the registers used for parameter passing *) - (* when it returns, lr contains the original return address *) - ` bl {emit_symbol "_mcount"}\n`; - ` addi 1, 1, 16\n` - | ELF64v1 | ELF64v2 -> - ` mflr 0\n`; - (* save the registers used for parameter passing *) - ` bl {emit_symbol "caml_before_mcount"}\n`; - ` bl {emit_symbol "_mcount"}\n`; - ` nop\n`; - (* restore the registers used for parameter passing *) - ` bl {emit_symbol "caml_after_mcount"}\n`; - ` mtlr 0\n` - (* Output the assembly code for an instruction *) let emit_instr i = @@ -546,7 +527,7 @@ let emit_instr i = match i.desc with | Lend -> () | Lprologue -> - if !Clflags.gprofile then emit_profile(); + assert (Proc.prologue_required ()); let n = frame_size() in if n > 0 then begin ` addi 1, 1, {emit_int(-n)}\n`; @@ -561,8 +542,7 @@ let emit_instr i = | ELF32 -> () | ELF64v1 | ELF64v2 -> ` std 2, {emit_int(toc_save_offset())}(1)\n` - end; - `{emit_label !tailrec_entry_point}:\n` + end | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in if src.loc <> dst.loc then begin @@ -975,26 +955,26 @@ let emit_instr i = done; emit_string code_space end - | Lsetuptrap lbl -> - ` bl {emit_label lbl}\n`; + | Lentertrap -> begin match abi with | ELF32 -> () | ELF64v1 | ELF64v2 -> emit_reload_toc() end - | Lpushtrap -> + | Lpushtrap { lbl_handler; } -> begin match abi with | ELF32 -> - ` mflr 0\n`; - ` stwu 0, -16(1)\n`; + ` addis 11, 0, {emit_upper emit_label lbl_handler}\n`; + ` addi 11, 11, {emit_lower emit_label lbl_handler}\n`; + ` stwu 11, -16(1)\n`; adjust_stack_offset 16; ` stw 29, 4(1)\n`; ` mr 29, 1\n` | ELF64v1 | ELF64v2 -> - ` mflr 0\n`; - ` addi 1, 1, -32\n`; - adjust_stack_offset 32; - ` std 0, {emit_int trap_handler_offset}(1)\n`; + ` addi 1, 1, {emit_int (-trap_size)}\n`; + adjust_stack_offset trap_size; ` std 29, {emit_int trap_previous_offset}(1)\n`; + emit_tocload emit_gpr 29 (TocLabel lbl_handler); + ` std 29, {emit_int trap_handler_offset}(1)\n`; ` mr 29, 1\n` end | Lpoptrap -> @@ -1027,7 +1007,7 @@ let rec emit_all i = let fundecl fundecl = function_name := fundecl.fun_name; - tailrec_entry_point := new_label(); + tailrec_entry_point := fundecl.fun_tailrec_entry_point_label; stack_offset := 0; call_gc_label := 0; float_literals := []; @@ -1183,31 +1163,6 @@ let begin_assembly() = `{emit_symbol lbl_begin}:\n` let end_assembly() = - (* In profiling mode, for ELF64, emit the helper functions - for register saving and restoring. We put one copy of these - functions in every generated file, instead of defining - them once in runtime/power.S, so that we can call them - without risking to save r2 in the wrong place. *) - if ppc64 && !Clflags.gprofile then begin - let save_area = reserved_stack_space + (if abi = ELF64v1 then 8*8 else 0) in - let stacksize = save_area + 8*8 in - emit_string code_space; - ` .align 2\n`; - `{emit_symbol "caml_before_mcount"}:\n`; - ` stdu 1, {emit_int (-stacksize)}(1)\n`; - ` std 0, {emit_int (16 + stacksize)}(1)\n`; - for i = 3 to 10 do - ` std {emit_gpr i}, {emit_int (save_area + (i - 3) * 8)}(1)\n` - done; - ` blr\n`; - `{emit_symbol "caml_after_mcount"}:\n`; - ` ld 0, {emit_int (16 + stacksize)}(1)\n`; - for i = 3 to 10 do - ` ld {emit_gpr i}, {emit_int (save_area + (i - 3) * 8)}(1)\n` - done; - ` addi 1, 1, {emit_int stacksize}\n`; - ` blr\n` - end; (* Emit the end of the segments *) emit_string function_descr_space; let lbl_end = Compilenv.make_symbol (Some "code_end") in diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml index 8560d0f9..86b4476c 100644 --- a/asmcomp/power/proc.ml +++ b/asmcomp/power/proc.ml @@ -341,6 +341,26 @@ let op_is_pure = function let num_stack_slots = [| 0; 0 |] let contains_calls = ref false +(* See [reserved_stack_space] in emit.mlp. *) +let reserved_stack_space_required () = + match abi with + | ELF32 -> false + | ELF64v1 | ELF64v2 -> true + +let frame_required () = + let is_elf32 = + match abi with + | ELF32 -> true + | ELF64v1 | ELF64v2 -> false + in + reserved_stack_space_required () + || num_stack_slots.(0) > 0 + || num_stack_slots.(1) > 0 + || (!contains_calls && is_elf32) + +let prologue_required () = + frame_required () + (* Calling the assembler *) let assemble_file infile outfile = diff --git a/asmcomp/power/selection.ml b/asmcomp/power/selection.ml index e62b0b89..6e97feba 100644 --- a/asmcomp/power/selection.ml +++ b/asmcomp/power/selection.ml @@ -27,11 +27,11 @@ type addressing_expr = | Aadd of expression * expression let rec select_addr = function - Cconst_symbol s -> + Cconst_symbol (s, _) -> (Asymbol s, 0, Debuginfo.none) - | Cop((Caddi | Caddv | Cadda), [arg; Cconst_int m], dbg) -> + | Cop((Caddi | Caddv | Cadda), [arg; Cconst_int (m, _)], dbg) -> let (a, n, _) = select_addr arg in (a, n + m, dbg) - | Cop((Caddi | Caddv | Cadda), [Cconst_int m; arg], dbg) -> + | Cop((Caddi | Caddv | Cadda), [Cconst_int (m, _); arg], dbg) -> let (a, n, _) = select_addr arg in (a, n + m, dbg) | Cop((Caddi | Caddv | Cadda), [arg1; arg2], dbg) -> begin match (select_addr arg1, select_addr arg2) with @@ -82,9 +82,9 @@ method! select_operation op args dbg = super#select_operation op args dbg method select_logical op = function - [arg; Cconst_int n] when n >= 0 && n <= 0xFFFF -> + [arg; Cconst_int (n, _)] when n >= 0 && n <= 0xFFFF -> (Iintop_imm(op, n), [arg]) - | [Cconst_int n; arg] when n >= 0 && n <= 0xFFFF -> + | [Cconst_int (n, _); arg] when n >= 0 && n <= 0xFFFF -> (Iintop_imm(op, n), [arg]) | args -> (Iintop op, args) diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml deleted file mode 100644 index 954fecf8..00000000 --- a/asmcomp/printclambda.ml +++ /dev/null @@ -1,271 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - - -open Format -open Asttypes -open Clambda - -module V = Backend_var -module VP = Backend_var.With_provenance - -let mutable_flag = function - | Mutable-> "[mut]" - | Immutable -> "" - -let value_kind = - let open Lambda in - function - | Pgenval -> "" - | Pintval -> ":int" - | Pfloatval -> ":float" - | Pboxedintval Pnativeint -> ":nativeint" - | Pboxedintval Pint32 -> ":int32" - | Pboxedintval Pint64 -> ":int64" - -let rec structured_constant ppf = function - | Uconst_float x -> fprintf ppf "%F" x - | Uconst_int32 x -> fprintf ppf "%ldl" x - | Uconst_int64 x -> fprintf ppf "%LdL" x - | Uconst_nativeint x -> fprintf ppf "%ndn" x - | Uconst_block (tag, l) -> - fprintf ppf "block(%i" tag; - List.iter (fun u -> fprintf ppf ",%a" uconstant u) l; - fprintf ppf ")" - | Uconst_float_array [] -> - fprintf ppf "floatarray()" - | Uconst_float_array (f1 :: fl) -> - fprintf ppf "floatarray(%F" f1; - List.iter (fun f -> fprintf ppf ",%F" f) fl; - fprintf ppf ")" - | Uconst_string s -> fprintf ppf "%S" s - | Uconst_closure(clos, sym, fv) -> - let funs ppf = - List.iter (fprintf ppf "@ %a" one_fun) in - let sconsts ppf scl = - List.iter (fun sc -> fprintf ppf "@ %a" uconstant sc) scl in - fprintf ppf "@[<2>(const_closure%a %s@ %a)@]" funs clos sym sconsts fv - -and one_fun ppf f = - let idents ppf = - List.iter - (fun (x, k) -> - fprintf ppf "@ %a%a" - VP.print x - Printlambda.value_kind k - ) - in - fprintf ppf "(fun@ %s%s@ %d@ @[<2>%a@]@ @[<2>%a@])" - f.label (value_kind f.return) f.arity idents f.params lam f.body - -and phantom_defining_expr ppf = function - | Uphantom_const const -> uconstant ppf const - | Uphantom_var var -> Ident.print ppf var - | Uphantom_offset_var { var; offset_in_words; } -> - Format.fprintf ppf "%a+(%d)" Backend_var.print var offset_in_words - | Uphantom_read_field { var; field; } -> - Format.fprintf ppf "%a[%d]" Backend_var.print var field - | Uphantom_read_symbol_field { sym; field; } -> - Format.fprintf ppf "%s[%d]" sym field - | Uphantom_block { tag; fields; } -> - Format.fprintf ppf "[%d: " tag; - List.iter (fun field -> - Format.fprintf ppf "%a; " Backend_var.print field) - fields; - Format.fprintf ppf "]" - -and phantom_defining_expr_opt ppf = function - | None -> Format.fprintf ppf "DEAD" - | Some expr -> phantom_defining_expr ppf expr - -and uconstant ppf = function - | Uconst_ref (s, Some c) -> - fprintf ppf "%S=%a" s structured_constant c - | Uconst_ref (s, None) -> fprintf ppf "%S"s - | Uconst_int i -> fprintf ppf "%i" i - | Uconst_ptr i -> fprintf ppf "%ia" i - -and lam ppf = function - | Uvar id -> - V.print ppf id - | Uconst c -> uconstant ppf c - | Udirect_apply(f, largs, _) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(apply*@ %s %a)@]" f lams largs - | Ugeneric_apply(lfun, largs, _) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs - | Uclosure(clos, fv) -> - let funs ppf = - List.iter (fprintf ppf "@ @[<2>%a@]" one_fun) in - let lams ppf = - List.iter (fprintf ppf "@ %a" lam) in - fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv - | Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i - | Ulet(mut, kind, id, arg, body) -> - let rec letbody ul = match ul with - | Ulet(mut, kind, id, arg, body) -> - fprintf ppf "@ @[<2>%a%s%s@ %a@]" - VP.print id - (mutable_flag mut) (value_kind kind) lam arg; - letbody body - | _ -> ul in - fprintf ppf "@[<2>(let@ @[(@[<2>%a%s%s@ %a@]" - VP.print id (mutable_flag mut) - (value_kind kind) lam arg; - let expr = letbody body in - fprintf ppf ")@]@ %a)@]" lam expr - | Uphantom_let (id, defining_expr, body) -> - let rec letbody ul = match ul with - | Uphantom_let (id, defining_expr, body) -> - fprintf ppf "@ @[<2>%a@ %a@]" - Backend_var.With_provenance.print id - phantom_defining_expr_opt defining_expr; - letbody body - | _ -> ul in - fprintf ppf "@[<2>(phantom_let@ @[(@[<2>%a@ %a@]" - Backend_var.With_provenance.print id - phantom_defining_expr_opt defining_expr; - let expr = letbody body in - fprintf ppf ")@]@ %a)@]" lam expr - | Uletrec(id_arg_list, body) -> - let bindings ppf id_arg_list = - let spc = ref false in - List.iter - (fun (id, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<2>%a@ %a@]" - VP.print id - lam l) - id_arg_list in - fprintf ppf - "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body - | Uprim(prim, largs, _) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(%a%a)@]" Printlambda.primitive prim lams largs - | Uswitch(larg, sw, _dbg) -> - let print_case tag index i ppf = - for j = 0 to Array.length index - 1 do - if index.(j) = i then fprintf ppf "case %s %i:" tag j - done in - let print_cases tag index cases ppf = - for i = 0 to Array.length cases - 1 do - fprintf ppf "@ @[<2>%t@ %a@]" - (print_case tag index i) sequence cases.(i) - done in - let switch ppf sw = - print_cases "int" sw.us_index_consts sw.us_actions_consts ppf ; - print_cases "tag" sw.us_index_blocks sw.us_actions_blocks ppf in - fprintf ppf - "@[@[<2>(switch@ %a@ @]%a)@]" - lam larg switch sw - | Ustringswitch(larg,sw,d) -> - let switch ppf sw = - let spc = ref false in - List.iter - (fun (s,l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case \"%s\":@ %a@]" - (String.escaped s) lam l) - sw ; - begin match d with - | Some d -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam d - | None -> () - end in - fprintf ppf - "@[<1>(switch %a@ @[%a@])@]" lam larg switch sw - | Ustaticfail (i, ls) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls; - | Ucatch(i, vars, lbody, lhandler) -> - fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" - lam lbody i - (fun ppf vars -> - List.iter - (fun (x, k) -> - fprintf ppf " %a%a" - VP.print x - Printlambda.value_kind k - ) - vars - ) - vars - lam lhandler - | Utrywith(lbody, param, lhandler) -> - fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" - lam lbody VP.print param lam lhandler - | Uifthenelse(lcond, lif, lelse) -> - fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse - | Usequence(l1, l2) -> - fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 - | Uwhile(lcond, lbody) -> - fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody - | Ufor(param, lo, hi, dir, body) -> - fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" - VP.print param lam lo - (match dir with Upto -> "to" | Downto -> "downto") - lam hi lam body - | Uassign(id, expr) -> - fprintf ppf "@[<2>(assign@ %a@ %a)@]" V.print id lam expr - | Usend (k, met, obj, largs, _) -> - let args ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - let kind = - if k = Lambda.Self then "self" - else if k = Lambda.Cached then "cache" - else "" in - fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs - | Uunreachable -> - fprintf ppf "unreachable" - -and sequence ppf ulam = match ulam with - | Usequence(l1, l2) -> - fprintf ppf "%a@ %a" sequence l1 sequence l2 - | _ -> lam ppf ulam - -let clambda ppf ulam = - fprintf ppf "%a@." lam ulam - - -let rec approx ppf = function - Value_closure(fundesc, a) -> - Format.fprintf ppf "@[<2>function %s@ arity %i" - fundesc.fun_label fundesc.fun_arity; - if fundesc.fun_closed then begin - Format.fprintf ppf "@ (closed)" - end; - if fundesc.fun_inline <> None then begin - Format.fprintf ppf "@ (inline)" - end; - Format.fprintf ppf "@ -> @ %a@]" approx a - | Value_tuple a -> - let tuple ppf a = - for i = 0 to Array.length a - 1 do - if i > 0 then Format.fprintf ppf ";@ "; - Format.fprintf ppf "%i: %a" i approx a.(i) - done in - Format.fprintf ppf "@[(%a)@]" tuple a - | Value_unknown -> - Format.fprintf ppf "_" - | Value_const c -> - fprintf ppf "@[const(%a)@]" uconstant c - | Value_global_field (s, i) -> - fprintf ppf "@[global(%s,%i)@]" s i diff --git a/asmcomp/printclambda.mli b/asmcomp/printclambda.mli deleted file mode 100644 index 121667e2..00000000 --- a/asmcomp/printclambda.mli +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Clambda -open Format - -val clambda: formatter -> ulambda -> unit -val approx: formatter -> value_approximation -> unit -val structured_constant: formatter -> ustructured_constant -> unit - -val phantom_defining_expr_opt - : formatter - -> uphantom_defining_expr option - -> unit diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index c485eec1..7be55c2f 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -143,16 +143,16 @@ let operation d = function | Ccheckbound -> "checkbound" ^ Debuginfo.to_string d let rec expr ppf = function - | Cconst_int n -> fprintf ppf "%i" n - | Cconst_natint n -> + | Cconst_int (n, _dbg) -> fprintf ppf "%i" n + | Cconst_natint (n, _dbg) -> fprintf ppf "%s" (Nativeint.to_string n) | Cblockheader(n, d) -> fprintf ppf "block-hdr(%s)%s" (Nativeint.to_string n) (Debuginfo.to_string d) - | Cconst_float n -> fprintf ppf "%F" n - | Cconst_symbol s -> fprintf ppf "\"%s\"" s - | Cconst_pointer n -> fprintf ppf "%ia" n - | Cconst_natpointer n -> fprintf ppf "%sa" (Nativeint.to_string n) + | Cconst_float (n, _dbg) -> fprintf ppf "%F" n + | Cconst_symbol (s, _dbg) -> fprintf ppf "\"%s\"" s + | Cconst_pointer (n, _dbg) -> fprintf ppf "%ia" n + | Cconst_natpointer (n, _dbg) -> fprintf ppf "%sa" (Nativeint.to_string n) | Cvar id -> V.print ppf id | Clet(id, def, (Clet(_, _, _) as body)) -> let print_binding id ppf def = @@ -211,7 +211,7 @@ let rec expr ppf = function fprintf ppf ")@]" | Csequence(e1, e2) -> fprintf ppf "@[<2>(seq@ %a@ %a)@]" sequence e1 sequence e2 - | Cifthenelse(e1, e2, e3) -> + | Cifthenelse(e1, _e2_dbg, e2, _e3_dbg, e3, _dbg) -> fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" expr e1 expr e2 expr e3 | Cswitch(e1, index, cases, _dbg) -> let print_case i ppf = @@ -220,13 +220,11 @@ let rec expr ppf = function done in let print_cases ppf = for i = 0 to Array.length cases - 1 do - fprintf ppf "@ @[<2>%t@ %a@]" (print_case i) sequence cases.(i) + fprintf ppf "@ @[<2>%t@ %a@]" (print_case i) sequence (fst cases.(i)) done in fprintf ppf "@[@[<2>(switch@ %a@ @]%t)@]" expr e1 print_cases - | Cloop e -> - fprintf ppf "@[<2>(loop@ %a)@]" sequence e | Ccatch(flag, handlers, e1) -> - let print_handler ppf (i, ids, e2) = + let print_handler ppf (i, ids, e2, _dbg) = fprintf ppf "(%d%a)@ %a" i (fun ppf ids -> @@ -249,7 +247,7 @@ let rec expr ppf = function fprintf ppf "@[<2>(exit %d" i; List.iter (fun e -> fprintf ppf "@ %a" expr e) el; fprintf ppf ")@]" - | Ctrywith(e1, id, e2) -> + | Ctrywith(e1, id, e2, _dbg) -> fprintf ppf "@[<2>(try@ %a@;<1 -2>with@ %a@ %a)@]" sequence e1 VP.print id sequence e2 diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml index 69557687..4e62fc6f 100644 --- a/asmcomp/printlinear.ml +++ b/asmcomp/printlinear.ml @@ -59,10 +59,10 @@ let instr ppf i = fprintf ppf "case %i: goto %a" i label lblv.(i) done; fprintf ppf "@,endswitch" - | Lsetuptrap lbl -> - fprintf ppf "setup trap %a" label lbl - | Lpushtrap -> - fprintf ppf "push trap" + | Lentertrap -> + fprintf ppf "enter trap" + | Lpushtrap { lbl_handler; } -> + fprintf ppf "push trap %a" label lbl_handler | Lpoptrap -> fprintf ppf "pop trap" | Lraise k -> diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index 6ef11ce3..d90e302d 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -207,8 +207,6 @@ let rec instr ppf i = fprintf ppf "@]@,%a@]" instr cases.(i) done; fprintf ppf "@,endswitch" - | Iloop(body) -> - fprintf ppf "@[loop@,%a@;<0 -2>endloop@]" instr body | Icatch(flag, handlers, body) -> fprintf ppf "@[catch%a@,%a@;<0 -2>with" Printcmm.rec_flag flag instr body; diff --git a/asmcomp/proc.mli b/asmcomp/proc.mli index 2074d619..4e0e0364 100644 --- a/asmcomp/proc.mli +++ b/asmcomp/proc.mli @@ -67,6 +67,10 @@ val op_is_pure: Mach.operation -> bool (* Info for laying out the stack frame *) val num_stack_slots: int array val contains_calls: bool ref +val frame_required : unit -> bool + +(* Function prologues *) +val prologue_required : unit -> bool (** For a given register class, the DWARF register numbering for that class. Given an allocated register with location [Reg n] and class [reg_class], the diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml index d2bf9150..b1f260c1 100644 --- a/asmcomp/reloadgen.ml +++ b/asmcomp/reloadgen.ml @@ -110,8 +110,6 @@ method private reload i = insert_moves i.arg newarg (instr_cons (Iswitch(index, Array.map (self#reload) cases)) newarg [||] (self#reload i.next)) - | Iloop body -> - instr_cons (Iloop(self#reload body)) [||] [||] (self#reload i.next) | Icatch(rec_flag, handlers, body) -> let new_handlers = List.map (fun (nfail, handler) -> nfail, self#reload handler) diff --git a/asmcomp/s390x/emit.mlp b/asmcomp/s390x/emit.mlp index f422ad29..619b454f 100644 --- a/asmcomp/s390x/emit.mlp +++ b/asmcomp/s390x/emit.mlp @@ -308,11 +308,11 @@ let emit_instr i = match i.desc with Lend -> () | Lprologue -> + assert (Proc.prologue_required ()); let n = frame_size() in emit_stack_adjust n; if !contains_calls then - ` stg %r14, {emit_int(n - size_addr)}(%r15)\n`; - `{emit_label !tailrec_entry_point}:\n`; + ` stg %r14, {emit_int(n - size_addr)}(%r15)\n` | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in if src.loc <> dst.loc then begin @@ -608,11 +608,12 @@ let emit_instr i = ` .long {emit_label jumptbl.(i)} - {emit_label lbl}\n` done; emit_string code_space - | Lsetuptrap lbl -> - ` brasl %r14, {emit_label lbl}\n`; - | Lpushtrap -> + | Lentertrap -> + () + | Lpushtrap { lbl_handler; } -> stack_offset := !stack_offset + 16; emit_stack_adjust 16; + ` larl %r14, {emit_label lbl_handler}\n`; ` stg %r14, 0(%r15)\n`; ` stg %r13, {emit_int size_addr}(%r15)\n`; ` lgr %r13, %r15\n` @@ -647,7 +648,7 @@ let rec emit_all i = let fundecl fundecl = function_name := fundecl.fun_name; - tailrec_entry_point := new_label(); + tailrec_entry_point := fundecl.fun_tailrec_entry_point_label; stack_offset := 0; call_gc_sites := []; bound_error_sites := []; diff --git a/asmcomp/s390x/proc.ml b/asmcomp/s390x/proc.ml index 9b359b19..db2b0c04 100644 --- a/asmcomp/s390x/proc.ml +++ b/asmcomp/s390x/proc.ml @@ -228,6 +228,14 @@ let op_is_pure = function let num_stack_slots = [| 0; 0 |] let contains_calls = ref false +let frame_required () = + !contains_calls + || num_stack_slots.(0) > 0 + || num_stack_slots.(1) > 0 + +let prologue_required () = + frame_required () + (* Calling the assembler *) let assemble_file infile outfile = diff --git a/asmcomp/s390x/selection.ml b/asmcomp/s390x/selection.ml index 44ab1f9d..760719b5 100644 --- a/asmcomp/s390x/selection.ml +++ b/asmcomp/s390x/selection.ml @@ -30,9 +30,9 @@ type addressing_expr = | Aadd of expression * expression let rec select_addr = function - | Cop((Caddi | Cadda | Caddv), [arg; Cconst_int m], _) -> + | Cop((Caddi | Cadda | Caddv), [arg; Cconst_int (m, _)], _) -> let (a, n) = select_addr arg in (a, n + m) - | Cop((Caddi | Cadda | Caddv), [Cconst_int m; arg], _) -> + | Cop((Caddi | Cadda | Caddv), [Cconst_int (m, _); arg], _) -> let (a, n) = select_addr arg in (a, n + m) | Cop((Caddi | Cadda | Caddv), [arg1; arg2], _) -> begin match (select_addr arg1, select_addr arg2) with @@ -97,23 +97,23 @@ method! select_operation op args dbg = super#select_operation op args dbg method select_logical op lo hi = function - [arg; Cconst_int n] when n >= lo && n <= hi -> + [arg; Cconst_int (n, _)] when n >= lo && n <= hi -> (Iintop_imm(op, n), [arg]) - | [Cconst_int n; arg] when n >= lo && n <= hi -> + | [Cconst_int (n, _); arg] when n >= lo && n <= hi -> (Iintop_imm(op, n), [arg]) | args -> (Iintop op, args) -method! insert_op_debug op dbg rs rd = +method! insert_op_debug env op dbg rs rd = try let (rsrc, rdst) = pseudoregs_for_operation op rs rd in - self#insert_moves rs rsrc; - self#insert_debug (Iop op) dbg rsrc rdst; - self#insert_moves rdst rd; + self#insert_moves env rs rsrc; + self#insert_debug env (Iop op) dbg rsrc rdst; + self#insert_moves env rdst rd; rd with Use_default -> - super#insert_op_debug op dbg rs rd + super#insert_op_debug env op dbg rs rd end diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml index c640f7f7..41484228 100644 --- a/asmcomp/schedgen.ml +++ b/asmcomp/schedgen.ml @@ -360,7 +360,8 @@ method schedule_fundecl f = let rec schedule i try_nesting = match i.desc with | Lend -> i - | Lpushtrap -> { i with next = schedule i.next (try_nesting + 1) } + | Lpushtrap { lbl_handler = _; } + -> { i with next = schedule i.next (try_nesting + 1) } | Lpoptrap -> { i with next = schedule i.next (try_nesting - 1) } | _ -> if self#instr_in_basic_block i try_nesting then begin @@ -383,7 +384,7 @@ method schedule_fundecl f = self#reschedule ready_queue 0 (schedule i try_nesting) end in - if f.fun_fast then begin + if f.fun_fast && !Clflags.insn_sched then begin let new_body = schedule f.fun_body 0 in clear_code_dag(); { fun_name = f.fun_name; @@ -391,6 +392,7 @@ method schedule_fundecl f = fun_fast = f.fun_fast; fun_dbg = f.fun_dbg; fun_spacetime_shape = f.fun_spacetime_shape; + fun_tailrec_entry_point_label = f.fun_tailrec_entry_point_label; } end else f diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 302115c7..ea59ad22 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -138,7 +138,7 @@ let name_regs id rv = (* "Join" two instruction sequences, making sure they return their results in the same registers. *) -let join opt_r1 seq1 opt_r2 seq2 = +let join env opt_r1 seq1 opt_r2 seq2 = match (opt_r1, opt_r2) with (None, _) -> opt_r2 | (_, None) -> opt_r1 @@ -151,24 +151,24 @@ let join opt_r1 seq1 opt_r2 seq2 = && Cmm.ge_component r1.(i).typ r2.(i).typ then begin r.(i) <- r1.(i); - seq2#insert_move r2.(i) r1.(i) + seq2#insert_move env r2.(i) r1.(i) end else if Reg.anonymous r2.(i) && Cmm.ge_component r2.(i).typ r1.(i).typ then begin r.(i) <- r2.(i); - seq1#insert_move r1.(i) r2.(i) + seq1#insert_move env r1.(i) r2.(i) end else begin let typ = Cmm.lub_component r1.(i).typ r2.(i).typ in r.(i) <- Reg.create typ; - seq1#insert_move r1.(i) r.(i); - seq2#insert_move r2.(i) r.(i) + seq1#insert_move env r1.(i) r.(i); + seq2#insert_move env r2.(i) r.(i) end done; Some r (* Same, for N branches *) -let join_array rs = +let join_array env rs = let some_res = ref None in for i = 0 to Array.length rs - 1 do let (r, _) = rs.(i) in @@ -195,7 +195,7 @@ let join_array rs = let (r, s) = rs.(i) in match r with None -> () - | Some r -> s#insert_moves r res + | Some r -> s#insert_moves env r res done; Some res @@ -309,7 +309,7 @@ method is_simple_expr = function | Cabsf | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Ccmpf _ | Ccheckbound -> List.for_all self#is_simple_expr args end - | Cassign _ | Cifthenelse _ | Cswitch _ | Cloop _ | Ccatch _ | Cexit _ + | Cassign _ | Cifthenelse _ | Cswitch _ | Ccatch _ | Cexit _ | Ctrywith _ -> false (* Analyses the effects and coeffects of an expression. This is used across @@ -336,7 +336,7 @@ method effects_of exp = | Cphantom_let (_var, _defining_expr, body) -> self#effects_of body | Csequence (e1, e2) -> EC.join (self#effects_of e1) (self#effects_of e2) - | Cifthenelse (cond, ifso, ifnot) -> + | Cifthenelse (cond, _ifso_dbg, ifso, _ifnot_dbg, ifnot, _dbg) -> EC.join (self#effects_of cond) (EC.join (self#effects_of ifso) (self#effects_of ifnot)) | Cop (op, args, _) -> @@ -354,7 +354,7 @@ method effects_of exp = EC.none in EC.join from_op (EC.join_list_map args self#effects_of) - | Cassign _ | Cswitch _ | Cloop _ | Ccatch _ | Cexit _ | Ctrywith _ -> + | Cassign _ | Cswitch _ | Ccatch _ | Cexit _ | Ctrywith _ -> EC.arbitrary (* Says whether an integer constant is a suitable immediate argument *) @@ -414,7 +414,7 @@ method select_checkbound_extra_args () = [] method select_operation op args _dbg = match (op, args) with - | (Capply _, Cconst_symbol func :: rem) -> + | (Capply _, Cconst_symbol (func, _dbg) :: rem) -> let label_after = Cmm.new_label () in (Icall_imm { func; label_after; }, rem) | (Capply _, _) -> @@ -477,39 +477,39 @@ method select_operation op args _dbg = | _ -> Misc.fatal_error "Selection.select_oper" method private select_arith_comm op = function - [arg; Cconst_int n] when self#is_immediate n -> + [arg; Cconst_int (n, _)] when self#is_immediate n -> (Iintop_imm(op, n), [arg]) - | [arg; Cconst_pointer n] when self#is_immediate n -> + | [arg; Cconst_pointer (n, _)] when self#is_immediate n -> (Iintop_imm(op, n), [arg]) - | [Cconst_int n; arg] when self#is_immediate n -> + | [Cconst_int (n, _); arg] when self#is_immediate n -> (Iintop_imm(op, n), [arg]) - | [Cconst_pointer n; arg] when self#is_immediate n -> + | [Cconst_pointer (n, _); arg] when self#is_immediate n -> (Iintop_imm(op, n), [arg]) | args -> (Iintop op, args) method private select_arith op = function - [arg; Cconst_int n] when self#is_immediate n -> + [arg; Cconst_int (n, _)] when self#is_immediate n -> (Iintop_imm(op, n), [arg]) - | [arg; Cconst_pointer n] when self#is_immediate n -> + | [arg; Cconst_pointer (n, _)] when self#is_immediate n -> (Iintop_imm(op, n), [arg]) | args -> (Iintop op, args) method private select_shift op = function - [arg; Cconst_int n] when n >= 0 && n < Arch.size_int * 8 -> + [arg; Cconst_int (n, _)] when n >= 0 && n < Arch.size_int * 8 -> (Iintop_imm(op, n), [arg]) | args -> (Iintop op, args) method private select_arith_comp cmp = function - [arg; Cconst_int n] when self#is_immediate n -> + [arg; Cconst_int (n, _)] when self#is_immediate n -> (Iintop_imm(Icomp cmp, n), [arg]) - | [arg; Cconst_pointer n] when self#is_immediate n -> + | [arg; Cconst_pointer (n, _)] when self#is_immediate n -> (Iintop_imm(Icomp cmp, n), [arg]) - | [Cconst_int n; arg] when self#is_immediate n -> + | [Cconst_int (n, _); arg] when self#is_immediate n -> (Iintop_imm(Icomp(swap_intcomp cmp), n), [arg]) - | [Cconst_pointer n; arg] when self#is_immediate n -> + | [Cconst_pointer (n, _); arg] when self#is_immediate n -> (Iintop_imm(Icomp(swap_intcomp cmp), n), [arg]) | args -> (Iintop(Icomp cmp), args) @@ -517,29 +517,29 @@ method private select_arith_comp cmp = function (* Instruction selection for conditionals *) method select_condition = function - Cop(Ccmpi cmp, [arg1; Cconst_int n], _) when self#is_immediate n -> + Cop(Ccmpi cmp, [arg1; Cconst_int (n, _)], _) when self#is_immediate n -> (Iinttest_imm(Isigned cmp, n), arg1) - | Cop(Ccmpi cmp, [Cconst_int n; arg2], _) when self#is_immediate n -> + | Cop(Ccmpi cmp, [Cconst_int (n, _); arg2], _) when self#is_immediate n -> (Iinttest_imm(Isigned(swap_integer_comparison cmp), n), arg2) - | Cop(Ccmpi cmp, [arg1; Cconst_pointer n], _) when self#is_immediate n -> + | Cop(Ccmpi cmp, [arg1; Cconst_pointer (n, _)], _) when self#is_immediate n -> (Iinttest_imm(Isigned cmp, n), arg1) - | Cop(Ccmpi cmp, [Cconst_pointer n; arg2], _) when self#is_immediate n -> + | Cop(Ccmpi cmp, [Cconst_pointer (n, _); arg2], _) when self#is_immediate n -> (Iinttest_imm(Isigned(swap_integer_comparison cmp), n), arg2) | Cop(Ccmpi cmp, args, _) -> (Iinttest(Isigned cmp), Ctuple args) - | Cop(Ccmpa cmp, [arg1; Cconst_pointer n], _) when self#is_immediate n -> + | Cop(Ccmpa cmp, [arg1; Cconst_pointer (n, _)], _) when self#is_immediate n -> (Iinttest_imm(Iunsigned cmp, n), arg1) - | Cop(Ccmpa cmp, [arg1; Cconst_int n], _) when self#is_immediate n -> + | Cop(Ccmpa cmp, [arg1; Cconst_int (n, _)], _) when self#is_immediate n -> (Iinttest_imm(Iunsigned cmp, n), arg1) - | Cop(Ccmpa cmp, [Cconst_pointer n; arg2], _) when self#is_immediate n -> + | Cop(Ccmpa cmp, [Cconst_pointer (n, _); arg2], _) when self#is_immediate n -> (Iinttest_imm(Iunsigned(swap_integer_comparison cmp), n), arg2) - | Cop(Ccmpa cmp, [Cconst_int n; arg2], _) when self#is_immediate n -> + | Cop(Ccmpa cmp, [Cconst_int (n, _); arg2], _) when self#is_immediate n -> (Iinttest_imm(Iunsigned(swap_integer_comparison cmp), n), arg2) | Cop(Ccmpa cmp, args, _) -> (Iinttest(Iunsigned cmp), Ctuple args) | Cop(Ccmpf cmp, args, _) -> (Ifloattest cmp, Ctuple args) - | Cop(Cand, [arg; Cconst_int 1], _) -> + | Cop(Cand, [arg; Cconst_int (1, _)], _) -> (Ioddtest, arg) | arg -> (Itruetest, arg) @@ -555,10 +555,10 @@ method regs_for tys = Reg.createv tys val mutable instr_seq = dummy_instr -method insert_debug desc dbg arg res = +method insert_debug _env desc dbg arg res = instr_seq <- instr_cons_debug desc arg res dbg instr_seq -method insert desc arg res = +method insert _env desc arg res = instr_seq <- instr_cons desc arg res instr_seq method extract_core ~end_instr = @@ -573,13 +573,13 @@ method extract = (* Insert a sequence of moves from one pseudoreg set to another. *) -method insert_move src dst = +method insert_move env src dst = if src.stamp <> dst.stamp then - self#insert (Iop Imove) [|src|] [|dst|] + self#insert env (Iop Imove) [|src|] [|dst|] -method insert_moves src dst = +method insert_moves env src dst = for i = 0 to min (Array.length src) (Array.length dst) - 1 do - self#insert_move src.(i) dst.(i) + self#insert_move env src.(i) dst.(i) done (* Adjust the types of destination pseudoregs for a [Cassign] assignment. @@ -602,37 +602,41 @@ method adjust_types src dst = (* Insert moves and stack offsets for function arguments and results *) -method insert_move_args arg loc stacksize = - if stacksize <> 0 then self#insert (Iop(Istackoffset stacksize)) [||] [||]; - self#insert_moves arg loc +method insert_move_args env arg loc stacksize = + if stacksize <> 0 then begin + self#insert env (Iop(Istackoffset stacksize)) [||] [||] + end; + self#insert_moves env arg loc -method insert_move_results loc res stacksize = - if stacksize <> 0 then self#insert(Iop(Istackoffset(-stacksize))) [||] [||]; - self#insert_moves loc res +method insert_move_results env loc res stacksize = + if stacksize <> 0 then begin + self#insert env (Iop(Istackoffset(-stacksize))) [||] [||] + end; + self#insert_moves env loc res (* Add an Iop opcode. Can be overridden by processor description to insert moves before and after the operation, i.e. for two-address instructions, or instructions using dedicated registers. *) -method insert_op_debug op dbg rs rd = - self#insert_debug (Iop op) dbg rs rd; +method insert_op_debug env op dbg rs rd = + self#insert_debug env (Iop op) dbg rs rd; rd -method insert_op op rs rd = - self#insert_op_debug op Debuginfo.none rs rd +method insert_op env op rs rd = + self#insert_op_debug env op Debuginfo.none rs rd -method emit_blockheader _env n _dbg = +method emit_blockheader env n _dbg = let r = self#regs_for typ_int in - Some(self#insert_op (Iconst_int n) [||] r) + Some(self#insert_op env (Iconst_int n) [||] r) -method about_to_emit_call _env _insn _arg = None +method about_to_emit_call _env _insn _arg _dbg = None (* Prior to a function call, update the Spacetime node hole pointer hard register. *) -method private maybe_emit_spacetime_move ~spacetime_reg = - Misc.Stdlib.Option.iter (fun reg -> - self#insert_moves reg [| Proc.loc_spacetime_node_hole |]) +method private maybe_emit_spacetime_move env ~spacetime_reg = + Option.iter (fun reg -> + self#insert_moves env reg [| Proc.loc_spacetime_node_hole |]) spacetime_reg (* Add the instructions for the given expression @@ -640,24 +644,24 @@ method private maybe_emit_spacetime_move ~spacetime_reg = method emit_expr (env:environment) exp = match exp with - Cconst_int n -> + Cconst_int (n, _dbg) -> let r = self#regs_for typ_int in - Some(self#insert_op (Iconst_int(Nativeint.of_int n)) [||] r) - | Cconst_natint n -> + Some(self#insert_op env (Iconst_int(Nativeint.of_int n)) [||] r) + | Cconst_natint (n, _dbg) -> let r = self#regs_for typ_int in - Some(self#insert_op (Iconst_int n) [||] r) - | Cconst_float n -> + Some(self#insert_op env (Iconst_int n) [||] r) + | Cconst_float (n, _dbg) -> let r = self#regs_for typ_float in - Some(self#insert_op (Iconst_float (Int64.bits_of_float n)) [||] r) - | Cconst_symbol n -> + Some(self#insert_op env (Iconst_float (Int64.bits_of_float n)) [||] r) + | Cconst_symbol (n, _dbg) -> let r = self#regs_for typ_val in - Some(self#insert_op (Iconst_symbol n) [||] r) - | Cconst_pointer n -> + Some(self#insert_op env (Iconst_symbol n) [||] r) + | Cconst_pointer (n, _dbg) -> let r = self#regs_for typ_val in (* integer as Caml value *) - Some(self#insert_op (Iconst_int(Nativeint.of_int n)) [||] r) - | Cconst_natpointer n -> + Some(self#insert_op env (Iconst_int(Nativeint.of_int n)) [||] r) + | Cconst_natpointer (n, _dbg) -> let r = self#regs_for typ_val in (* integer as Caml value *) - Some(self#insert_op (Iconst_int n) [||] r) + Some(self#insert_op env (Iconst_int n) [||] r) | Cblockheader(n, dbg) -> self#emit_blockheader env n dbg | Cvar v -> @@ -681,7 +685,8 @@ method emit_expr (env:environment) exp = Misc.fatal_error ("Selection.emit_expr: unbound var " ^ V.name v) in begin match self#emit_expr env e1 with None -> None - | Some r1 -> self#adjust_types r1 rv; self#insert_moves r1 rv; Some [||] + | Some r1 -> + self#adjust_types r1 rv; self#insert_moves env r1 rv; Some [||] end | Ctuple [] -> Some [||] @@ -696,12 +701,16 @@ method emit_expr (env:environment) exp = None -> None | Some r1 -> let rd = [|Proc.loc_exn_bucket|] in - self#insert (Iop Imove) r1 rd; - self#insert_debug (Iraise k) dbg rd [||]; + self#insert env (Iop Imove) r1 rd; + self#insert_debug env (Iraise k) dbg rd [||]; None end - | Cop(Ccmpf _, _, _) -> - self#emit_expr env (Cifthenelse(exp, Cconst_int 1, Cconst_int 0)) + | Cop(Ccmpf _, _, dbg) -> + self#emit_expr env + (Cifthenelse (exp, + dbg, Cconst_int (1, dbg), + dbg, Cconst_int (0, dbg), + dbg)) | Cop(op, args, dbg) -> begin match self#emit_parts_list env args with None -> None @@ -716,13 +725,13 @@ method emit_expr (env:environment) exp = let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in let loc_res = Proc.loc_results rd in let spacetime_reg = - self#about_to_emit_call env (Iop new_op) [| r1.(0) |] + self#about_to_emit_call env (Iop new_op) [| r1.(0) |] dbg in - self#insert_move_args rarg loc_arg stack_ofs; - self#maybe_emit_spacetime_move ~spacetime_reg; - self#insert_debug (Iop new_op) dbg + self#insert_move_args env rarg loc_arg stack_ofs; + self#maybe_emit_spacetime_move env ~spacetime_reg; + self#insert_debug env (Iop new_op) dbg (Array.append [|r1.(0)|] loc_arg) loc_res; - self#insert_move_results loc_res rd stack_ofs; + self#insert_move_results env loc_res rd stack_ofs; Some rd | Icall_imm _ -> let r1 = self#emit_tuple env new_args in @@ -730,24 +739,24 @@ method emit_expr (env:environment) exp = let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in let loc_res = Proc.loc_results rd in let spacetime_reg = - self#about_to_emit_call env (Iop new_op) [| |] + self#about_to_emit_call env (Iop new_op) [| |] dbg in - self#insert_move_args r1 loc_arg stack_ofs; - self#maybe_emit_spacetime_move ~spacetime_reg; - self#insert_debug (Iop new_op) dbg loc_arg loc_res; - self#insert_move_results loc_res rd stack_ofs; + self#insert_move_args env r1 loc_arg stack_ofs; + self#maybe_emit_spacetime_move env ~spacetime_reg; + self#insert_debug env (Iop new_op) dbg loc_arg loc_res; + self#insert_move_results env loc_res rd stack_ofs; Some rd | Iextcall _ -> let spacetime_reg = - self#about_to_emit_call env (Iop new_op) [| |] + self#about_to_emit_call env (Iop new_op) [| |] dbg in let (loc_arg, stack_ofs) = self#emit_extcall_args env new_args in - self#maybe_emit_spacetime_move ~spacetime_reg; + self#maybe_emit_spacetime_move env ~spacetime_reg; let rd = self#regs_for ty in let loc_res = - self#insert_op_debug new_op dbg + self#insert_op_debug env new_op dbg loc_arg (Proc.loc_external_results rd) in - self#insert_move_results loc_res rd stack_ofs; + self#insert_move_results env loc_res rd stack_ofs; Some rd | Ialloc { bytes = _; spacetime_index; label_after_call_gc; } -> let rd = self#regs_for typ_val in @@ -756,28 +765,28 @@ method emit_expr (env:environment) exp = Ialloc { bytes; spacetime_index; label_after_call_gc; } in let args = self#select_allocation_args env in - self#insert_debug (Iop op) dbg args rd; + self#insert_debug env (Iop op) dbg args rd; self#emit_stores env new_args rd; Some rd | op -> let r1 = self#emit_tuple env new_args in let rd = self#regs_for ty in - Some (self#insert_op_debug op dbg r1 rd) + Some (self#insert_op_debug env op dbg r1 rd) end | Csequence(e1, e2) -> begin match self#emit_expr env e1 with None -> None | Some _ -> self#emit_expr env e2 end - | Cifthenelse(econd, eif, eelse) -> + | Cifthenelse(econd, _ifso_dbg, eif, _ifnot_dbg, eelse, _dbg) -> let (cond, earg) = self#select_condition econd in begin match self#emit_expr env earg with None -> None | Some rarg -> let (rif, sif) = self#emit_sequence env eif in let (relse, selse) = self#emit_sequence env eelse in - let r = join rif sif relse selse in - self#insert (Iifthenelse(cond, sif#extract, selse#extract)) + let r = join env rif sif relse selse in + self#insert env (Iifthenelse(cond, sif#extract, selse#extract)) rarg [||]; r end @@ -785,40 +794,38 @@ method emit_expr (env:environment) exp = begin match self#emit_expr env esel with None -> None | Some rsel -> - let rscases = Array.map (self#emit_sequence env) ecases in - let r = join_array rscases in - self#insert (Iswitch(index, - Array.map (fun (_, s) -> s#extract) rscases)) + let rscases = + Array.map (fun (case, _dbg) -> self#emit_sequence env case) ecases + in + let r = join_array env rscases in + self#insert env (Iswitch(index, + Array.map (fun (_, s) -> s#extract) rscases)) rsel [||]; r end - | Cloop(ebody) -> - let (_rarg, sbody) = self#emit_sequence env ebody in - self#insert (Iloop(sbody#extract)) [||] [||]; - Some [||] | Ccatch(_, [], e1) -> self#emit_expr env e1 | Ccatch(rec_flag, handlers, body) -> let handlers = - List.map (fun (nfail, ids, e2) -> + List.map (fun (nfail, ids, e2, dbg) -> let rs = List.map (fun (id, typ) -> let r = self#regs_for typ in name_regs id r; r) ids in - (nfail, ids, rs, e2)) + (nfail, ids, rs, e2, dbg)) handlers in let env = (* Since the handlers may be recursive, and called from the body, the same environment is used for translating both the handlers and the body. *) - List.fold_left (fun env (nfail, _ids, rs, _e2) -> + List.fold_left (fun env (nfail, _ids, rs, _e2, _dbg) -> env_add_static_exception nfail rs env) env handlers in let (r_body, s_body) = self#emit_sequence env body in - let translate_one_handler (nfail, ids, rs, e2) = + let translate_one_handler (nfail, ids, rs, e2, _dbg) = assert(List.length ids = List.length rs); let new_env = List.fold_left (fun env ((id, _typ), r) -> env_add id r env) @@ -829,9 +836,10 @@ method emit_expr (env:environment) exp = in let l = List.map translate_one_handler handlers in let a = Array.of_list ((r_body, s_body) :: List.map snd l) in - let r = join_array a in + let r = join_array env a in let aux (nfail, (_r, s)) = (nfail, s#extract) in - self#insert (Icatch (rec_flag, List.map aux l, s_body#extract)) [||] [||]; + self#insert env (Icatch (rec_flag, List.map aux l, s_body#extract)) + [||] [||]; r | Cexit (nfail,args) -> begin match self#emit_parts_list env args with @@ -849,17 +857,17 @@ method emit_expr (env:environment) exp = let tmp_regs = Reg.createv_like src in (* Ccatch registers must not contain out of heap pointers *) Array.iter (fun reg -> assert(reg.typ <> Addr)) src; - self#insert_moves src tmp_regs ; - self#insert_moves tmp_regs (Array.concat dest_args) ; - self#insert (Iexit nfail) [||] [||]; + self#insert_moves env src tmp_regs ; + self#insert_moves env tmp_regs (Array.concat dest_args) ; + self#insert env (Iexit nfail) [||] [||]; None end - | Ctrywith(e1, v, e2) -> + | Ctrywith(e1, v, e2, _dbg) -> let (r1, s1) = self#emit_sequence env e1 in let rv = self#regs_for typ_val in let (r2, s2) = self#emit_sequence (env_add v rv env) e2 in - let r = join r1 s1 r2 s2 in - self#insert + let r = join env r1 s1 r2 s2 in + self#insert env (Itrywith(s1#extract, instr_cons (Iop Imove) [|Proc.loc_exn_bucket|] rv (s2#extract))) @@ -878,7 +886,7 @@ method private bind_let (env:environment) v r1 = end else begin let rv = Reg.createv_like r1 in name_regs v rv; - self#insert_moves r1 rv; + self#insert_moves env r1 rv; env_add v rv env end @@ -943,7 +951,7 @@ method private emit_parts (env:environment) ~effects_after exp = else begin (* Introduce a fresh temp to hold the result *) let tmp = Reg.createv_like r in - self#insert_moves r tmp; + self#insert_moves env r tmp; Some (Cvar id, env_add (VP.create id) tmp env) end end @@ -997,7 +1005,7 @@ method emit_extcall_args env args = required semantics of [loc_external_arguments] (see proc.mli). *) let args = Array.concat args in let arg_hard_regs = Array.concat (Array.to_list arg_hard_regs) in - self#insert_move_args args arg_hard_regs stack_ofs; + self#insert_move_args env args arg_hard_regs stack_ofs; arg_hard_regs, stack_ofs method emit_stores env data regs_addr = @@ -1014,12 +1022,13 @@ method emit_stores env data regs_addr = for i = 0 to Array.length regs - 1 do let r = regs.(i) in let kind = if r.typ = Float then Double_u else Word_val in - self#insert (Iop(Istore(kind, !a, false))) + self#insert env + (Iop(Istore(kind, !a, false))) (Array.append [|r|] regs_addr) [||]; a := Arch.offset_addressing !a (size_component r.typ) done | _ -> - self#insert (Iop op) (Array.append regs regs_addr) [||]; + self#insert env (Iop op) (Array.append regs regs_addr) [||]; a := Arch.offset_addressing !a (size_expr env e)) data @@ -1030,8 +1039,8 @@ method private emit_return (env:environment) exp = None -> () | Some r -> let loc = Proc.loc_results r in - self#insert_moves r loc; - self#insert Ireturn loc [||] + self#insert_moves env r loc; + self#insert env Ireturn loc [||] method emit_tail (env:environment) exp = match exp with @@ -1055,24 +1064,24 @@ method emit_tail (env:environment) exp = if stack_ofs = 0 then begin let call = Iop (Itailcall_ind { label_after; }) in let spacetime_reg = - self#about_to_emit_call env call [| r1.(0) |] + self#about_to_emit_call env call [| r1.(0) |] dbg in - self#insert_moves rarg loc_arg; - self#maybe_emit_spacetime_move ~spacetime_reg; - self#insert_debug call dbg + self#insert_moves env rarg loc_arg; + self#maybe_emit_spacetime_move env ~spacetime_reg; + self#insert_debug env call dbg (Array.append [|r1.(0)|] loc_arg) [||]; end else begin let rd = self#regs_for ty in let loc_res = Proc.loc_results rd in let spacetime_reg = - self#about_to_emit_call env (Iop new_op) [| r1.(0) |] + self#about_to_emit_call env (Iop new_op) [| r1.(0) |] dbg in - self#insert_move_args rarg loc_arg stack_ofs; - self#maybe_emit_spacetime_move ~spacetime_reg; - self#insert_debug (Iop new_op) dbg + self#insert_move_args env rarg loc_arg stack_ofs; + self#maybe_emit_spacetime_move env ~spacetime_reg; + self#insert_debug env (Iop new_op) dbg (Array.append [|r1.(0)|] loc_arg) loc_res; - self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||]; - self#insert Ireturn loc_res [||] + self#insert env (Iop(Istackoffset(-stack_ofs))) [||] [||]; + self#insert env Ireturn loc_res [||] end | Icall_imm { func; label_after; } -> let r1 = self#emit_tuple env new_args in @@ -1080,31 +1089,31 @@ method emit_tail (env:environment) exp = if stack_ofs = 0 then begin let call = Iop (Itailcall_imm { func; label_after; }) in let spacetime_reg = - self#about_to_emit_call env call [| |] + self#about_to_emit_call env call [| |] dbg in - self#insert_moves r1 loc_arg; - self#maybe_emit_spacetime_move ~spacetime_reg; - self#insert_debug call dbg loc_arg [||]; + self#insert_moves env r1 loc_arg; + self#maybe_emit_spacetime_move env ~spacetime_reg; + self#insert_debug env call dbg loc_arg [||]; end else if func = !current_function_name then begin let call = Iop (Itailcall_imm { func; label_after; }) in let loc_arg' = Proc.loc_parameters r1 in let spacetime_reg = - self#about_to_emit_call env call [| |] + self#about_to_emit_call env call [| |] dbg in - self#insert_moves r1 loc_arg'; - self#maybe_emit_spacetime_move ~spacetime_reg; - self#insert_debug call dbg loc_arg' [||]; + self#insert_moves env r1 loc_arg'; + self#maybe_emit_spacetime_move env ~spacetime_reg; + self#insert_debug env call dbg loc_arg' [||]; end else begin let rd = self#regs_for ty in let loc_res = Proc.loc_results rd in let spacetime_reg = - self#about_to_emit_call env (Iop new_op) [| |] + self#about_to_emit_call env (Iop new_op) [| |] dbg in - self#insert_move_args r1 loc_arg stack_ofs; - self#maybe_emit_spacetime_move ~spacetime_reg; - self#insert_debug (Iop new_op) dbg loc_arg loc_res; - self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||]; - self#insert Ireturn loc_res [||] + self#insert_move_args env r1 loc_arg stack_ofs; + self#maybe_emit_spacetime_move env ~spacetime_reg; + self#insert_debug env (Iop new_op) dbg loc_arg loc_res; + self#insert env (Iop(Istackoffset(-stack_ofs))) [||] [||]; + self#insert env Ireturn loc_res [||] end | _ -> Misc.fatal_error "Selection.emit_tail" end @@ -1113,12 +1122,13 @@ method emit_tail (env:environment) exp = None -> () | Some _ -> self#emit_tail env e2 end - | Cifthenelse(econd, eif, eelse) -> + | Cifthenelse(econd, _ifso_dbg, eif, _ifnot_dbg, eelse, _dbg) -> let (cond, earg) = self#select_condition econd in begin match self#emit_expr env earg with None -> () | Some rarg -> - self#insert (Iifthenelse(cond, self#emit_tail_sequence env eif, + self#insert env + (Iifthenelse(cond, self#emit_tail_sequence env eif, self#emit_tail_sequence env eelse)) rarg [||] end @@ -1126,28 +1136,30 @@ method emit_tail (env:environment) exp = begin match self#emit_expr env esel with None -> () | Some rsel -> - self#insert - (Iswitch(index, Array.map (self#emit_tail_sequence env) ecases)) - rsel [||] + let cases = + Array.map (fun (case, _dbg) -> self#emit_tail_sequence env case) + ecases + in + self#insert env (Iswitch (index, cases)) rsel [||] end | Ccatch(_, [], e1) -> self#emit_tail env e1 | Ccatch(rec_flag, handlers, e1) -> let handlers = - List.map (fun (nfail, ids, e2) -> + List.map (fun (nfail, ids, e2, dbg) -> let rs = List.map (fun (id, typ) -> let r = self#regs_for typ in name_regs id r; r) ids in - (nfail, ids, rs, e2)) + (nfail, ids, rs, e2, dbg)) handlers in let env = - List.fold_left (fun env (nfail, _ids, rs, _e2) -> + List.fold_left (fun env (nfail, _ids, rs, _e2, _dbg) -> env_add_static_exception nfail rs env) env handlers in let s_body = self#emit_tail_sequence env e1 in - let aux (nfail, ids, rs, e2) = + let aux (nfail, ids, rs, e2, _dbg) = assert(List.length ids = List.length rs); let new_env = List.fold_left @@ -1155,12 +1167,13 @@ method emit_tail (env:environment) exp = env (List.combine ids rs) in nfail, self#emit_tail_sequence new_env e2 in - self#insert (Icatch(rec_flag, List.map aux handlers, s_body)) [||] [||] - | Ctrywith(e1, v, e2) -> + self#insert env (Icatch(rec_flag, List.map aux handlers, s_body)) + [||] [||] + | Ctrywith(e1, v, e2, _dbg) -> let (opt_r1, s1) = self#emit_sequence env e1 in let rv = self#regs_for typ_val in let s2 = self#emit_tail_sequence (env_add v rv env) e2 in - self#insert + self#insert env (Itrywith(s1#extract, instr_cons (Iop Imove) [|Proc.loc_exn_bucket|] rv s2)) [||] [||]; @@ -1168,8 +1181,8 @@ method emit_tail (env:environment) exp = None -> () | Some r1 -> let loc = Proc.loc_results r1 in - self#insert_moves r1 loc; - self#insert Ireturn loc [||] + self#insert_moves env r1 loc; + self#insert env Ireturn loc [||] end | _ -> self#emit_return env exp @@ -1181,8 +1194,8 @@ method private emit_tail_sequence env exp = (* Insertion of the function prologue *) -method insert_prologue _f ~loc_arg ~rarg ~spacetime_node_hole:_ ~env:_ = - self#insert_moves loc_arg rarg; +method insert_prologue _f ~loc_arg ~rarg ~spacetime_node_hole:_ ~env = + self#insert_moves env loc_arg rarg; None (* Sequentialization of a function definition *) diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli index 003d7067..87c35be7 100644 --- a/asmcomp/selectgen.mli +++ b/asmcomp/selectgen.mli @@ -88,11 +88,12 @@ class virtual selector_generic : object Can be overridden if float values are stored as pairs of integer registers. *) method insert_op : - Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array + environment -> Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array (* Can be overridden to deal with 2-address instructions or instructions with hardwired input/output registers *) method insert_op_debug : - Mach.operation -> Debuginfo.t -> Reg.t array -> Reg.t array -> Reg.t array + environment -> Mach.operation -> Debuginfo.t -> Reg.t array + -> Reg.t array -> Reg.t array (* Can be overridden to deal with 2-address instructions or instructions with hardwired input/output registers *) method emit_extcall_args : @@ -136,13 +137,17 @@ class virtual selector_generic : object are not always applied to "self", but ideally they should be private. *) method extract : Mach.instruction method extract_core : end_instr:Mach.instruction -> Mach.instruction - method insert : Mach.instruction_desc -> Reg.t array -> Reg.t array -> unit - method insert_debug : Mach.instruction_desc -> Debuginfo.t -> - Reg.t array -> Reg.t array -> unit - method insert_move : Reg.t -> Reg.t -> unit - method insert_move_args : Reg.t array -> Reg.t array -> int -> unit - method insert_move_results : Reg.t array -> Reg.t array -> int -> unit - method insert_moves : Reg.t array -> Reg.t array -> unit + method insert : + environment -> Mach.instruction_desc -> Reg.t array -> Reg.t array -> unit + method insert_debug : + environment -> Mach.instruction_desc -> Debuginfo.t -> + Reg.t array -> Reg.t array -> unit + method insert_move : environment -> Reg.t -> Reg.t -> unit + method insert_move_args : + environment -> Reg.t array -> Reg.t array -> int -> unit + method insert_move_results : + environment -> Reg.t array -> Reg.t array -> int -> unit + method insert_moves : environment -> Reg.t array -> Reg.t array -> unit method adjust_type : Reg.t -> Reg.t -> unit method adjust_types : Reg.t array -> Reg.t array -> unit method emit_expr : @@ -163,6 +168,7 @@ class virtual selector_generic : object : environment -> Mach.instruction_desc -> Reg.t array + -> Debuginfo.t -> Reg.t array option method initial_env : unit -> environment method insert_prologue diff --git a/asmcomp/spacetime_profiling.ml b/asmcomp/spacetime_profiling.ml index acabf7c0..a61cd1c4 100644 --- a/asmcomp/spacetime_profiling.ml +++ b/asmcomp/spacetime_profiling.ml @@ -4,7 +4,7 @@ (* *) (* Mark Shinwell and Leo White, Jane Street Europe *) (* *) -(* Copyright 2015--2017 Jane Street Group LLC *) +(* Copyright 2015--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 *) @@ -12,6 +12,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-30-40-41-42"] + module V = Backend_var module VP = Backend_var.With_provenance @@ -23,11 +25,17 @@ let index_within_node = ref node_num_header_words arch.ml.) *) let spacetime_node = ref (lazy (Cmm.Cvar (V.create_local "dummy"))) let spacetime_node_ident = ref (lazy (V.create_local "dummy")) -let current_function_label = ref "" +let current_function_label = ref None let direct_tail_call_point_indexes = ref [] let reverse_shape = ref ([] : Mach.spacetime_shape) +(* CR-someday mshinwell: This code could be updated to use [placeholder_dbg] as + in [Cmmgen]. *) +let cconst_int i = Cmm.Cconst_int (i, Debuginfo.none) +let cconst_natint i = Cmm.Cconst_natint (i, Debuginfo.none) +let cconst_symbol s = Cmm.Cconst_symbol (s, Debuginfo.none) + let something_was_instrumented () = !index_within_node > node_num_header_words @@ -54,16 +62,15 @@ let reset ~spacetime_node_ident:ident ~function_label = spacetime_node := lazy (Cmm.Cvar ident); spacetime_node_ident := lazy ident; direct_tail_call_point_indexes := []; - current_function_label := function_label; + current_function_label := Some function_label; reverse_shape := [] -let code_for_function_prologue ~function_name ~node_hole = +let code_for_function_prologue ~function_name ~fun_dbg:dbg ~node_hole = let node = V.create_local "node" in let new_node = V.create_local "new_node" in let must_allocate_node = V.create_local "must_allocate_node" in let is_new_node = V.create_local "is_new_node" in let no_tail_calls = List.length !direct_tail_call_point_indexes < 1 in - let dbg = Debuginfo.none in let open Cmm in let initialize_direct_tail_call_points_and_return_node = let new_node_encoded = V.create_local "new_node_encoded" in @@ -77,7 +84,7 @@ let code_for_function_prologue ~function_name ~node_hole = let offset_in_bytes = index * Arch.size_addr in Csequence ( Cop (Cstore (Word_int, Lambda.Assignment), - [Cop (Caddi, [Cvar new_node; Cconst_int offset_in_bytes], dbg); + [Cop (Caddi, [Cvar new_node; cconst_int offset_in_bytes], dbg); Cvar new_node_encoded], dbg), init_code)) (Cvar new_node) @@ -88,22 +95,24 @@ let code_for_function_prologue ~function_name ~node_hole = | _ -> Clet (VP.create new_node_encoded, (* Cf. [Encode_tail_caller_node] in the runtime. *) - Cop (Cor, [Cvar new_node; Cconst_int 1], dbg), + Cop (Cor, [Cvar new_node; cconst_int 1], dbg), body) in let pc = V.create_local "pc" in Clet (VP.create node, Cop (Cload (Word_int, Asttypes.Mutable), [Cvar node_hole], dbg), Clet (VP.create must_allocate_node, - Cop (Cand, [Cvar node; Cconst_int 1], dbg), + Cop (Cand, [Cvar node; cconst_int 1], dbg), Cifthenelse ( - Cop (Ccmpi Cne, [Cvar must_allocate_node; Cconst_int 1], dbg), + Cop (Ccmpi Cne, [Cvar must_allocate_node; cconst_int 1], dbg), + dbg, Cvar node, + dbg, Clet (VP.create is_new_node, - Clet (VP.create pc, Cconst_symbol function_name, + Clet (VP.create pc, cconst_symbol function_name, Cop (Cextcall ("caml_spacetime_allocate_node", [| Int |], false, None), - [Cconst_int (1 (* header *) + !index_within_node); + [cconst_int (1 (* header *) + !index_within_node); Cvar pc; Cvar node_hole; ], @@ -113,9 +122,13 @@ let code_for_function_prologue ~function_name ~node_hole = if no_tail_calls then Cvar new_node else Cifthenelse ( - Cop (Ccmpi Ceq, [Cvar is_new_node; Cconst_int 0], dbg), + Cop (Ccmpi Ceq, [Cvar is_new_node; cconst_int 0], dbg), + dbg, Cvar new_node, - initialize_direct_tail_call_points_and_return_node)))))) + dbg, + initialize_direct_tail_call_points_and_return_node, + dbg))), + dbg))) let code_for_blockheader ~value's_header ~node ~dbg = let num_words = Nativeint.shift_right_logical value's_header 10 in @@ -141,7 +154,7 @@ let code_for_blockheader ~value's_header ~node ~dbg = Cop (Cextcall ("caml_spacetime_generate_profinfo", [| Int |], false, Some label), [Cvar address_of_profinfo; - Cconst_int (index_within_node + 1)], + cconst_int (index_within_node + 1)], dbg) in (* Check if we have already allocated a profinfo value for this allocation @@ -150,30 +163,33 @@ let code_for_blockheader ~value's_header ~node ~dbg = Clet (VP.create address_of_profinfo, Cop (Caddi, [ Cvar node; - Cconst_int offset_into_node; + cconst_int offset_into_node; ], dbg), Clet (VP.create existing_profinfo, Cop (Cload (Word_int, Asttypes.Mutable), [Cvar address_of_profinfo], dbg), Clet (VP.create profinfo, Cifthenelse ( - Cop (Ccmpi Cne, [Cvar existing_profinfo; Cconst_int 1 (* () *)], dbg), + Cop (Ccmpi Cne, [Cvar existing_profinfo; cconst_int 1 (* () *)], dbg), + dbg, Cvar existing_profinfo, - generate_new_profinfo), + dbg, + generate_new_profinfo, + dbg), Clet (VP.create existing_count, Cop (Cload (Word_int, Asttypes.Mutable), [ Cop (Caddi, - [Cvar address_of_profinfo; Cconst_int Arch.size_addr], dbg) + [Cvar address_of_profinfo; cconst_int Arch.size_addr], dbg) ], dbg), Csequence ( Cop (Cstore (Word_int, Lambda.Assignment), [Cop (Caddi, - [Cvar address_of_profinfo; Cconst_int Arch.size_addr], dbg); + [Cvar address_of_profinfo; cconst_int Arch.size_addr], dbg); Cop (Caddi, [ Cvar existing_count; (* N.B. "*2" since the count is an OCaml integer. The "1 +" is to count the value's header. *) - Cconst_int (2 * (1 + Nativeint.to_int num_words)); + cconst_int (2 * (1 + Nativeint.to_int num_words)); ], dbg); ], dbg), (* [profinfo] looks like a black [Infix_tag] header. Instead of @@ -188,18 +204,22 @@ let code_for_blockheader ~value's_header ~node ~dbg = (* The following is the [Infix_offset_val], in words. *) (Nativeint.of_int (index_within_node + 1)) 10)) in - Cop (Cxor, [Cvar profinfo; Cconst_natint value's_header], dbg)))))) + Cop (Cxor, [Cvar profinfo; cconst_natint value's_header], dbg)))))) type callee = | Direct of string | Indirect of Cmm.expression -let code_for_call ~node ~callee ~is_tail ~label = +let code_for_call ~node ~callee ~is_tail ~label dbg = (* We treat self recursive calls as tail calls to avoid blow-ups in the graph. *) let is_self_recursive_call = match callee with - | Direct callee -> callee = !current_function_label + | Direct callee -> + begin match !current_function_label with + | None -> Misc.fatal_error "[current_function_label] not set" + | Some label -> String.equal callee label + end | Indirect _ -> false in let is_tail = is_tail || is_self_recursive_call in @@ -221,10 +241,9 @@ let code_for_call ~node ~callee ~is_tail ~label = | Direct _ | Indirect _ -> () end; let place_within_node = V.create_local "place_within_node" in - let dbg = Debuginfo.none in let open Cmm in Clet (VP.create place_within_node, - Cop (Caddi, [node; Cconst_int (index_within_node * Arch.size_addr)], dbg), + Cop (Caddi, [node; cconst_int (index_within_node * Arch.size_addr)], dbg), (* The following code returns the address that is to be moved into the (hard) node hole pointer register immediately before the call. (That move is inserted in [Selectgen].) *) @@ -234,14 +253,14 @@ let code_for_call ~node ~callee ~is_tail ~label = let count_addr = V.create_local "call_count_addr" in let count = V.create_local "call_count" in Clet (VP.create count_addr, - Cop (Caddi, [Cvar place_within_node; Cconst_int Arch.size_addr], dbg), + Cop (Caddi, [Cvar place_within_node; cconst_int Arch.size_addr], dbg), Clet (VP.create count, Cop (Cload (Word_int, Asttypes.Mutable), [Cvar count_addr], dbg), Csequence ( Cop (Cstore (Word_int, Lambda.Assignment), (* Adding 2 really means adding 1; the count is encoded as an OCaml integer. *) - [Cvar count_addr; Cop (Caddi, [Cvar count; Cconst_int 2], dbg)], + [Cvar count_addr; Cop (Caddi, [Cvar count; cconst_int 2], dbg)], dbg), Cvar place_within_node))) end else begin @@ -250,7 +269,7 @@ let code_for_call ~node ~callee ~is_tail ~label = | Indirect callee -> let caller_node = if is_tail then node - else Cconst_int 1 (* [Val_unit] *) + else cconst_int 1 (* [Val_unit] *) in Cop (Cextcall ("caml_spacetime_indirect_node_hole_ptr", [| Int |], false, None), @@ -264,20 +283,21 @@ class virtual instruction_selection = object (self) instrumentation... *) val mutable disable_instrumentation = false - method private instrument_direct_call ~env ~func ~is_tail ~label_after = + method private instrument_direct_call ~env ~func ~is_tail ~label_after dbg = let instrumentation = code_for_call ~node:(Lazy.force !spacetime_node) ~callee:(Direct func) ~is_tail ~label:label_after + dbg in match self#emit_expr env instrumentation with | None -> assert false | Some reg -> Some reg method private instrument_indirect_call ~env ~callee ~is_tail - ~label_after = + ~label_after dbg = (* [callee] is a pseudoregister, so we have to bind it in the environment and reference the variable to which it is bound. *) let callee_ident = V.create_local "callee" in @@ -288,6 +308,7 @@ class virtual instruction_selection = object (self) ~callee:(Indirect (Cmm.Cvar callee_ident)) ~is_tail ~label:label_after + dbg in match self#emit_expr env instrumentation with | None -> assert false @@ -296,29 +317,29 @@ class virtual instruction_selection = object (self) method private can_instrument () = Config.spacetime && not disable_instrumentation - method! about_to_emit_call env desc arg = + method! about_to_emit_call env desc arg dbg = if not (self#can_instrument ()) then None else let module M = Mach in match desc with | M.Iop (M.Icall_imm { func; label_after; }) -> assert (Array.length arg = 0); - self#instrument_direct_call ~env ~func ~is_tail:false ~label_after + self#instrument_direct_call ~env ~func ~is_tail:false ~label_after dbg | M.Iop (M.Icall_ind { label_after; }) -> assert (Array.length arg = 1); self#instrument_indirect_call ~env ~callee:arg.(0) - ~is_tail:false ~label_after + ~is_tail:false ~label_after dbg | M.Iop (M.Itailcall_imm { func; label_after; }) -> assert (Array.length arg = 0); - self#instrument_direct_call ~env ~func ~is_tail:true ~label_after + self#instrument_direct_call ~env ~func ~is_tail:true ~label_after dbg | M.Iop (M.Itailcall_ind { label_after; }) -> assert (Array.length arg = 1); self#instrument_indirect_call ~env ~callee:arg.(0) - ~is_tail:true ~label_after + ~is_tail:true ~label_after dbg | M.Iop (M.Iextcall { func; alloc = true; label_after; }) -> (* N.B. No need to instrument "noalloc" external calls. *) assert (Array.length arg = 0); - self#instrument_direct_call ~env ~func ~is_tail:false ~label_after + self#instrument_direct_call ~env ~func ~is_tail:false ~label_after dbg | _ -> None method private instrument_blockheader ~env ~value's_header ~dbg = @@ -336,6 +357,7 @@ class virtual instruction_selection = object (self) if something_was_instrumented () then begin let prologue_cmm = code_for_function_prologue ~function_name:f.Cmm.fun_name ~node_hole + ~fun_dbg:f.Cmm.fun_dbg in disable_instrumentation <- true; let node_temp_reg = @@ -348,7 +370,7 @@ class virtual instruction_selection = object (self) disable_instrumentation <- false; let node = Lazy.force !spacetime_node_ident in let node_reg = Selectgen.env_find node env in - self#insert_moves node_temp_reg node_reg + self#insert_moves env node_temp_reg node_reg end method! emit_blockheader env n dbg = @@ -446,7 +468,7 @@ class virtual instruction_selection = object (self) | None -> assert false | Some (node_hole, reg) -> node_hole, reg in - self#insert_moves [| Proc.loc_spacetime_node_hole |] node_hole_reg; + self#insert_moves env [| Proc.loc_spacetime_node_hole |] node_hole_reg; self#emit_prologue f ~node_hole ~env; match !reverse_shape with | [] -> None diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index 7e3a3188..0aeee83c 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -198,28 +198,6 @@ let rec reload i before = (instr_cons (Iswitch(index, new_cases)) i.arg i.res new_next), finally) - | Iloop(body) -> - let date_start = !current_date in - let destroyed_at_fork_start = !destroyed_at_fork in - let at_head = ref before in - let final_body = ref body in - begin try - while true do - current_date := date_start; - destroyed_at_fork := destroyed_at_fork_start; - let (new_body, new_at_head) = reload body !at_head in - let merged_at_head = Reg.Set.union !at_head new_at_head in - if Reg.Set.equal merged_at_head !at_head then begin - final_body := new_body; - raise Exit - end; - at_head := merged_at_head - done - with Exit -> () - end; - let (new_next, finally) = reload i.next Reg.Set.empty in - (instr_cons (Iloop(!final_body)) i.arg i.res new_next, - finally) | Icatch(rec_flag, handlers, body) -> let new_sets = List.map (fun (nfail, _) -> nfail, ref Reg.Set.empty) handlers in @@ -375,26 +353,6 @@ let rec spill i finally = inside_arm := saved_inside_arm ; (instr_cons (Iswitch(index, new_cases)) i.arg i.res new_next, !before) - | Iloop(body) -> - let (new_next, _) = spill i.next finally in - let saved_inside_loop = !inside_loop in - inside_loop := true; - let at_head = ref Reg.Set.empty in - let final_body = ref body in - begin try - while true do - let (new_body, before_body) = spill body !at_head in - let new_at_head = Reg.Set.union !at_head before_body in - if Reg.Set.equal new_at_head !at_head then begin - final_body := new_body; raise Exit - end; - at_head := new_at_head - done - with Exit -> () - end; - inside_loop := saved_inside_loop; - (instr_cons (Iloop(!final_body)) i.arg i.res new_next, - !at_head) | Icatch(rec_flag, handlers, body) -> let (new_next, at_join) = spill i.next finally in let saved_inside_catch = !inside_catch in diff --git a/asmcomp/split.ml b/asmcomp/split.ml index 650c404e..cfe4b0d6 100644 --- a/asmcomp/split.ml +++ b/asmcomp/split.ml @@ -160,11 +160,6 @@ let rec rename i sub = (instr_cons (Iswitch(index, Array.map (fun (n, _s) -> n) new_sub_cases)) (subst_regs i.arg sub) [||] new_next, sub_next) - | Iloop(body) -> - let (new_body, sub_body) = rename body sub in - let (new_next, sub_next) = rename i.next (merge_substs sub sub_body i) in - (instr_cons (Iloop(new_body)) [||] [||] new_next, - sub_next) | Icatch(rec_flag, handlers, body) -> let new_subst = List.map (fun (nfail, _) -> nfail, ref None) handlers in diff --git a/asmcomp/strmatch.ml b/asmcomp/strmatch.ml index b1efbf8f..07d77ebf 100644 --- a/asmcomp/strmatch.ml +++ b/asmcomp/strmatch.ml @@ -77,7 +77,7 @@ module Make(I:I) = struct let dbg = Debuginfo.none in let cell = Cop(Cload (Word_int, Asttypes.Mutable), - [Cop(Cadda,[str;Cconst_int(Arch.size_int*ind)], dbg)], + [Cop(Cadda,[str;Cconst_int(Arch.size_int*ind, dbg)], dbg)], dbg) in Clet(id, cell, body) @@ -88,9 +88,9 @@ module Make(I:I) = struct let mk_cmp_gen cmp_op id nat ifso ifnot = let dbg = Debuginfo.none in let test = - Cop (Ccmpi cmp_op, [ Cvar id; Cconst_natpointer nat ], dbg) + Cop (Ccmpi cmp_op, [ Cvar id; Cconst_natpointer (nat, dbg) ], dbg) in - Cifthenelse (test, ifso, ifnot) + Cifthenelse (test, dbg, ifso, dbg, ifnot, dbg) let mk_lt = mk_cmp_gen Clt let mk_eq = mk_cmp_gen Ceq @@ -377,11 +377,11 @@ module Make(I:I) = struct (* Module entry point *) - let catch arg k = match arg with + let catch dbg arg k = match arg with | Cexit (_e,[]) -> k arg | _ -> let e = next_raise_count () in - ccatch (e,[],k (Cexit (e,[])),arg) + ccatch (e,[],k (Cexit (e,[])),arg,dbg) let compile dbg str default cases = (* We do not attempt to really optimise default=None *) @@ -393,6 +393,6 @@ module Make(I:I) = struct List.rev_map (fun (s,act) -> pat_of_string s,act) cases in - catch default (fun default -> top_compile dbg str default cases) + catch dbg default (fun default -> top_compile dbg str default cases) end diff --git a/asmcomp/traverse_for_exported_symbols.ml b/asmcomp/traverse_for_exported_symbols.ml deleted file mode 100644 index 1b7ce57f..00000000 --- a/asmcomp/traverse_for_exported_symbols.ml +++ /dev/null @@ -1,267 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fu Yong Quah, Jane Street Europe *) -(* *) -(* Copyright 2017 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -module A = Simple_value_approx - -type queue_elem = - | Q_symbol of Symbol.t - | Q_set_of_closures_id of Set_of_closures_id.t - | Q_export_id of Export_id.t - -type symbols_to_export = - { symbols : Symbol.Set.t; - export_ids : Export_id.Set.t; - set_of_closure_ids : Set_of_closures_id.Set.t; - set_of_closure_ids_keep_declaration : Set_of_closures_id.Set.t; - relevant_imported_closure_ids : Closure_id.Set.t; - relevant_local_closure_ids : Closure_id.Set.t; - relevant_imported_vars_within_closure : Var_within_closure.Set.t; - relevant_local_vars_within_closure : Var_within_closure.Set.t; - } - -let traverse - ~(sets_of_closures_map : - Flambda.set_of_closures Set_of_closures_id.Map.t) - ~(closure_id_to_set_of_closures_id : - Set_of_closures_id.t Closure_id.Map.t) - ~(function_declarations_map : - A.function_declarations Set_of_closures_id.Map.t) - ~(values : Export_info.descr Export_id.Map.t) - ~(symbol_id : Export_id.t Symbol.Map.t) - ~(root_symbol: Symbol.t) = - let relevant_set_of_closures_declaration_only = - ref Set_of_closures_id.Set.empty - in - let relevant_symbols = ref (Symbol.Set.singleton root_symbol) in - let relevant_set_of_closures = ref Set_of_closures_id.Set.empty in - let relevant_export_ids = ref Export_id.Set.empty in - let relevant_imported_closure_ids = ref Closure_id.Set.empty in - let relevant_local_closure_ids = ref Closure_id.Set.empty in - let relevant_imported_vars_within_closure = - ref Var_within_closure.Set.empty - in - let relevant_local_vars_with_closure = ref Var_within_closure.Set.empty in - let (queue : queue_elem Queue.t) = Queue.create () in - let conditionally_add_symbol symbol = - if not (Symbol.Set.mem symbol !relevant_symbols) then begin - relevant_symbols := - Symbol.Set.add symbol !relevant_symbols; - Queue.add (Q_symbol symbol) queue - end - in - let conditionally_add_set_of_closures_id set_of_closures_id = - if not (Set_of_closures_id.Set.mem - set_of_closures_id !relevant_set_of_closures) then begin - relevant_set_of_closures := - Set_of_closures_id.Set.add set_of_closures_id - !relevant_set_of_closures; - Queue.add (Q_set_of_closures_id set_of_closures_id) queue - end - in - let conditionally_add_export_id export_id = - if not (Export_id.Set.mem export_id !relevant_export_ids) then begin - relevant_export_ids := - Export_id.Set.add export_id !relevant_export_ids; - Queue.add (Q_export_id export_id) queue - end - in - let process_approx (approx : Export_info.approx) = - match approx with - | Value_id export_id -> - conditionally_add_export_id export_id - | Value_symbol symbol -> - conditionally_add_symbol symbol - | Value_unknown -> () - in - let process_value_set_of_closures - (soc : Export_info.value_set_of_closures) = - conditionally_add_set_of_closures_id soc.set_of_closures_id; - Var_within_closure.Map.iter - (fun _ value -> process_approx value) soc.bound_vars; - Closure_id.Map.iter - (fun _ value -> process_approx value) soc.results; - begin match soc.aliased_symbol with - | None -> () - | Some symbol -> conditionally_add_symbol symbol - end - in - let process_function_body (function_body : A.function_body) = - Flambda_iterators.iter - (fun (term : Flambda.t) -> - match term with - | Flambda.Apply { kind ; _ } -> - begin match kind with - | Indirect -> () - | Direct closure_id -> - begin match - Closure_id.Map.find - closure_id - closure_id_to_set_of_closures_id - with - | exception Not_found -> - relevant_imported_closure_ids := - Closure_id.Set.add closure_id - !relevant_imported_closure_ids - | set_of_closures_id -> - relevant_local_closure_ids := - Closure_id.Set.add closure_id - !relevant_local_closure_ids; - conditionally_add_set_of_closures_id - set_of_closures_id - end - end - | _ -> ()) - (fun (named : Flambda.named) -> - let process_closure_id closure_id = - match - Closure_id.Map.find closure_id closure_id_to_set_of_closures_id - with - | exception Not_found -> - relevant_imported_closure_ids := - Closure_id.Set.add closure_id !relevant_imported_closure_ids - | set_of_closure_id -> - relevant_local_closure_ids := - Closure_id.Set.add closure_id !relevant_local_closure_ids; - relevant_set_of_closures_declaration_only := - Set_of_closures_id.Set.add - set_of_closure_id - !relevant_set_of_closures_declaration_only - in - match named with - | Symbol symbol - | Read_symbol_field (symbol, _) -> - conditionally_add_symbol symbol - | Set_of_closures soc -> - conditionally_add_set_of_closures_id - soc.function_decls.set_of_closures_id - | Project_closure { closure_id; _ } -> - process_closure_id closure_id - | Move_within_set_of_closures { start_from; move_to; _ } -> - process_closure_id start_from; - process_closure_id move_to - | Project_var { closure_id ; var; _ } -> - begin match - Closure_id.Map.find - closure_id closure_id_to_set_of_closures_id - with - | exception Not_found -> - relevant_imported_closure_ids := - Closure_id.Set.add closure_id - !relevant_imported_closure_ids; - relevant_imported_vars_within_closure := - Var_within_closure.Set.add var - !relevant_imported_vars_within_closure - | set_of_closure_id -> - relevant_local_closure_ids := - Closure_id.Set.add closure_id - !relevant_local_closure_ids; - relevant_local_vars_with_closure := - Var_within_closure.Set.add var - !relevant_local_vars_with_closure; - relevant_set_of_closures_declaration_only := - Set_of_closures_id.Set.add - set_of_closure_id - !relevant_set_of_closures_declaration_only - end - | Prim _ - | Expr _ - | Const _ - | Allocated_const _ - | Read_mutable _ -> ()) - function_body.body - in - let rec loop () = - if Queue.is_empty queue then - () - else begin - begin match Queue.pop queue with - | Q_export_id export_id -> - begin match Export_id.Map.find export_id values with - | exception Not_found -> () - | Value_block (_, approxes) -> - Array.iter process_approx approxes - | Value_closure value_closure -> - process_value_set_of_closures value_closure.set_of_closures - | Value_set_of_closures soc -> - process_value_set_of_closures soc - | _ -> () - end - | Q_symbol symbol -> - let compilation_unit = Symbol.compilation_unit symbol in - if Compilation_unit.is_current compilation_unit then begin - match Symbol.Map.find symbol symbol_id with - | exception Not_found -> - Misc.fatal_errorf "cannot find symbol's export id %a\n" - Symbol.print symbol - | export_id -> - conditionally_add_export_id export_id - end - | Q_set_of_closures_id set_of_closures_id -> - begin match - Set_of_closures_id.Map.find - set_of_closures_id function_declarations_map - with - | exception Not_found -> () - | function_declarations -> - Variable.Map.iter - (fun (_ : Variable.t) (fun_decl : A.function_declaration) -> - match fun_decl.function_body with - | None -> () - | Some function_body -> process_function_body function_body) - function_declarations.funs - end - end; - loop () - end - in - Queue.add (Q_symbol root_symbol) queue; - loop (); - - Closure_id.Map.iter (fun closure_id set_of_closure_id -> - if Set_of_closures_id.Set.mem - set_of_closure_id !relevant_set_of_closures - then begin - relevant_local_closure_ids := - Closure_id.Set.add closure_id !relevant_local_closure_ids - end) - closure_id_to_set_of_closures_id; - - Set_of_closures_id.Set.iter (fun set_of_closures_id -> - match - Set_of_closures_id.Map.find set_of_closures_id sets_of_closures_map - with - | exception Not_found -> () - | set_of_closures -> - Variable.Map.iter (fun var _ -> - relevant_local_vars_with_closure := - Var_within_closure.Set.add - (Var_within_closure.wrap var) - !relevant_local_vars_with_closure) - set_of_closures.free_vars) - !relevant_set_of_closures; - - { symbols = !relevant_symbols; - export_ids = !relevant_export_ids; - set_of_closure_ids = !relevant_set_of_closures; - set_of_closure_ids_keep_declaration = - !relevant_set_of_closures_declaration_only; - relevant_imported_closure_ids = !relevant_imported_closure_ids; - relevant_local_closure_ids = !relevant_local_closure_ids; - relevant_imported_vars_within_closure = - !relevant_imported_vars_within_closure; - relevant_local_vars_within_closure = - !relevant_local_vars_with_closure; - } diff --git a/asmcomp/traverse_for_exported_symbols.mli b/asmcomp/traverse_for_exported_symbols.mli deleted file mode 100644 index 2825a386..00000000 --- a/asmcomp/traverse_for_exported_symbols.mli +++ /dev/null @@ -1,41 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fu Yong Quah, Jane Street Europe *) -(* *) -(* Copyright 2017 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -type symbols_to_export = - { symbols : Symbol.Set.t; - export_ids : Export_id.Set.t; - set_of_closure_ids : Set_of_closures_id.Set.t; - set_of_closure_ids_keep_declaration : Set_of_closures_id.Set.t; - relevant_imported_closure_ids : Closure_id.Set.t; - relevant_local_closure_ids : Closure_id.Set.t; - relevant_imported_vars_within_closure : Var_within_closure.Set.t; - relevant_local_vars_within_closure : Var_within_closure.Set.t; - } - -(** Computes the transitive closure in [Symbol.t], [Closure_id.t] and - [Set_of_closures_id.t] and determines which ones of those should be - exported (i.e: included in the cmx files). -**) -val traverse - : sets_of_closures_map: Flambda.set_of_closures Set_of_closures_id.Map.t - -> closure_id_to_set_of_closures_id: - Set_of_closures_id.t Closure_id.Map.t - -> function_declarations_map: - Simple_value_approx.function_declarations Set_of_closures_id.Map.t - -> values: Export_info.descr Export_id.Map.t - -> symbol_id: Export_id.t Symbol.Map.t - -> root_symbol: Symbol.t - -> symbols_to_export diff --git a/asmcomp/un_anf.ml b/asmcomp/un_anf.ml deleted file mode 100644 index 450a9dd5..00000000 --- a/asmcomp/un_anf.ml +++ /dev/null @@ -1,817 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-30-40-41-42"] - -(* CR-someday vlaviron for mshinwell: I believe that the phantom lets introduced - in un_anf (when the new debug_full flag is enabled) bind mostly variables - that were created in the middle-end. Is it relevant to generate debugging - information for such variables ? I expect later pull requests to refine the - generation of these phantom constructions anyway, but maybe it would already - make sense to restrict the phantom let generation to variables with an actual - provenance. -*) - -module V = Backend_var -module VP = Backend_var.With_provenance - -(* We say that an [V.t] is "linear" iff: - (a) it is used exactly once; - (b) it is never assigned to (using [Uassign]). -*) -type var_info = - { used : V.Set.t; - linear : V.Set.t; - assigned : V.Set.t; - closure_environment : V.Set.t; - let_bound_vars_that_can_be_moved : V.Set.t; - } - -let ignore_uconstant (_ : Clambda.uconstant) = () -let ignore_ulambda (_ : Clambda.ulambda) = () -let ignore_ulambda_list (_ : Clambda.ulambda list) = () -let ignore_uphantom_defining_expr_option - (_ : Clambda.uphantom_defining_expr option) = () -let ignore_function_label (_ : Clambda.function_label) = () -let ignore_debuginfo (_ : Debuginfo.t) = () -let ignore_int (_ : int) = () -let ignore_var (_ : V.t) = () -let ignore_var_option (_ : V.t option) = () -let ignore_primitive (_ : Lambda.primitive) = () -let ignore_string (_ : string) = () -let ignore_int_array (_ : int array) = () -let ignore_var_with_provenance (_ : VP.t) = () -let ignore_params_with_value_kind (_ : (VP.t * Lambda.value_kind) list) = () -let ignore_direction_flag (_ : Asttypes.direction_flag) = () -let ignore_meth_kind (_ : Lambda.meth_kind) = () -let ignore_value_kind (_ : Lambda.value_kind) = () - -(* CR-soon mshinwell: check we aren't traversing function bodies more than - once (need to analyse exactly what the calls are from Cmmgen into this - module). *) - -let closure_environment_var (ufunction:Clambda.ufunction) = - (* The argument after the arity is the environment *) - if List.length ufunction.params = ufunction.arity + 1 then - let (env_var, _) = List.nth ufunction.params ufunction.arity in - assert (VP.name env_var = "env"); - Some env_var - else - (* closed function, no environment *) - None - -let make_var_info (clam : Clambda.ulambda) : var_info = - let t : int V.Tbl.t = V.Tbl.create 42 in - let assigned_vars = ref V.Set.empty in - let environment_vars = ref V.Set.empty in - let rec loop : Clambda.ulambda -> unit = function - (* No underscores in the pattern match, to reduce the chance of failing - to traverse some subexpression. *) - | Uvar var -> - begin match V.Tbl.find t var with - | n -> V.Tbl.replace t var (n + 1) - | exception Not_found -> V.Tbl.add t var 1 - end - | Uconst const -> - (* The only variables that might occur in [const] are those in constant - closures---and those are all bound by such closures. It follows that - [const] cannot contain any variables that are bound in the current - scope, so we do not need to count them here. (The function bodies - of the closures will be traversed when this function is called from - [Cmmgen.transl_function].) *) - ignore_uconstant const - | Udirect_apply (label, args, dbg) -> - ignore_function_label label; - List.iter loop args; - ignore_debuginfo dbg - | Ugeneric_apply (func, args, dbg) -> - loop func; - List.iter loop args; - ignore_debuginfo dbg - | Uclosure (functions, captured_variables) -> - List.iter loop captured_variables; - List.iter (fun ( - { Clambda. label; arity; params; return; body; dbg; env; } as clos) -> - (match closure_environment_var clos with - | None -> () - | Some env_var -> - environment_vars := - V.Set.add (VP.var env_var) !environment_vars); - ignore_function_label label; - ignore_int arity; - ignore_params_with_value_kind params; - ignore_value_kind return; - loop body; - ignore_debuginfo dbg; - ignore_var_option env) - functions - | Uoffset (expr, offset) -> - loop expr; - ignore_int offset - | Ulet (_let_kind, _value_kind, _var, def, body) -> - loop def; - loop body - | Uphantom_let (var, defining_expr_opt, body) -> - ignore_var_with_provenance var; - ignore_uphantom_defining_expr_option defining_expr_opt; - loop body - | Uletrec (defs, body) -> - List.iter (fun (var, def) -> - ignore_var_with_provenance var; - loop def) - defs; - loop body - | Uprim (prim, args, dbg) -> - ignore_primitive prim; - List.iter loop args; - ignore_debuginfo dbg - | Uswitch (cond, { us_index_consts; us_actions_consts; - us_index_blocks; us_actions_blocks }, dbg) -> - loop cond; - ignore_int_array us_index_consts; - Array.iter loop us_actions_consts; - ignore_int_array us_index_blocks; - Array.iter loop us_actions_blocks; - ignore_debuginfo dbg - | Ustringswitch (cond, branches, default) -> - loop cond; - List.iter (fun (str, branch) -> - ignore_string str; - loop branch) - branches; - Misc.may loop default - | Ustaticfail (static_exn, args) -> - ignore_int static_exn; - List.iter loop args - | Ucatch (static_exn, vars, body, handler) -> - ignore_int static_exn; - ignore_params_with_value_kind vars; - loop body; - loop handler - | Utrywith (body, var, handler) -> - loop body; - ignore_var_with_provenance var; - loop handler - | Uifthenelse (cond, ifso, ifnot) -> - loop cond; - loop ifso; - loop ifnot - | Usequence (e1, e2) -> - loop e1; - loop e2 - | Uwhile (cond, body) -> - loop cond; - loop body - | Ufor (var, low, high, direction_flag, body) -> - ignore_var_with_provenance var; - loop low; - loop high; - ignore_direction_flag direction_flag; - loop body - | Uassign (var, expr) -> - assigned_vars := V.Set.add var !assigned_vars; - loop expr - | Usend (meth_kind, e1, e2, args, dbg) -> - ignore_meth_kind meth_kind; - loop e1; - loop e2; - List.iter loop args; - ignore_debuginfo dbg - | Uunreachable -> - () - in - loop clam; - let linear = - V.Tbl.fold (fun var n acc -> - assert (n >= 1); - if n = 1 && not (V.Set.mem var !assigned_vars) - then V.Set.add var acc - else acc) - t V.Set.empty - in - let assigned = !assigned_vars in - let used = - (* This doesn't work transitively and thus is somewhat restricted. In - particular, it does not allow us to get rid of useless chains of [let]s. - However it should be sufficient to remove the majority of unnecessary - [let] bindings that might hinder [Cmmgen]. *) - V.Tbl.fold (fun var _n acc -> V.Set.add var acc) - t assigned - in - { used; linear; assigned; closure_environment = !environment_vars; - let_bound_vars_that_can_be_moved = V.Set.empty; - } - -(* When sequences of [let]-bindings match the evaluation order in a subsequent - primitive or function application whose arguments are linearly-used - non-assigned variables bound by such lets (possibly interspersed with other - variables that are known to be constant), and it is known that there were no - intervening side-effects during the evaluation of the [let]-bindings, - permit substitution of the variables for their defining expressions. *) -let let_bound_vars_that_can_be_moved var_info (clam : Clambda.ulambda) = - let obviously_constant = ref V.Set.empty in - let can_move = ref V.Set.empty in - let let_stack = ref [] in - let examine_argument_list args = - let rec loop let_bound_vars (args : Clambda.ulambda list) = - match let_bound_vars, args with - | _, [] -> - (* We've matched all arguments and will not substitute (in the - current application being considered) any of the remaining - [let_bound_vars]. As such they may stay on the stack. *) - let_bound_vars - | [], _ -> - (* There are no more [let]-bindings to consider, so the stack - is left empty. *) - [] - | let_bound_vars, (Uvar arg)::args - when V.Set.mem arg !obviously_constant -> - loop let_bound_vars args - | let_bound_var::let_bound_vars, (Uvar arg)::args - when V.same let_bound_var arg - && not (V.Set.mem arg var_info.assigned) -> - assert (V.Set.mem arg var_info.used); - assert (V.Set.mem arg var_info.linear); - can_move := V.Set.add arg !can_move; - loop let_bound_vars args - | _::_, _::_ -> - (* The [let] sequence has ceased to match the evaluation order - or we have encountered some complicated argument. In this case - we empty the stack to ensure that we do not end up moving an - outer [let] across a side effect. *) - [] - in - (* Start at the most recent let binding and the leftmost argument - (the last argument to be evaluated). *) - let_stack := loop !let_stack args - in - let rec loop : Clambda.ulambda -> unit = function - | Uvar var -> - if V.Set.mem var var_info.assigned then begin - let_stack := [] - end - | Uconst const -> - ignore_uconstant const - | Udirect_apply (label, args, dbg) -> - ignore_function_label label; - examine_argument_list args; - (* We don't currently traverse [args]; they should all be variables - anyway. If this is added in the future, take care to traverse [args] - following the evaluation order. *) - ignore_debuginfo dbg - | Ugeneric_apply (func, args, dbg) -> - examine_argument_list (args @ [func]); - ignore_debuginfo dbg - | Uclosure (functions, captured_variables) -> - ignore_ulambda_list captured_variables; - (* Start a new let stack for speed. *) - List.iter (fun {Clambda. label; arity; params; return; body; dbg; env} -> - ignore_function_label label; - ignore_int arity; - ignore_params_with_value_kind params; - ignore_value_kind return; - let_stack := []; - loop body; - let_stack := []; - ignore_debuginfo dbg; - ignore_var_option env) - functions - | Uoffset (expr, offset) -> - (* [expr] should usually be a variable. *) - examine_argument_list [expr]; - ignore_int offset - | Ulet (_let_kind, _value_kind, var, def, body) -> - let var = VP.var var in - begin match def with - | Uconst _ -> - (* The defining expression is obviously constant, so we don't - have to put this [let] on the stack, and we don't have to - traverse the defining expression either. *) - obviously_constant := V.Set.add var !obviously_constant; - loop body - | _ -> - loop def; - if V.Set.mem var var_info.linear then begin - let_stack := var::!let_stack - end else begin - (* If we encounter a non-linear [let]-binding then we must clear - the let stack, since we cannot now move any previous binding - across the non-linear one. *) - let_stack := [] - end; - loop body - end - | Uphantom_let (var, _defining_expr, body) -> - ignore_var_with_provenance var; - loop body - | Uletrec (defs, body) -> - (* Evaluation order for [defs] is not defined, and this case - probably isn't important for [Cmmgen] anyway. *) - let_stack := []; - List.iter (fun (var, def) -> - ignore_var_with_provenance var; - loop def; - let_stack := []) - defs; - loop body - | Uprim (prim, args, dbg) -> - ignore_primitive prim; - examine_argument_list args; - ignore_debuginfo dbg - | Uswitch (cond, { us_index_consts; us_actions_consts; - us_index_blocks; us_actions_blocks }, dbg) -> - examine_argument_list [cond]; - ignore_int_array us_index_consts; - Array.iter (fun action -> - let_stack := []; - loop action) - us_actions_consts; - ignore_int_array us_index_blocks; - Array.iter (fun action -> - let_stack := []; - loop action) - us_actions_blocks; - ignore_debuginfo dbg; - let_stack := [] - | Ustringswitch (cond, branches, default) -> - examine_argument_list [cond]; - List.iter (fun (str, branch) -> - ignore_string str; - let_stack := []; - loop branch) - branches; - let_stack := []; - Misc.may loop default; - let_stack := [] - | Ustaticfail (static_exn, args) -> - ignore_int static_exn; - examine_argument_list args - | Ucatch (static_exn, vars, body, handler) -> - ignore_int static_exn; - ignore_params_with_value_kind vars; - let_stack := []; - loop body; - let_stack := []; - loop handler; - let_stack := [] - | Utrywith (body, var, handler) -> - let_stack := []; - loop body; - let_stack := []; - ignore_var_with_provenance var; - loop handler; - let_stack := [] - | Uifthenelse (cond, ifso, ifnot) -> - examine_argument_list [cond]; - let_stack := []; - loop ifso; - let_stack := []; - loop ifnot; - let_stack := [] - | Usequence (e1, e2) -> - loop e1; - let_stack := []; - loop e2; - let_stack := [] - | Uwhile (cond, body) -> - let_stack := []; - loop cond; - let_stack := []; - loop body; - let_stack := [] - | Ufor (var, low, high, direction_flag, body) -> - ignore_var_with_provenance var; - (* Cmmgen generates code that evaluates low before high, - but we don't do anything here at the moment anyway. *) - ignore_ulambda low; - ignore_ulambda high; - ignore_direction_flag direction_flag; - let_stack := []; - loop body; - let_stack := [] - | Uassign (var, expr) -> - ignore_var var; - ignore_ulambda expr; - let_stack := [] - | Usend (meth_kind, e1, e2, args, dbg) -> - ignore_meth_kind meth_kind; - ignore_ulambda e1; - ignore_ulambda e2; - ignore_ulambda_list args; - let_stack := []; - ignore_debuginfo dbg - | Uunreachable -> - let_stack := [] - in - loop clam; - !can_move - -(* Substitution of an expression for a let-moveable variable can cause the - surrounding expression to become fixed. To avoid confusion, do the - let-moveable substitutions first. *) -let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda) - : Clambda.ulambda = - match clam with - | Uvar var -> - if not (V.Set.mem var is_let_moveable) then - clam - else - begin match V.Map.find var env with - | clam -> clam - | exception Not_found -> - Misc.fatal_errorf "substitute_let_moveable: Unbound variable %a" - V.print var - end - | Uconst _ -> clam - | Udirect_apply (label, args, dbg) -> - let args = substitute_let_moveable_list is_let_moveable env args in - Udirect_apply (label, args, dbg) - | Ugeneric_apply (func, args, dbg) -> - let func = substitute_let_moveable is_let_moveable env func in - let args = substitute_let_moveable_list is_let_moveable env args in - Ugeneric_apply (func, args, dbg) - | Uclosure (functions, variables_bound_by_the_closure) -> - let functions = - List.map (fun (ufunction : Clambda.ufunction) -> - { ufunction with - body = substitute_let_moveable is_let_moveable env ufunction.body; - }) - functions - in - let variables_bound_by_the_closure = - substitute_let_moveable_list is_let_moveable env - variables_bound_by_the_closure - in - Uclosure (functions, variables_bound_by_the_closure) - | Uoffset (clam, n) -> - let clam = substitute_let_moveable is_let_moveable env clam in - Uoffset (clam, n) - | Ulet (let_kind, value_kind, var, def, body) -> - let def = substitute_let_moveable is_let_moveable env def in - if V.Set.mem (VP.var var) is_let_moveable then - let env = V.Map.add (VP.var var) def env in - let body = substitute_let_moveable is_let_moveable env body in - (* If we are about to delete a [let] in debug mode, keep it for the - debugger. *) - (* CR-someday mshinwell: find out why some closure constructions were - not leaving phantom lets behind after substitution. *) - if not !Clflags.debug_full then - body - else - match def with - | Uconst const -> - Uphantom_let (var, Some (Clambda.Uphantom_const const), body) - | Uvar alias_of -> - Uphantom_let (var, Some (Clambda.Uphantom_var alias_of), body) - | _ -> - Uphantom_let (var, None, body) - else - Ulet (let_kind, value_kind, - var, def, substitute_let_moveable is_let_moveable env body) - | Uphantom_let (var, defining_expr, body) -> - let body = substitute_let_moveable is_let_moveable env body in - Uphantom_let (var, defining_expr, body) - | Uletrec (defs, body) -> - let defs = - List.map (fun (var, def) -> - var, substitute_let_moveable is_let_moveable env def) - defs - in - let body = substitute_let_moveable is_let_moveable env body in - Uletrec (defs, body) - | Uprim (prim, args, dbg) -> - let args = substitute_let_moveable_list is_let_moveable env args in - Uprim (prim, args, dbg) - | Uswitch (cond, sw, dbg) -> - let cond = substitute_let_moveable is_let_moveable env cond in - let sw = - { sw with - us_actions_consts = - substitute_let_moveable_array is_let_moveable env - sw.us_actions_consts; - us_actions_blocks = - substitute_let_moveable_array is_let_moveable env - sw.us_actions_blocks; - } - in - Uswitch (cond, sw, dbg) - | Ustringswitch (cond, branches, default) -> - let cond = substitute_let_moveable is_let_moveable env cond in - let branches = - List.map (fun (s, branch) -> - s, substitute_let_moveable is_let_moveable env branch) - branches - in - let default = - Misc.may_map (substitute_let_moveable is_let_moveable env) default - in - Ustringswitch (cond, branches, default) - | Ustaticfail (n, args) -> - let args = substitute_let_moveable_list is_let_moveable env args in - Ustaticfail (n, args) - | Ucatch (n, vars, body, handler) -> - let body = substitute_let_moveable is_let_moveable env body in - let handler = substitute_let_moveable is_let_moveable env handler in - Ucatch (n, vars, body, handler) - | Utrywith (body, var, handler) -> - let body = substitute_let_moveable is_let_moveable env body in - let handler = substitute_let_moveable is_let_moveable env handler in - Utrywith (body, var, handler) - | Uifthenelse (cond, ifso, ifnot) -> - let cond = substitute_let_moveable is_let_moveable env cond in - let ifso = substitute_let_moveable is_let_moveable env ifso in - let ifnot = substitute_let_moveable is_let_moveable env ifnot in - Uifthenelse (cond, ifso, ifnot) - | Usequence (e1, e2) -> - let e1 = substitute_let_moveable is_let_moveable env e1 in - let e2 = substitute_let_moveable is_let_moveable env e2 in - Usequence (e1, e2) - | Uwhile (cond, body) -> - let cond = substitute_let_moveable is_let_moveable env cond in - let body = substitute_let_moveable is_let_moveable env body in - Uwhile (cond, body) - | Ufor (var, low, high, direction, body) -> - let low = substitute_let_moveable is_let_moveable env low in - let high = substitute_let_moveable is_let_moveable env high in - let body = substitute_let_moveable is_let_moveable env body in - Ufor (var, low, high, direction, body) - | Uassign (var, expr) -> - let expr = substitute_let_moveable is_let_moveable env expr in - Uassign (var, expr) - | Usend (kind, e1, e2, args, dbg) -> - let e1 = substitute_let_moveable is_let_moveable env e1 in - let e2 = substitute_let_moveable is_let_moveable env e2 in - let args = substitute_let_moveable_list is_let_moveable env args in - Usend (kind, e1, e2, args, dbg) - | Uunreachable -> - Uunreachable - -and substitute_let_moveable_list is_let_moveable env clams = - List.map (substitute_let_moveable is_let_moveable env) clams - -and substitute_let_moveable_array is_let_moveable env clams = - Array.map (substitute_let_moveable is_let_moveable env) clams - -(* We say that an expression is "moveable" iff it has neither effects nor - coeffects. (See semantics_of_primitives.mli.) -*) -type moveable = Fixed | Constant | Moveable - -let both_moveable a b = - match a, b with - | Constant, Constant -> Constant - | Constant, Moveable - | Moveable, Constant - | Moveable, Moveable -> Moveable - | Constant, Fixed - | Moveable, Fixed - | Fixed, Constant - | Fixed, Moveable - | Fixed, Fixed -> Fixed - -let primitive_moveable (prim : Lambda.primitive) - (args : Clambda.ulambda list) - (var_info : var_info) = - match prim, args with - | Pfield _, [Uconst (Uconst_ref (_, _))] -> - (* CR-someday mshinwell: Actually, maybe this shouldn't be needed; these - should have been simplified to [Read_symbol_field], which doesn't yield - a Clambda let. This might be fixed when Inline_and_simplify can - turn Pfield into Read_symbol_field. *) - (* Allow field access of symbols to be moveable. (The comment in - flambda.mli on [Read_symbol_field] may be helpful to the reader.) *) - Moveable - | Pfield _, [Uvar var] when V.Set.mem var var_info.closure_environment -> - (* accesses to the function environment is coeffect free: this block - is never mutated *) - Moveable - | _ -> - match Semantics_of_primitives.for_primitive prim with - | No_effects, No_coeffects -> Moveable - | No_effects, Has_coeffects - | Only_generative_effects, No_coeffects - | Only_generative_effects, Has_coeffects - | Arbitrary_effects, No_coeffects - | Arbitrary_effects, Has_coeffects -> Fixed - -type moveable_for_env = Constant | Moveable - -(** Eliminate, through substitution, [let]-bindings of linear variables with - moveable defining expressions. *) -let rec un_anf_and_moveable var_info env (clam : Clambda.ulambda) - : Clambda.ulambda * moveable = - match clam with - | Uvar var -> - begin match V.Map.find var env with - | Constant, def -> def, Constant - | Moveable, def -> def, Moveable - | exception Not_found -> - let moveable : moveable = - if V.Set.mem var var_info.assigned then - Fixed - else - Moveable - in - clam, moveable - end - | Uconst _ -> - (* Constant closures are rewritten separately. *) - clam, Constant - | Udirect_apply (label, args, dbg) -> - let args = un_anf_list var_info env args in - Udirect_apply (label, args, dbg), Fixed - | Ugeneric_apply (func, args, dbg) -> - let func = un_anf var_info env func in - let args = un_anf_list var_info env args in - Ugeneric_apply (func, args, dbg), Fixed - | Uclosure (functions, variables_bound_by_the_closure) -> - let functions = - List.map (fun (ufunction : Clambda.ufunction) -> - { ufunction with - body = un_anf var_info env ufunction.body; - }) - functions - in - let variables_bound_by_the_closure = - un_anf_list var_info env variables_bound_by_the_closure - in - Uclosure (functions, variables_bound_by_the_closure), Fixed - | Uoffset (clam, n) -> - let clam, moveable = un_anf_and_moveable var_info env clam in - Uoffset (clam, n), both_moveable Moveable moveable - | Ulet (_let_kind, _value_kind, var, def, Uvar var') - when V.same (VP.var var) var' -> - un_anf_and_moveable var_info env def - | Ulet (let_kind, value_kind, var, def, body) -> - let def, def_moveable = un_anf_and_moveable var_info env def in - let is_linear = V.Set.mem (VP.var var) var_info.linear in - let is_used = V.Set.mem (VP.var var) var_info.used in - let is_assigned = V.Set.mem (VP.var var) var_info.assigned in - let maybe_for_debugger (body, moveable) : Clambda.ulambda * moveable = - if not !Clflags.debug_full then - body, moveable - else - match def with - | Uconst const -> - Uphantom_let (var, Some (Clambda.Uphantom_const const), - body), moveable - | Uvar alias_of -> - Uphantom_let (var, Some (Clambda.Uphantom_var alias_of), body), - moveable - | _ -> - Uphantom_let (var, None, body), moveable - in - begin match def_moveable, is_linear, is_used, is_assigned with - | (Constant | Moveable), _, false, _ -> - (* A moveable expression that is never used may be eliminated. - However, if in debug mode and the defining expression is - appropriate, keep the let (as a phantom let) for the debugger. *) - maybe_for_debugger (un_anf_and_moveable var_info env body) - | Constant, _, true, false - (* A constant expression bound to an unassigned variable can replace any - occurrences of the variable. The same comment as above concerning - phantom lets applies. *) - | Moveable, true, true, false -> - (* A moveable expression bound to a linear unassigned [V.t] - may replace the single occurrence of the variable. The same comment - as above concerning phantom lets applies. *) - let def_moveable = - match def_moveable with - | Moveable -> Moveable - | Constant -> Constant - | Fixed -> assert false - in - let env = V.Map.add (VP.var var) (def_moveable, def) env in - maybe_for_debugger (un_anf_and_moveable var_info env body) - | (Constant | Moveable), _, _, true - (* Constant or Moveable but assigned. *) - | Moveable, false, _, _ - (* Moveable but not used linearly. *) - | Fixed, _, _, _ -> - let body, body_moveable = un_anf_and_moveable var_info env body in - Ulet (let_kind, value_kind, var, def, body), - both_moveable def_moveable body_moveable - end - | Uphantom_let (var, defining_expr, body) -> - let body, body_moveable = un_anf_and_moveable var_info env body in - Uphantom_let (var, defining_expr, body), body_moveable - | Uletrec (defs, body) -> - let defs = - List.map (fun (var, def) -> var, un_anf var_info env def) defs - in - let body = un_anf var_info env body in - Uletrec (defs, body), Fixed - | Uprim (prim, args, dbg) -> - let args, args_moveable = un_anf_list_and_moveable var_info env args in - let moveable = - both_moveable args_moveable (primitive_moveable prim args var_info) - in - Uprim (prim, args, dbg), moveable - | Uswitch (cond, sw, dbg) -> - let cond = un_anf var_info env cond in - let sw = - { sw with - us_actions_consts = un_anf_array var_info env sw.us_actions_consts; - us_actions_blocks = un_anf_array var_info env sw.us_actions_blocks; - } - in - Uswitch (cond, sw, dbg), Fixed - | Ustringswitch (cond, branches, default) -> - let cond = un_anf var_info env cond in - let branches = - List.map (fun (s, branch) -> s, un_anf var_info env branch) - branches - in - let default = Misc.may_map (un_anf var_info env) default in - Ustringswitch (cond, branches, default), Fixed - | Ustaticfail (n, args) -> - let args = un_anf_list var_info env args in - Ustaticfail (n, args), Fixed - | Ucatch (n, vars, body, handler) -> - let body = un_anf var_info env body in - let handler = un_anf var_info env handler in - Ucatch (n, vars, body, handler), Fixed - | Utrywith (body, var, handler) -> - let body = un_anf var_info env body in - let handler = un_anf var_info env handler in - Utrywith (body, var, handler), Fixed - | Uifthenelse (cond, ifso, ifnot) -> - let cond, cond_moveable = un_anf_and_moveable var_info env cond in - let ifso, ifso_moveable = un_anf_and_moveable var_info env ifso in - let ifnot, ifnot_moveable = un_anf_and_moveable var_info env ifnot in - let moveable = - both_moveable cond_moveable - (both_moveable ifso_moveable ifnot_moveable) - in - Uifthenelse (cond, ifso, ifnot), moveable - | Usequence (e1, e2) -> - let e1 = un_anf var_info env e1 in - let e2 = un_anf var_info env e2 in - Usequence (e1, e2), Fixed - | Uwhile (cond, body) -> - let cond = un_anf var_info env cond in - let body = un_anf var_info env body in - Uwhile (cond, body), Fixed - | Ufor (var, low, high, direction, body) -> - let low = un_anf var_info env low in - let high = un_anf var_info env high in - let body = un_anf var_info env body in - Ufor (var, low, high, direction, body), Fixed - | Uassign (var, expr) -> - let expr = un_anf var_info env expr in - Uassign (var, expr), Fixed - | Usend (kind, e1, e2, args, dbg) -> - let e1 = un_anf var_info env e1 in - let e2 = un_anf var_info env e2 in - let args = un_anf_list var_info env args in - Usend (kind, e1, e2, args, dbg), Fixed - | Uunreachable -> - Uunreachable, Fixed - -and un_anf var_info env clam : Clambda.ulambda = - let clam, _moveable = un_anf_and_moveable var_info env clam in - clam - -and un_anf_list_and_moveable var_info env clams - : Clambda.ulambda list * moveable = - List.fold_right (fun clam (l, acc_moveable) -> - let clam, moveable = un_anf_and_moveable var_info env clam in - clam :: l, both_moveable moveable acc_moveable) - clams ([], (Moveable : moveable)) - -and un_anf_list var_info env clams : Clambda.ulambda list = - let clams, _moveable = un_anf_list_and_moveable var_info env clams in - clams - -and un_anf_array var_info env clams : Clambda.ulambda array = - Array.map (un_anf var_info env) clams - -let apply ~ppf_dump clam ~what = - let var_info = make_var_info clam in - let let_bound_vars_that_can_be_moved = - let_bound_vars_that_can_be_moved var_info clam - in - let clam = - substitute_let_moveable let_bound_vars_that_can_be_moved - V.Map.empty clam - in - let var_info = make_var_info clam in - let clam = un_anf var_info V.Map.empty clam in - if !Clflags.dump_clambda then begin - Format.fprintf ppf_dump - "@.un-anf (%s):@ %a@." what Printclambda.clambda clam - end; - clam diff --git a/asmcomp/un_anf.mli b/asmcomp/un_anf.mli deleted file mode 100644 index 92ea06cd..00000000 --- a/asmcomp/un_anf.mli +++ /dev/null @@ -1,23 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Expand ANF-like constructs so that pattern matches in [Cmmgen] will - work correctly. *) -val apply - : ppf_dump:Format.formatter - -> Clambda.ulambda - -> what:string - -> Clambda.ulambda diff --git a/asmcomp/x86_proc.ml b/asmcomp/x86_proc.ml index 31e16a4f..99ddd398 100644 --- a/asmcomp/x86_proc.ml +++ b/asmcomp/x86_proc.ml @@ -219,10 +219,6 @@ let string_of_rounding = function | RoundTruncate -> "roundsd.trunc" | RoundNearest -> "roundsd.near" -(* These hooks can be used to insert optimization passes on - the assembly code. *) -let assembler_passes = ref ([] : (asm_program -> asm_program) list) - let internal_assembler = ref None let register_internal_assembler f = internal_assembler := Some f @@ -268,9 +264,6 @@ let reset_asm_code () = asm_code := [] let generate_code asm = let instrs = List.rev !asm_code in - let instrs = - List.fold_left (fun instrs pass -> pass instrs) instrs !assembler_passes - in begin match asm with | Some f -> f instrs | None -> () diff --git a/asmcomp/x86_proc.mli b/asmcomp/x86_proc.mli index e8aed9c1..c7f20bc9 100644 --- a/asmcomp/x86_proc.mli +++ b/asmcomp/x86_proc.mli @@ -87,8 +87,3 @@ val use_plt : bool (** Support for plumbing a binary code emitter *) val register_internal_assembler: (asm_program -> string -> unit) -> unit - - -(** Hooks for rewriting the assembly code *) - -val assembler_passes: (asm_program -> asm_program) list ref diff --git a/autogen b/autogen index a4e15f94..40f47afa 100755 --- a/autogen +++ b/autogen @@ -1,2 +1,29 @@ #!/bin/sh -autoconf -W all,error +#************************************************************************** +#* * +#* OCaml * +#* * +#* David Allsopp, MetaStack Solutions Ltd. * +#* * +#* Copyright 2019 MetaStack Solutions Ltd. * +#* * +#* 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. * +#* * +#************************************************************************** + +version=$(autoconf --version | sed -ne 's/^autoconf .* \([0-9][^ ]*\)$/\1/p') +if [ "$version" != '2.69' ] ; then + echo "autoconf 2.69 is required" >&2 + exit 1 +else + # Remove the autom4te.cache directory to make sure we start in a clean state + rm -rf autom4te.cache + autoconf -W all,error + # Some distros have this 2013 patch to autoconf, some don't... + sed -i -e '/^runstatedir/d' \ + -e '/-runstatedir /,+8d' \ + -e '/--runstatedir=DIR/d' \ + -e 's/ runstatedir//' configure +fi diff --git a/boot/ocamlc b/boot/ocamlc index 4938ace5..9cc6a5bb 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamllex b/boot/ocamllex index 893f709e..261bb7d1 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index c7343bfc..2bbb19a5 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -129,6 +129,7 @@ let rec push_dummies n k = match n with type rhs_kind = | RHS_block of int + | RHS_infix of { blocksize : int; offset : int } | RHS_floatblock of int | RHS_nonrec | RHS_function of int * int @@ -158,6 +159,18 @@ let rec size_of_lambda env = function end | Llet(_str, _k, id, arg, body) -> size_of_lambda (Ident.add id (size_of_lambda env arg) env) body + (* See the Lletrec case of comp_expr *) + | Lletrec(bindings, body) when + List.for_all (function (_, Lfunction _) -> true | _ -> false) bindings -> + (* let rec of functions *) + let fv = + Ident.Set.elements (free_variables (Lletrec(bindings, lambda_unit))) in + (* See Instruct(CLOSUREREC) in interp.c *) + let blocksize = List.length bindings * 2 - 1 + List.length fv in + let offsets = List.mapi (fun i (id, _e) -> (id, i * 2)) bindings in + let env = List.fold_right (fun (id, offset) env -> + Ident.add id (RHS_infix { blocksize; offset }) env) offsets env in + size_of_lambda env body | Lletrec(bindings, body) -> let env = List.fold_right (fun (id, e) env -> Ident.add id (size_of_lambda env e) env) @@ -567,6 +580,12 @@ let rec comp_expr env exp sz cont = Kconst(Const_base(Const_int blocksize)) :: Kccall("caml_alloc_dummy", 1) :: Kpush :: comp_init (add_var id (sz+1) new_env) (sz+1) rem + | (id, _exp, RHS_infix { blocksize; offset }) :: rem -> + Kconst(Const_base(Const_int offset)) :: + Kpush :: + Kconst(Const_base(Const_int blocksize)) :: + Kccall("caml_alloc_dummy_infix", 2) :: Kpush :: + comp_init (add_var id (sz+1) new_env) (sz+1) rem | (id, _exp, RHS_function (blocksize,arity)) :: rem -> Kconst(Const_base(Const_int arity)) :: Kpush :: @@ -578,7 +597,8 @@ let rec comp_expr env exp sz cont = comp_init (add_var id (sz+1) new_env) (sz+1) rem and comp_nonrec new_env sz i = function | [] -> comp_rec new_env sz ndecl decl_size - | (_id, _exp, (RHS_block _ | RHS_floatblock _ | RHS_function _)) + | (_id, _exp, (RHS_block _ | RHS_infix _ | + RHS_floatblock _ | RHS_function _)) :: rem -> comp_nonrec new_env sz (i-1) rem | (_id, exp, RHS_nonrec) :: rem -> @@ -586,7 +606,8 @@ let rec comp_expr env exp sz cont = (Kassign (i-1) :: comp_nonrec new_env sz (i-1) rem) and comp_rec new_env sz i = function | [] -> comp_expr new_env body sz (add_pop ndecl cont) - | (_id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _)) + | (_id, exp, (RHS_block _ | RHS_infix _ | + RHS_floatblock _ | RHS_function _)) :: rem -> comp_expr new_env exp sz (Kpush :: Kacc i :: Kccall("caml_update_dummy", 2) :: diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index 0b964e69..3f50520c 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -20,15 +20,16 @@ open Config open Cmo_format type error = - File_not_found of string - | Not_an_object_file of string - | Wrong_object_name of string - | Symbol_error of string * Symtable.error - | Inconsistent_import of string * string * string + | File_not_found of filepath + | Not_an_object_file of filepath + | Wrong_object_name of filepath + | Symbol_error of filepath * Symtable.error + | Inconsistent_import of modname * filepath * filepath | Custom_runtime - | File_exists of string - | Cannot_open_dll of string - | Required_module_unavailable of string + | File_exists of filepath + | Cannot_open_dll of filepath + | Required_module_unavailable of modname + | Camlheader of string * filepath exception Error of error @@ -159,6 +160,8 @@ let scan_file obj_name tolink = (* Consistency check between interfaces *) +module Consistbl = Consistbl.Make (Misc.Stdlib.String) + let crc_interfaces = Consistbl.create () let interfaces = ref ([] : string list) let implementations_defined = ref ([] : (string * string) list) @@ -300,29 +303,33 @@ let link_bytecode ?final_name tolink exec_name standalone = | Link_object(file_name, _) when file_name = exec_name -> raise (Error (Wrong_object_name exec_name)); | _ -> ()) tolink; - Misc.remove_file exec_name; (* avoid permission problems, cf PR#1911 *) + Misc.remove_file exec_name; (* avoid permission problems, cf PR#8354 *) + let outperm = if !Clflags.with_runtime then 0o777 else 0o666 in let outchan = open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary] - 0o777 exec_name in + outperm exec_name in Misc.try_finally ~always:(fun () -> close_out outchan) ~exceptionally:(fun () -> remove_file exec_name) (fun () -> - if standalone then begin + if standalone && !Clflags.with_runtime then begin (* Copy the header *) + let header = + if String.length !Clflags.use_runtime > 0 + then "camlheader_ur" else "camlheader" ^ !Clflags.runtime_variant + in try - let header = - if String.length !Clflags.use_runtime > 0 - then "camlheader_ur" else "camlheader" ^ !Clflags.runtime_variant - in let inchan = open_in_bin (Load_path.find header) in copy_file inchan outchan; close_in inchan - with Not_found | Sys_error _ -> () + with + | Not_found -> raise (Error (File_not_found header)) + | Sys_error msg -> raise (Error (Camlheader (header, msg))) end; Bytesections.init_record outchan; (* The path to the bytecode interpreter (in use_runtime mode) *) - if String.length !Clflags.use_runtime > 0 then begin + if String.length !Clflags.use_runtime > 0 && !Clflags.with_runtime then + begin output_string outchan (make_absolute !Clflags.use_runtime); output_char outchan '\n'; Bytesections.record outchan "RNTM" @@ -527,7 +534,10 @@ let link_bytecode_as_c tolink outfile = (* Build a custom runtime *) let build_custom_runtime prim_name exec_name = - let runtime_lib = "-lcamlrun" ^ !Clflags.runtime_variant in + let runtime_lib = + if not !Clflags.with_runtime + then "" + else "-lcamlrun" ^ !Clflags.runtime_variant in let debug_prefix_map = if Config.c_has_debug_prefix_map && not !Clflags.keep_camlprimc_file then [Printf.sprintf "-fdebug-prefix-map=%s=camlprim.c" prim_name] @@ -651,7 +661,10 @@ let link objfiles output_name = else Ccomp.MainDll, Config.bytecomp_c_libraries in if not ( - let runtime_lib = "-lcamlrun" ^ !Clflags.runtime_variant in + let runtime_lib = + if not !Clflags.with_runtime + then "" + else "-lcamlrun" ^ !Clflags.runtime_variant in Ccomp.call_linker mode output_name ([obj_file] @ List.rev !Clflags.ccobjs @ [runtime_lib]) c_libs @@ -694,6 +707,8 @@ let report_error ppf = function Location.print_filename file | Required_module_unavailable s -> fprintf ppf "Required module `%s' is unavailable" s + | Camlheader (msg, header) -> + fprintf ppf "System error while copying file %s: %s" header msg let () = Location.register_error_of_exn diff --git a/bytecomp/bytelink.mli b/bytecomp/bytelink.mli index e3cf98da..4792e7c8 100644 --- a/bytecomp/bytelink.mli +++ b/bytecomp/bytelink.mli @@ -13,25 +13,28 @@ (* *) (**************************************************************************) +open Misc + (* Link .cmo files and produce a bytecode executable. *) -val link : string list -> string -> unit +val link : filepath list -> filepath -> unit val reset : unit -> unit -val check_consistency: string -> Cmo_format.compilation_unit -> unit +val check_consistency: filepath -> Cmo_format.compilation_unit -> unit -val extract_crc_interfaces: unit -> (string * Digest.t option) list +val extract_crc_interfaces: unit -> crcs type error = - File_not_found of string - | Not_an_object_file of string - | Wrong_object_name of string - | Symbol_error of string * Symtable.error - | Inconsistent_import of string * string * string + | File_not_found of filepath + | Not_an_object_file of filepath + | Wrong_object_name of filepath + | Symbol_error of filepath * Symtable.error + | Inconsistent_import of modname * filepath * filepath | Custom_runtime - | File_exists of string - | Cannot_open_dll of string - | Required_module_unavailable of string + | File_exists of filepath + | Cannot_open_dll of filepath + | Required_module_unavailable of modname + | Camlheader of string * filepath exception Error of error diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 4c19f5c2..2458030b 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -195,7 +195,7 @@ let build_global_target ~ppf_dump oc target_name members mapping pos coercion = let lam = Translmod.transl_package components (Ident.create_persistent target_name) coercion in - let lam = Simplif.simplify_lambda target_name lam in + let lam = Simplif.simplify_lambda lam in if !Clflags.dump_lambda then Format.fprintf ppf_dump "%a@." Printlambda.lambda lam; let instrs = diff --git a/bytecomp/cmo_format.mli b/bytecomp/cmo_format.mli deleted file mode 100644 index 7fbb35a0..00000000 --- a/bytecomp/cmo_format.mli +++ /dev/null @@ -1,65 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Symbol table information for .cmo and .cma files *) - -(* Relocation information *) - -type reloc_info = - Reloc_literal of Lambda.structured_constant (* structured constant *) - | Reloc_getglobal of Ident.t (* reference to a global *) - | Reloc_setglobal of Ident.t (* definition of a global *) - | Reloc_primitive of string (* C primitive number *) - -(* Descriptor for compilation units *) - -type compilation_unit = - { cu_name: string; (* Name of compilation unit *) - mutable cu_pos: int; (* Absolute position in file *) - cu_codesize: int; (* Size of code block *) - cu_reloc: (reloc_info * int) list; (* Relocation information *) - cu_imports: - (string * Digest.t option) list; (* Names and CRC of intfs imported *) - cu_required_globals: Ident.t list; (* Compilation units whose initialization - side effects must occur before this - one. *) - cu_primitives: string list; (* Primitives declared inside *) - mutable cu_force_link: bool; (* Must be linked even if unref'ed *) - mutable cu_debug: int; (* Position of debugging info, or 0 *) - cu_debugsize: int } (* Length of debugging info *) - -(* Format of a .cmo file: - magic number (Config.cmo_magic_number) - absolute offset of compilation unit descriptor - block of relocatable bytecode - debugging information if any - compilation unit descriptor *) - -(* Descriptor for libraries *) - -type library = - { lib_units: compilation_unit list; (* List of compilation units *) - lib_custom: bool; (* Requires custom mode linking? *) - lib_ccobjs: string list; (* C object files needed for -custom *) - lib_ccopts: string list; (* Extra opts to C compiler *) - lib_dllibs: string list } (* DLLs needed *) - -(* Format of a .cma file: - magic number (Config.cma_magic_number) - absolute offset of library descriptor - object code for first library member - ... - object code for last library member - library descriptor *) diff --git a/bytecomp/dune b/bytecomp/dune index b2409cf4..655cb57e 100644 --- a/bytecomp/dune +++ b/bytecomp/dune @@ -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})))) diff --git a/bytecomp/generate_runtimedef.sh b/bytecomp/generate_runtimedef.sh deleted file mode 100755 index 66ccf3ce..00000000 --- a/bytecomp/generate_runtimedef.sh +++ /dev/null @@ -1,25 +0,0 @@ -#!/bin/sh - -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -#* * -#* Copyright 1999 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -echo 'let builtin_exceptions = [|' -cat "$1" | tr -d '\r' | \ - sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$| \1;|p' -echo '|]' - -echo 'let builtin_primitives = [|' -sed -e 's/.*/ "&";/' "$2" -echo '|]' diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml deleted file mode 100644 index ebdd49a3..00000000 --- a/bytecomp/lambda.ml +++ /dev/null @@ -1,891 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Misc -open Asttypes - -type compile_time_constant = - | Big_endian - | Word_size - | Int_size - | Max_wosize - | Ostype_unix - | Ostype_win32 - | Ostype_cygwin - | Backend_type - -type immediate_or_pointer = - | Immediate - | Pointer - -type initialization_or_assignment = - | Assignment - | Heap_initialization - | Root_initialization - -type is_safe = - | Safe - | Unsafe - -type primitive = - | Pidentity - | Pbytes_to_string - | Pbytes_of_string - | Pignore - | Prevapply - | Pdirapply - (* Globals *) - | Pgetglobal of Ident.t - | Psetglobal of Ident.t - (* Operations on heap blocks *) - | Pmakeblock of int * mutable_flag * block_shape - | Pfield of int - | Pfield_computed - | Psetfield of int * immediate_or_pointer * initialization_or_assignment - | Psetfield_computed of immediate_or_pointer * initialization_or_assignment - | Pfloatfield of int - | Psetfloatfield of int * initialization_or_assignment - | Pduprecord of Types.record_representation * int - (* Force lazy values *) - (* External call *) - | Pccall of Primitive.description - (* Exceptions *) - | Praise of raise_kind - (* Boolean operations *) - | Psequand | Psequor | Pnot - (* Integer operations *) - | Pnegint | Paddint | Psubint | Pmulint - | Pdivint of is_safe | Pmodint of is_safe - | Pandint | Porint | Pxorint - | Plslint | Plsrint | Pasrint - | Pintcomp of integer_comparison - | Poffsetint of int - | Poffsetref of int - (* Float operations *) - | Pintoffloat | Pfloatofint - | Pnegfloat | Pabsfloat - | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat - | Pfloatcomp of float_comparison - (* String operations *) - | Pstringlength | Pstringrefu | Pstringrefs - | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets - (* Array operations *) - | Pmakearray of array_kind * mutable_flag - | Pduparray of array_kind * mutable_flag - | Parraylength of array_kind - | Parrayrefu of array_kind - | Parraysetu of array_kind - | Parrayrefs of array_kind - | Parraysets of array_kind - (* Test if the argument is a block or an immediate integer *) - | Pisint - (* Test if the (integer) argument is outside an interval *) - | Pisout - (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *) - | Pbintofint of boxed_integer - | Pintofbint of boxed_integer - | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*) - | Pnegbint of boxed_integer - | Paddbint of boxed_integer - | Psubbint of boxed_integer - | Pmulbint of boxed_integer - | Pdivbint of { size : boxed_integer; is_safe : is_safe } - | Pmodbint of { size : boxed_integer; is_safe : is_safe } - | Pandbint of boxed_integer - | Porbint of boxed_integer - | Pxorbint of boxed_integer - | Plslbint of boxed_integer - | Plsrbint of boxed_integer - | Pasrbint of boxed_integer - | Pbintcomp of boxed_integer * integer_comparison - (* Operations on Bigarrays: (unsafe, #dimensions, kind, layout) *) - | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout - | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout - (* size of the nth dimension of a Bigarray *) - | Pbigarraydim of int - (* load/set 16,32,64 bits from a string: (unsafe)*) - | Pstring_load_16 of bool - | Pstring_load_32 of bool - | Pstring_load_64 of bool - | Pbytes_load_16 of bool - | Pbytes_load_32 of bool - | Pbytes_load_64 of bool - | Pbytes_set_16 of bool - | Pbytes_set_32 of bool - | Pbytes_set_64 of bool - (* load/set 16,32,64 bits from a - (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *) - | Pbigstring_load_16 of bool - | Pbigstring_load_32 of bool - | Pbigstring_load_64 of bool - | Pbigstring_set_16 of bool - | Pbigstring_set_32 of bool - | Pbigstring_set_64 of bool - (* Compile time constants *) - | Pctconst of compile_time_constant - (* byte swap *) - | Pbswap16 - | Pbbswap of boxed_integer - (* Integer to external pointer *) - | Pint_as_pointer - (* Inhibition of optimisation *) - | Popaque - -and integer_comparison = - Ceq | Cne | Clt | Cgt | Cle | Cge - -and float_comparison = - CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge - -and value_kind = - Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval - -and block_shape = - value_kind list option - -and array_kind = - Pgenarray | Paddrarray | Pintarray | Pfloatarray - -and boxed_integer = Primitive.boxed_integer = - Pnativeint | Pint32 | Pint64 - -and bigarray_kind = - Pbigarray_unknown - | Pbigarray_float32 | Pbigarray_float64 - | Pbigarray_sint8 | Pbigarray_uint8 - | Pbigarray_sint16 | Pbigarray_uint16 - | Pbigarray_int32 | Pbigarray_int64 - | Pbigarray_caml_int | Pbigarray_native_int - | Pbigarray_complex32 | Pbigarray_complex64 - -and bigarray_layout = - Pbigarray_unknown_layout - | Pbigarray_c_layout - | Pbigarray_fortran_layout - -and raise_kind = - | Raise_regular - | Raise_reraise - | Raise_notrace - -let equal_boxed_integer x y = - match x, y with - | Pnativeint, Pnativeint - | Pint32, Pint32 - | Pint64, Pint64 -> - true - | (Pnativeint | Pint32 | Pint64), _ -> - false - -let equal_primitive = - (* Should be implemented like [equal_value_kind] of [equal_boxed_integer], - i.e. by matching over the various constructors but the type has more - than 100 constructors... *) - (=) - -let equal_value_kind x y = - match x, y with - | Pgenval, Pgenval -> true - | Pfloatval, Pfloatval -> true - | Pboxedintval bi1, Pboxedintval bi2 -> equal_boxed_integer bi1 bi2 - | Pintval, Pintval -> true - | (Pgenval | Pfloatval | Pboxedintval _ | Pintval), _ -> false - - -type structured_constant = - Const_base of constant - | Const_pointer of int - | Const_block of int * structured_constant list - | Const_float_array of string list - | Const_immstring of string - -type inline_attribute = - | Always_inline (* [@inline] or [@inline always] *) - | Never_inline (* [@inline never] *) - | Unroll of int (* [@unroll x] *) - | Default_inline (* no [@inline] attribute *) - -let equal_inline_attribute x y = - match x, y with - | Always_inline, Always_inline - | Never_inline, Never_inline - | Default_inline, Default_inline - -> - true - | Unroll u, Unroll v -> - u = v - | (Always_inline | Never_inline | Unroll _ | Default_inline), _ -> - false - -type specialise_attribute = - | Always_specialise (* [@specialise] or [@specialise always] *) - | Never_specialise (* [@specialise never] *) - | Default_specialise (* no [@specialise] attribute *) - -let equal_specialise_attribute x y = - match x, y with - | Always_specialise, Always_specialise - | Never_specialise, Never_specialise - | Default_specialise, Default_specialise -> - true - | (Always_specialise | Never_specialise | Default_specialise), _ -> - false - -type local_attribute = - | Always_local (* [@local] or [@local always] *) - | Never_local (* [@local never] *) - | Default_local (* [@local maybe] or no [@local] attribute *) - -type function_kind = Curried | Tupled - -type let_kind = Strict | Alias | StrictOpt | Variable - -type meth_kind = Self | Public | Cached - -let equal_meth_kind x y = - match x, y with - | Self, Self -> true - | Public, Public -> true - | Cached, Cached -> true - | (Self | Public | Cached), _ -> false - -type shared_code = (int * int) list - -type function_attribute = { - inline : inline_attribute; - specialise : specialise_attribute; - local: local_attribute; - is_a_functor: bool; - stub: bool; -} - -type lambda = - Lvar of Ident.t - | Lconst of structured_constant - | Lapply of lambda_apply - | Lfunction of lfunction - | Llet of let_kind * value_kind * Ident.t * lambda * lambda - | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t - | Lswitch of lambda * lambda_switch * Location.t - | Lstringswitch of - lambda * (string * lambda) list * lambda option * Location.t - | Lstaticraise of int * lambda list - | Lstaticcatch of lambda * (int * (Ident.t * value_kind) list) * lambda - | Ltrywith of lambda * Ident.t * lambda - | Lifthenelse of lambda * lambda * lambda - | Lsequence of lambda * lambda - | Lwhile of lambda * lambda - | Lfor of Ident.t * lambda * lambda * direction_flag * lambda - | Lassign of Ident.t * lambda - | Lsend of meth_kind * lambda * lambda * lambda list * Location.t - | Levent of lambda * lambda_event - | Lifused of Ident.t * lambda - -and lfunction = - { kind: function_kind; - params: (Ident.t * value_kind) list; - return: value_kind; - body: lambda; - attr: function_attribute; (* specified with [@inline] attribute *) - loc: Location.t; } - -and lambda_apply = - { ap_func : lambda; - ap_args : lambda list; - ap_loc : Location.t; - ap_should_be_tailcall : bool; - ap_inlined : inline_attribute; - ap_specialised : specialise_attribute; } - -and lambda_switch = - { sw_numconsts: int; - sw_consts: (int * lambda) list; - sw_numblocks: int; - sw_blocks: (int * lambda) list; - sw_failaction : lambda option} - -and lambda_event = - { lev_loc: Location.t; - lev_kind: lambda_event_kind; - lev_repr: int ref option; - lev_env: Env.t } - -and lambda_event_kind = - Lev_before - | Lev_after of Types.type_expr - | Lev_function - | Lev_pseudo - | Lev_module_definition of Ident.t - -type program = - { module_ident : Ident.t; - main_module_block_size : int; - required_globals : Ident.Set.t; - code : lambda } - -let const_unit = Const_pointer 0 - -let lambda_unit = Lconst const_unit - -let default_function_attribute = { - inline = Default_inline; - specialise = Default_specialise; - local = Default_local; - is_a_functor = false; - stub = false; -} - -let default_stub_attribute = - { default_function_attribute with stub = true } - -(* Build sharing keys *) -(* - Those keys are later compared with Stdlib.compare. - For that reason, they should not include cycles. -*) - -exception Not_simple - -let max_raw = 32 - -let make_key e = - let count = ref 0 (* Used for controlling size *) - and make_key = Ident.make_key_generator () in - (* make_key is used for normalizing let-bound variables *) - let rec tr_rec env e = - incr count ; - if !count > max_raw then raise Not_simple ; (* Too big ! *) - match e with - | Lvar id -> - begin - try Ident.find_same id env - with Not_found -> e - end - | Lconst (Const_base (Const_string _)) -> - (* Mutable constants are not shared *) - raise Not_simple - | Lconst _ -> e - | Lapply ap -> - Lapply {ap with ap_func = tr_rec env ap.ap_func; - ap_args = tr_recs env ap.ap_args; - ap_loc = Location.none} - | Llet (Alias,_k,x,ex,e) -> (* Ignore aliases -> substitute *) - let ex = tr_rec env ex in - tr_rec (Ident.add x ex env) e - | Llet ((Strict | StrictOpt),_k,x,ex,Lvar v) when Ident.same v x -> - tr_rec env ex - | Llet (str,k,x,ex,e) -> - (* Because of side effects, keep other lets with normalized names *) - let ex = tr_rec env ex in - let y = make_key x in - Llet (str,k,y,ex,tr_rec (Ident.add x (Lvar y) env) e) - | Lprim (p,es,_) -> - Lprim (p,tr_recs env es, Location.none) - | Lswitch (e,sw,loc) -> - Lswitch (tr_rec env e,tr_sw env sw,loc) - | Lstringswitch (e,sw,d,_) -> - Lstringswitch - (tr_rec env e, - List.map (fun (s,e) -> s,tr_rec env e) sw, - tr_opt env d, - Location.none) - | Lstaticraise (i,es) -> - Lstaticraise (i,tr_recs env es) - | Lstaticcatch (e1,xs,e2) -> - Lstaticcatch (tr_rec env e1,xs,tr_rec env e2) - | Ltrywith (e1,x,e2) -> - Ltrywith (tr_rec env e1,x,tr_rec env e2) - | Lifthenelse (cond,ifso,ifnot) -> - Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot) - | Lsequence (e1,e2) -> - Lsequence (tr_rec env e1,tr_rec env e2) - | Lassign (x,e) -> - Lassign (x,tr_rec env e) - | Lsend (m,e1,e2,es,_loc) -> - Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Location.none) - | Lifused (id,e) -> Lifused (id,tr_rec env e) - | Lletrec _|Lfunction _ - | Lfor _ | Lwhile _ -(* Beware: (PR#6412) the event argument to Levent - may include cyclic structure of type Type.typexpr *) - | Levent _ -> - raise Not_simple - - and tr_recs env es = List.map (tr_rec env) es - - and tr_sw env sw = - { sw with - sw_consts = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_consts ; - sw_blocks = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_blocks ; - sw_failaction = tr_opt env sw.sw_failaction ; } - - and tr_opt env = function - | None -> None - | Some e -> Some (tr_rec env e) in - - try - Some (tr_rec Ident.empty e) - with Not_simple -> None - -(***************) - -let name_lambda strict arg fn = - match arg with - Lvar id -> fn id - | _ -> - let id = Ident.create_local "let" in - Llet(strict, Pgenval, id, arg, fn id) - -let name_lambda_list args fn = - let rec name_list names = function - [] -> fn (List.rev names) - | (Lvar _ as arg) :: rem -> - name_list (arg :: names) rem - | arg :: rem -> - let id = Ident.create_local "let" in - Llet(Strict, Pgenval, id, arg, name_list (Lvar id :: names) rem) in - name_list [] args - - -let iter_opt f = function - | None -> () - | Some e -> f e - -let shallow_iter ~tail ~non_tail:f = function - Lvar _ - | Lconst _ -> () - | Lapply{ap_func = fn; ap_args = args} -> - f fn; List.iter f args - | Lfunction{body} -> - f body - | Llet(_str, _k, _id, arg, body) -> - f arg; tail body - | Lletrec(decl, body) -> - tail body; - List.iter (fun (_id, exp) -> f exp) decl - | Lprim (Pidentity, [l], _) -> - tail l - | Lprim (Psequand, [l1; l2], _) - | Lprim (Psequor, [l1; l2], _) -> - f l1; - tail l2 - | Lprim(_p, args, _loc) -> - List.iter f args - | Lswitch(arg, sw,_) -> - f arg; - List.iter (fun (_key, case) -> tail case) sw.sw_consts; - List.iter (fun (_key, case) -> tail case) sw.sw_blocks; - iter_opt tail sw.sw_failaction - | Lstringswitch (arg,cases,default,_) -> - f arg ; - List.iter (fun (_,act) -> tail act) cases ; - iter_opt tail default - | Lstaticraise (_,args) -> - List.iter f args - | Lstaticcatch(e1, _, e2) -> - tail e1; tail e2 - | Ltrywith(e1, _, e2) -> - f e1; tail e2 - | Lifthenelse(e1, e2, e3) -> - f e1; tail e2; tail e3 - | Lsequence(e1, e2) -> - f e1; tail e2 - | Lwhile(e1, e2) -> - f e1; f e2 - | Lfor(_v, e1, e2, _dir, e3) -> - f e1; f e2; f e3 - | Lassign(_, e) -> - f e - | Lsend (_k, met, obj, args, _) -> - List.iter f (met::obj::args) - | Levent (e, _evt) -> - tail e - | Lifused (_v, e) -> - tail e - -let iter_head_constructor f l = - shallow_iter ~tail:f ~non_tail:f l - -let rec free_variables = function - | Lvar id -> Ident.Set.singleton id - | Lconst _ -> Ident.Set.empty - | Lapply{ap_func = fn; ap_args = args} -> - free_variables_list (free_variables fn) args - | Lfunction{body; params} -> - Ident.Set.diff (free_variables body) - (Ident.Set.of_list (List.map fst params)) - | Llet(_str, _k, id, arg, body) -> - Ident.Set.union - (free_variables arg) - (Ident.Set.remove id (free_variables body)) - | Lletrec(decl, body) -> - let set = free_variables_list (free_variables body) (List.map snd decl) in - Ident.Set.diff set (Ident.Set.of_list (List.map fst decl)) - | Lprim(_p, args, _loc) -> - free_variables_list Ident.Set.empty args - | Lswitch(arg, sw,_) -> - let set = - free_variables_list - (free_variables_list (free_variables arg) - (List.map snd sw.sw_consts)) - (List.map snd sw.sw_blocks) - in - begin match sw.sw_failaction with - | None -> set - | Some failaction -> Ident.Set.union set (free_variables failaction) - end - | Lstringswitch (arg,cases,default,_) -> - let set = - free_variables_list (free_variables arg) - (List.map snd cases) - in - begin match default with - | None -> set - | Some default -> Ident.Set.union set (free_variables default) - end - | Lstaticraise (_,args) -> - free_variables_list Ident.Set.empty args - | Lstaticcatch(body, (_, params), handler) -> - Ident.Set.union - (Ident.Set.diff - (free_variables handler) - (Ident.Set.of_list (List.map fst params))) - (free_variables body) - | Ltrywith(body, param, handler) -> - Ident.Set.union - (Ident.Set.remove - param - (free_variables handler)) - (free_variables body) - | Lifthenelse(e1, e2, e3) -> - Ident.Set.union - (Ident.Set.union (free_variables e1) (free_variables e2)) - (free_variables e3) - | Lsequence(e1, e2) -> - Ident.Set.union (free_variables e1) (free_variables e2) - | Lwhile(e1, e2) -> - Ident.Set.union (free_variables e1) (free_variables e2) - | Lfor(v, lo, hi, _dir, body) -> - let set = Ident.Set.union (free_variables lo) (free_variables hi) in - Ident.Set.union set (Ident.Set.remove v (free_variables body)) - | Lassign(id, e) -> - Ident.Set.add id (free_variables e) - | Lsend (_k, met, obj, args, _) -> - free_variables_list - (Ident.Set.union (free_variables met) (free_variables obj)) - args - | Levent (lam, _evt) -> - free_variables lam - | Lifused (_v, e) -> - (* Shouldn't v be considered a free variable ? *) - free_variables e - -and free_variables_list set exprs = - List.fold_left (fun set expr -> Ident.Set.union (free_variables expr) set) - set exprs - -(* Check if an action has a "when" guard *) -let raise_count = ref 0 - -let next_raise_count () = - incr raise_count ; - !raise_count - -(* Anticipated staticraise, for guards *) -let staticfail = Lstaticraise (0,[]) - -let rec is_guarded = function - | Lifthenelse(_cond, _body, Lstaticraise (0,[])) -> true - | Llet(_str, _k, _id, _lam, body) -> is_guarded body - | Levent(lam, _ev) -> is_guarded lam - | _ -> false - -let rec patch_guarded patch = function - | Lifthenelse (cond, body, Lstaticraise (0,[])) -> - Lifthenelse (cond, body, patch) - | Llet(str, k, id, lam, body) -> - Llet (str, k, id, lam, patch_guarded patch body) - | Levent(lam, ev) -> - Levent (patch_guarded patch lam, ev) - | _ -> fatal_error "Lambda.patch_guarded" - -(* Translate an access path *) - -let rec transl_address loc = function - | Env.Aident id -> - if Ident.global id - then Lprim(Pgetglobal id, [], loc) - else Lvar id - | Env.Adot(addr, pos) -> - Lprim(Pfield pos, [transl_address loc addr], loc) - -let transl_path find loc env path = - match find path env with - | exception Not_found -> - fatal_error ("Cannot find address for: " ^ (Path.name path)) - | addr -> transl_address loc addr - -(* Translation of identifiers *) - -let transl_module_path loc env path = - transl_path Env.find_module_address loc env path - -let transl_value_path loc env path = - transl_path Env.find_value_address loc env path - -let transl_extension_path loc env path = - transl_path Env.find_constructor_address loc env path - -let transl_class_path loc env path = - transl_path Env.find_class_address loc env path - -let transl_prim mod_name name = - let pers = Ident.create_persistent mod_name in - let env = Env.add_persistent_structure pers Env.empty in - let lid = Longident.Ldot (Longident.Lident mod_name, name) in - match Env.lookup_value lid env with - | path, _ -> transl_value_path Location.none env path - | exception Not_found -> - fatal_error ("Primitive " ^ name ^ " not found.") - -(* Compile a sequence of expressions *) - -let rec make_sequence fn = function - [] -> lambda_unit - | [x] -> fn x - | x::rem -> - let lam = fn x in Lsequence(lam, make_sequence fn rem) - -(* Apply a substitution to a lambda-term. - Assumes that the image of the substitution is out of reach - of the bound variables of the lambda-term (no capture). *) - -let subst update_env s lam = - let rec subst s lam = - let remove_list l s = - List.fold_left (fun s (id, _kind) -> Ident.Map.remove id s) s l - in - let module M = Ident.Map in - match lam with - | Lvar id as l -> - begin try Ident.Map.find id s with Not_found -> l end - | Lconst _ as l -> l - | Lapply ap -> - Lapply{ap with ap_func = subst s ap.ap_func; - ap_args = subst_list s ap.ap_args} - | Lfunction lf -> - let s = - List.fold_right - (fun (id, _) s -> Ident.Map.remove id s) - lf.params s - in - Lfunction {lf with body = subst s lf.body} - | Llet(str, k, id, arg, body) -> - Llet(str, k, id, subst s arg, subst (Ident.Map.remove id s) body) - | Lletrec(decl, body) -> - let s = - List.fold_left (fun s (id, _) -> Ident.Map.remove id s) - s decl - in - Lletrec(List.map (subst_decl s) decl, subst s body) - | Lprim(p, args, loc) -> Lprim(p, subst_list s args, loc) - | Lswitch(arg, sw, loc) -> - Lswitch(subst s arg, - {sw with sw_consts = List.map (subst_case s) sw.sw_consts; - sw_blocks = List.map (subst_case s) sw.sw_blocks; - sw_failaction = subst_opt s sw.sw_failaction; }, - loc) - | Lstringswitch (arg,cases,default,loc) -> - Lstringswitch - (subst s arg,List.map (subst_strcase s) cases,subst_opt s default,loc) - | Lstaticraise (i,args) -> Lstaticraise (i, subst_list s args) - | Lstaticcatch(body, (id, params), handler) -> - Lstaticcatch(subst s body, (id, params), - subst (remove_list params s) handler) - | Ltrywith(body, exn, handler) -> - Ltrywith(subst s body, exn, subst (Ident.Map.remove exn s) handler) - | Lifthenelse(e1, e2, e3) -> Lifthenelse(subst s e1, subst s e2, subst s e3) - | Lsequence(e1, e2) -> Lsequence(subst s e1, subst s e2) - | Lwhile(e1, e2) -> Lwhile(subst s e1, subst s e2) - | Lfor(v, lo, hi, dir, body) -> - Lfor(v, subst s lo, subst s hi, dir, - subst (Ident.Map.remove v s) body) - | Lassign(id, e) -> - assert(not (Ident.Map.mem id s)); - Lassign(id, subst s e) - | Lsend (k, met, obj, args, loc) -> - Lsend (k, subst s met, subst s obj, subst_list s args, loc) - | Levent (lam, evt) -> - let lev_env = - Ident.Map.fold (fun id _ env -> - match Env.find_value (Path.Pident id) evt.lev_env with - | exception Not_found -> env - | vd -> update_env id vd env - ) s evt.lev_env - in - Levent (subst s lam, { evt with lev_env }) - | Lifused (v, e) -> Lifused (v, subst s e) - and subst_list s l = List.map (subst s) l - and subst_decl s (id, exp) = (id, subst s exp) - and subst_case s (key, case) = (key, subst s case) - and subst_strcase s (key, case) = (key, subst s case) - and subst_opt s = function - | None -> None - | Some e -> Some (subst s e) - in - subst s lam - -let rename idmap lam = - let update_env oldid vd env = - let newid = Ident.Map.find oldid idmap in - Env.add_value newid vd env - in - let s = Ident.Map.map (fun new_id -> Lvar new_id) idmap in - subst update_env s lam - -let shallow_map f = function - | Lvar _ - | Lconst _ as lam -> lam - | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall; - ap_inlined; ap_specialised } -> - Lapply { - ap_func = f ap_func; - ap_args = List.map f ap_args; - ap_loc; - ap_should_be_tailcall; - ap_inlined; - ap_specialised; - } - | Lfunction { kind; params; return; body; attr; loc; } -> - Lfunction { kind; params; return; body = f body; attr; loc; } - | Llet (str, k, v, e1, e2) -> - Llet (str, k, v, f e1, f e2) - | Lletrec (idel, e2) -> - Lletrec (List.map (fun (v, e) -> (v, f e)) idel, f e2) - | Lprim (p, el, loc) -> - Lprim (p, List.map f el, loc) - | Lswitch (e, sw, loc) -> - Lswitch (f e, - { sw_numconsts = sw.sw_numconsts; - sw_consts = List.map (fun (n, e) -> (n, f e)) sw.sw_consts; - sw_numblocks = sw.sw_numblocks; - sw_blocks = List.map (fun (n, e) -> (n, f e)) sw.sw_blocks; - sw_failaction = Misc.may_map f sw.sw_failaction; - }, - loc) - | Lstringswitch (e, sw, default, loc) -> - Lstringswitch ( - f e, - List.map (fun (s, e) -> (s, f e)) sw, - Misc.may_map f default, - loc) - | Lstaticraise (i, args) -> - Lstaticraise (i, List.map f args) - | Lstaticcatch (body, id, handler) -> - Lstaticcatch (f body, id, f handler) - | Ltrywith (e1, v, e2) -> - Ltrywith (f e1, v, f e2) - | Lifthenelse (e1, e2, e3) -> - Lifthenelse (f e1, f e2, f e3) - | Lsequence (e1, e2) -> - Lsequence (f e1, f e2) - | Lwhile (e1, e2) -> - Lwhile (f e1, f e2) - | Lfor (v, e1, e2, dir, e3) -> - Lfor (v, f e1, f e2, dir, f e3) - | Lassign (v, e) -> - Lassign (v, f e) - | Lsend (k, m, o, el, loc) -> - Lsend (k, f m, f o, List.map f el, loc) - | Levent (l, ev) -> - Levent (f l, ev) - | Lifused (v, e) -> - Lifused (v, f e) - -let map f = - let rec g lam = f (shallow_map g lam) in - g - -(* To let-bind expressions to variables *) - -let bind_with_value_kind str (var, kind) exp body = - match exp with - Lvar var' when Ident.same var var' -> body - | _ -> Llet(str, kind, var, exp, body) - -let bind str var exp body = - bind_with_value_kind str (var, Pgenval) exp body - -let negate_integer_comparison = function - | Ceq -> Cne - | Cne -> Ceq - | Clt -> Cge - | Cle -> Cgt - | Cgt -> Cle - | Cge -> Clt - -let swap_integer_comparison = function - | Ceq -> Ceq - | Cne -> Cne - | Clt -> Cgt - | Cle -> Cge - | Cgt -> Clt - | Cge -> Cle - -let negate_float_comparison = function - | CFeq -> CFneq - | CFneq -> CFeq - | CFlt -> CFnlt - | CFnlt -> CFlt - | CFgt -> CFngt - | CFngt -> CFgt - | CFle -> CFnle - | CFnle -> CFle - | CFge -> CFnge - | CFnge -> CFge - -let swap_float_comparison = function - | CFeq -> CFeq - | CFneq -> CFneq - | CFlt -> CFgt - | CFnlt -> CFngt - | CFle -> CFge - | CFnle -> CFnge - | CFgt -> CFlt - | CFngt -> CFnlt - | CFge -> CFle - | CFnge -> CFnle - -let raise_kind = function - | Raise_regular -> "raise" - | Raise_reraise -> "reraise" - | Raise_notrace -> "raise_notrace" - -let merge_inline_attributes attr1 attr2 = - match attr1, attr2 with - | Default_inline, _ -> Some attr2 - | _, Default_inline -> Some attr1 - | _, _ -> - if attr1 = attr2 then Some attr1 - else None - -let function_is_curried func = - match func.kind with - | Curried -> true - | Tupled -> false - -let reset () = - raise_count := 0 diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli deleted file mode 100644 index f79ee0c7..00000000 --- a/bytecomp/lambda.mli +++ /dev/null @@ -1,428 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* The "lambda" intermediate code *) - -open Asttypes - -type compile_time_constant = - | Big_endian - | Word_size - | Int_size - | Max_wosize - | Ostype_unix - | Ostype_win32 - | Ostype_cygwin - | Backend_type - -type immediate_or_pointer = - | Immediate - | Pointer - -type initialization_or_assignment = - | Assignment - (* Initialization of in heap values, like [caml_initialize] C primitive. The - field should not have been read before and initialization should happen - only once. *) - | Heap_initialization - (* Initialization of roots only. Compiles to a simple store. - No checks are done to preserve GC invariants. *) - | Root_initialization - -type is_safe = - | Safe - | Unsafe - -type primitive = - | Pidentity - | Pbytes_to_string - | Pbytes_of_string - | Pignore - | Prevapply - | Pdirapply - (* Globals *) - | Pgetglobal of Ident.t - | Psetglobal of Ident.t - (* Operations on heap blocks *) - | Pmakeblock of int * mutable_flag * block_shape - | Pfield of int - | Pfield_computed - | Psetfield of int * immediate_or_pointer * initialization_or_assignment - | Psetfield_computed of immediate_or_pointer * initialization_or_assignment - | Pfloatfield of int - | Psetfloatfield of int * initialization_or_assignment - | Pduprecord of Types.record_representation * int - (* External call *) - | Pccall of Primitive.description - (* Exceptions *) - | Praise of raise_kind - (* Boolean operations *) - | Psequand | Psequor | Pnot - (* Integer operations *) - | Pnegint | Paddint | Psubint | Pmulint - | Pdivint of is_safe | Pmodint of is_safe - | Pandint | Porint | Pxorint - | Plslint | Plsrint | Pasrint - | Pintcomp of integer_comparison - | Poffsetint of int - | Poffsetref of int - (* Float operations *) - | Pintoffloat | Pfloatofint - | Pnegfloat | Pabsfloat - | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat - | Pfloatcomp of float_comparison - (* String operations *) - | Pstringlength | Pstringrefu | Pstringrefs - | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets - (* Array operations *) - | Pmakearray of array_kind * mutable_flag - | Pduparray of array_kind * mutable_flag - (** For [Pduparray], the argument must be an immutable array. - The arguments of [Pduparray] give the kind and mutability of the - array being *produced* by the duplication. *) - | Parraylength of array_kind - | Parrayrefu of array_kind - | Parraysetu of array_kind - | Parrayrefs of array_kind - | Parraysets of array_kind - (* Test if the argument is a block or an immediate integer *) - | Pisint - (* Test if the (integer) argument is outside an interval *) - | Pisout - (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *) - | Pbintofint of boxed_integer - | Pintofbint of boxed_integer - | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*) - | Pnegbint of boxed_integer - | Paddbint of boxed_integer - | Psubbint of boxed_integer - | Pmulbint of boxed_integer - | Pdivbint of { size : boxed_integer; is_safe : is_safe } - | Pmodbint of { size : boxed_integer; is_safe : is_safe } - | Pandbint of boxed_integer - | Porbint of boxed_integer - | Pxorbint of boxed_integer - | Plslbint of boxed_integer - | Plsrbint of boxed_integer - | Pasrbint of boxed_integer - | Pbintcomp of boxed_integer * integer_comparison - (* Operations on Bigarrays: (unsafe, #dimensions, kind, layout) *) - | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout - | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout - (* size of the nth dimension of a Bigarray *) - | Pbigarraydim of int - (* load/set 16,32,64 bits from a string: (unsafe)*) - | Pstring_load_16 of bool - | Pstring_load_32 of bool - | Pstring_load_64 of bool - | Pbytes_load_16 of bool - | Pbytes_load_32 of bool - | Pbytes_load_64 of bool - | Pbytes_set_16 of bool - | Pbytes_set_32 of bool - | Pbytes_set_64 of bool - (* load/set 16,32,64 bits from a - (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *) - | Pbigstring_load_16 of bool - | Pbigstring_load_32 of bool - | Pbigstring_load_64 of bool - | Pbigstring_set_16 of bool - | Pbigstring_set_32 of bool - | Pbigstring_set_64 of bool - (* Compile time constants *) - | Pctconst of compile_time_constant - (* byte swap *) - | Pbswap16 - | Pbbswap of boxed_integer - (* Integer to external pointer *) - | Pint_as_pointer - (* Inhibition of optimisation *) - | Popaque - -and integer_comparison = - Ceq | Cne | Clt | Cgt | Cle | Cge - -and float_comparison = - CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge - -and array_kind = - Pgenarray | Paddrarray | Pintarray | Pfloatarray - -and value_kind = - Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval - -and block_shape = - value_kind list option - -and boxed_integer = Primitive.boxed_integer = - Pnativeint | Pint32 | Pint64 - -and bigarray_kind = - Pbigarray_unknown - | Pbigarray_float32 | Pbigarray_float64 - | Pbigarray_sint8 | Pbigarray_uint8 - | Pbigarray_sint16 | Pbigarray_uint16 - | Pbigarray_int32 | Pbigarray_int64 - | Pbigarray_caml_int | Pbigarray_native_int - | Pbigarray_complex32 | Pbigarray_complex64 - -and bigarray_layout = - Pbigarray_unknown_layout - | Pbigarray_c_layout - | Pbigarray_fortran_layout - -and raise_kind = - | Raise_regular - | Raise_reraise - | Raise_notrace - -val equal_primitive : primitive -> primitive -> bool - -val equal_value_kind : value_kind -> value_kind -> bool - -val equal_boxed_integer : boxed_integer -> boxed_integer -> bool - -type structured_constant = - Const_base of constant - | Const_pointer of int - | Const_block of int * structured_constant list - | Const_float_array of string list - | Const_immstring of string - -type inline_attribute = - | Always_inline (* [@inline] or [@inline always] *) - | Never_inline (* [@inline never] *) - | Unroll of int (* [@unroll x] *) - | Default_inline (* no [@inline] attribute *) - -val equal_inline_attribute : inline_attribute -> inline_attribute -> bool - -type specialise_attribute = - | Always_specialise (* [@specialise] or [@specialise always] *) - | Never_specialise (* [@specialise never] *) - | Default_specialise (* no [@specialise] attribute *) - -val equal_specialise_attribute - : specialise_attribute - -> specialise_attribute - -> bool - -type local_attribute = - | Always_local (* [@local] or [@local always] *) - | Never_local (* [@local never] *) - | Default_local (* [@local maybe] or no [@local] attribute *) - -type function_kind = Curried | Tupled - -type let_kind = Strict | Alias | StrictOpt | Variable -(* Meaning of kinds for let x = e in e': - Strict: e may have side-effects; always evaluate e first - (If e is a simple expression, e.g. a variable or constant, - we may still substitute e'[x/e].) - Alias: e is pure, we can substitute e'[x/e] if x has 0 or 1 occurrences - in e' - StrictOpt: e does not have side-effects, but depend on the store; - we can discard e if x does not appear in e' - Variable: the variable x is assigned later in e' - *) - -type meth_kind = Self | Public | Cached - -val equal_meth_kind : meth_kind -> meth_kind -> bool - -type shared_code = (int * int) list (* stack size -> code label *) - -type function_attribute = { - inline : inline_attribute; - specialise : specialise_attribute; - local: local_attribute; - is_a_functor: bool; - stub: bool; -} - -type lambda = - Lvar of Ident.t - | Lconst of structured_constant - | Lapply of lambda_apply - | Lfunction of lfunction - | Llet of let_kind * value_kind * Ident.t * lambda * lambda - | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t - | Lswitch of lambda * lambda_switch * Location.t -(* switch on strings, clauses are sorted by string order, - strings are pairwise distinct *) - | Lstringswitch of - lambda * (string * lambda) list * lambda option * Location.t - | Lstaticraise of int * lambda list - | Lstaticcatch of lambda * (int * (Ident.t * value_kind) list) * lambda - | Ltrywith of lambda * Ident.t * lambda - | Lifthenelse of lambda * lambda * lambda - | Lsequence of lambda * lambda - | Lwhile of lambda * lambda - | Lfor of Ident.t * lambda * lambda * direction_flag * lambda - | Lassign of Ident.t * lambda - | Lsend of meth_kind * lambda * lambda * lambda list * Location.t - | Levent of lambda * lambda_event - | Lifused of Ident.t * lambda - -and lfunction = - { kind: function_kind; - params: (Ident.t * value_kind) list; - return: value_kind; - body: lambda; - attr: function_attribute; (* specified with [@inline] attribute *) - loc : Location.t; } - -and lambda_apply = - { ap_func : lambda; - ap_args : lambda list; - ap_loc : Location.t; - ap_should_be_tailcall : bool; (* true if [@tailcall] was specified *) - ap_inlined : inline_attribute; (* specified with the [@inlined] attribute *) - ap_specialised : specialise_attribute; } - -and lambda_switch = - { sw_numconsts: int; (* Number of integer cases *) - sw_consts: (int * lambda) list; (* Integer cases *) - sw_numblocks: int; (* Number of tag block cases *) - sw_blocks: (int * lambda) list; (* Tag block cases *) - sw_failaction : lambda option} (* Action to take if failure *) -and lambda_event = - { lev_loc: Location.t; - lev_kind: lambda_event_kind; - lev_repr: int ref option; - lev_env: Env.t } - -and lambda_event_kind = - Lev_before - | Lev_after of Types.type_expr - | Lev_function - | Lev_pseudo - | Lev_module_definition of Ident.t - -type program = - { module_ident : Ident.t; - main_module_block_size : int; - required_globals : Ident.Set.t; (* Modules whose initializer side effects - must occur before [code]. *) - code : lambda } -(* Lambda code for the middle-end. - * In the closure case the code is a sequence of assignments to a - preallocated block of size [main_module_block_size] using - (Setfield(Getglobal(module_ident))). The size is used to preallocate - the block. - * In the flambda case the code is an expression returning a block - value of size [main_module_block_size]. The size is used to build - the module root as an initialize_symbol - Initialize_symbol(module_name, 0, - [getfield 0; ...; getfield (main_module_block_size - 1)]) -*) - -(* Sharing key *) -val make_key: lambda -> lambda option - -val const_unit: structured_constant -val lambda_unit: lambda -val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda -val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda - -val iter_head_constructor: (lambda -> unit) -> lambda -> unit -(** [iter_head_constructor f lam] apply [f] to only the first level of - sub expressions of [lam]. It does not recursively traverse the - expression. -*) - -val shallow_iter: - tail:(lambda -> unit) -> - non_tail:(lambda -> unit) -> - lambda -> unit -(** Same as [iter_head_constructor], but use a different callback for - sub-terms which are in tail position or not. *) - -val transl_prim: string -> string -> lambda -(** Translate a value from a persistent module. For instance: - - {[ - transl_internal_value "CamlinternalLazy" "force" - ]} -*) - -val free_variables: lambda -> Ident.Set.t - -val transl_module_path: Location.t -> Env.t -> Path.t -> lambda -val transl_value_path: Location.t -> Env.t -> Path.t -> lambda -val transl_extension_path: Location.t -> Env.t -> Path.t -> lambda -val transl_class_path: Location.t -> Env.t -> Path.t -> lambda - -val make_sequence: ('a -> lambda) -> 'a list -> lambda - -val subst: (Ident.t -> Types.value_description -> Env.t -> Env.t) -> - lambda Ident.Map.t -> lambda -> lambda -(** [subst env_update_fun s lt] applies a substitution [s] to the lambda-term - [lt]. - - Assumes that the image of the substitution is out of reach - of the bound variables of the lambda-term (no capture). - - [env_update_fun] is used to refresh the environment contained in debug - events. *) - -val rename : Ident.t Ident.Map.t -> lambda -> lambda -(** A version of [subst] specialized for the case where we're just renaming - idents. *) - -val map : (lambda -> lambda) -> lambda -> lambda - (** Bottom-up rewriting, applying the function on - each node from the leaves to the root. *) - -val shallow_map : (lambda -> lambda) -> lambda -> lambda - (** Rewrite each immediate sub-term with the function. *) - -val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda -val bind_with_value_kind: - let_kind -> (Ident.t * value_kind) -> lambda -> lambda -> lambda - -val negate_integer_comparison : integer_comparison -> integer_comparison -val swap_integer_comparison : integer_comparison -> integer_comparison - -val negate_float_comparison : float_comparison -> float_comparison -val swap_float_comparison : float_comparison -> float_comparison - -val default_function_attribute : function_attribute -val default_stub_attribute : function_attribute - -val function_is_curried : lfunction -> bool - -(***********************) -(* For static failures *) -(***********************) - -(* Get a new static failure ident *) -val next_raise_count : unit -> int - -val staticfail : lambda (* Anticipated static failure *) - -(* Check anticipated failure, substitute its final value *) -val is_guarded: lambda -> bool -val patch_guarded : lambda -> lambda -> lambda - -val raise_kind: raise_kind -> string - -val merge_inline_attributes - : inline_attribute - -> inline_attribute - -> inline_attribute option - -val reset: unit -> unit diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml deleted file mode 100644 index 0b31ecbc..00000000 --- a/bytecomp/matching.ml +++ /dev/null @@ -1,3240 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Compilation of pattern matching *) - -open Misc -open Asttypes -open Types -open Typedtree -open Lambda -open Parmatch -open Printf -open Printpat - - -let dbg = false - -(* See Peyton-Jones, ``The Implementation of functional programming - languages'', chapter 5. *) -(* - Well, it was true at the beginning of the world. - Now, see Lefessant-Maranget ``Optimizing Pattern-Matching'' ICFP'2001 -*) - -(* - Compatibility predicate that considers potential rebindings of constructors - of an extension type. - - "may_compat p q" returns false when p and q never admit a common instance; - returns true when they may have a common instance. -*) - -module MayCompat = - Parmatch.Compat (struct let equal = Types.may_equal_constr end) -let may_compat = MayCompat.compat -and may_compats = MayCompat.compats - -(* - Many functions on the various data structures of the algorithm : - - Pattern matrices. - - Default environments: mapping from matrices to exit numbers. - - Contexts: matrices whose column are partitioned into - left and right. - - Jump summaries: mapping from exit numbers to contexts -*) - - -let string_of_lam lam = - Printlambda.lambda Format.str_formatter lam ; - Format.flush_str_formatter () - -let all_record_args lbls = match lbls with -| (_,{lbl_all=lbl_all},_)::_ -> - let t = - Array.map - (fun lbl -> mknoloc (Longident.Lident "?temp?"), lbl,omega) - lbl_all in - List.iter - (fun ((_, lbl,_) as x) -> t.(lbl.lbl_pos) <- x) - lbls ; - Array.to_list t -| _ -> fatal_error "Parmatch.all_record_args" - -type matrix = pattern list list - -let add_omega_column pss = List.map (fun ps -> omega::ps) pss - -type ctx = {left:pattern list ; right:pattern list} - -let pretty_ctx ctx = - List.iter - (fun {left=left ; right=right} -> - Format.eprintf "LEFT:%a RIGHT:%a\n" pretty_line left pretty_line right) - ctx - -let le_ctx c1 c2 = - le_pats c1.left c2.left && - le_pats c1.right c2.right - -let lshift {left=left ; right=right} = match right with -| x::xs -> {left=x::left ; right=xs} -| _ -> assert false - -let lforget {left=left ; right=right} = match right with -| _::xs -> {left=omega::left ; right=xs} -| _ -> assert false - -let rec small_enough n = function - | [] -> true - | _::rem -> - if n <= 0 then false - else small_enough (n-1) rem - -let ctx_lshift ctx = - if small_enough (!Clflags.match_context_rows - 1) ctx then - List.map lshift ctx - else (* Context pruning *) begin - get_mins le_ctx (List.map lforget ctx) - end - -let rshift {left=left ; right=right} = match left with -| p::ps -> {left=ps ; right=p::right} -| _ -> assert false - -let ctx_rshift ctx = List.map rshift ctx - -let rec nchars n ps = - if n <= 0 then [],ps - else match ps with - | p::rem -> - let chars, cdrs = nchars (n-1) rem in - p::chars,cdrs - | _ -> assert false - -let rshift_num n {left=left ; right=right} = - let shifted,left = nchars n left in - {left=left ; right = shifted@right} - -let ctx_rshift_num n ctx = List.map (rshift_num n) ctx - -(* Recombination of contexts (eg: (_,_)::p1::p2::rem -> (p1,p2)::rem) - All mutable fields are replaced by '_', since side-effects in - guards can alter these fields *) - -let combine {left=left ; right=right} = match left with -| p::ps -> {left=ps ; right=set_args_erase_mutable p right} -| _ -> assert false - -let ctx_combine ctx = List.map combine ctx - -let ncols = function - | [] -> 0 - | ps::_ -> List.length ps - - -exception NoMatch -exception OrPat - -let filter_matrix matcher pss = - - let rec filter_rec = function - | (p::ps)::rem -> - begin match p.pat_desc with - | Tpat_alias (p,_,_) -> - filter_rec ((p::ps)::rem) - | Tpat_var _ -> - filter_rec ((omega::ps)::rem) - | _ -> - begin - let rem = filter_rec rem in - try - matcher p ps::rem - with - | NoMatch -> rem - | OrPat -> - match p.pat_desc with - | Tpat_or (p1,p2,_) -> filter_rec [(p1::ps) ;(p2::ps)]@rem - | _ -> assert false - end - end - | [] -> [] - | _ -> - pretty_matrix Format.err_formatter pss ; - fatal_error "Matching.filter_matrix" in - filter_rec pss - -let make_default matcher env = - let rec make_rec = function - | [] -> [] - | ([[]],i)::_ -> [[[]],i] - | (pss,i)::rem -> - let rem = make_rec rem in - match filter_matrix matcher pss with - | [] -> rem - | ([]::_) -> ([[]],i)::rem - | pss -> (pss,i)::rem in - make_rec env - -let ctx_matcher p = - let p = normalize_pat p in - match p.pat_desc with - | Tpat_construct (_, cstr,omegas) -> - (fun q rem -> match q.pat_desc with - | Tpat_construct (_, cstr',args) -(* NB: may_constr_equal considers (potential) constructor rebinding *) - when Types.may_equal_constr cstr cstr' -> - p,args@rem - | Tpat_any -> p,omegas @ rem - | _ -> raise NoMatch) - | Tpat_constant cst -> - (fun q rem -> match q.pat_desc with - | Tpat_constant cst' when const_compare cst cst' = 0 -> - p,rem - | Tpat_any -> p,rem - | _ -> raise NoMatch) - | Tpat_variant (lab,Some omega,_) -> - (fun q rem -> match q.pat_desc with - | Tpat_variant (lab',Some arg,_) when lab=lab' -> - p,arg::rem - | Tpat_any -> p,omega::rem - | _ -> raise NoMatch) - | Tpat_variant (lab,None,_) -> - (fun q rem -> match q.pat_desc with - | Tpat_variant (lab',None,_) when lab=lab' -> - p,rem - | Tpat_any -> p,rem - | _ -> raise NoMatch) - | Tpat_array omegas -> - let len = List.length omegas in - (fun q rem -> match q.pat_desc with - | Tpat_array args when List.length args = len -> p,args @ rem - | Tpat_any -> p, omegas @ rem - | _ -> raise NoMatch) - | Tpat_tuple omegas -> - let len = List.length omegas in - (fun q rem -> match q.pat_desc with - | Tpat_tuple args when List.length args = len -> p,args @ rem - | Tpat_any -> p, omegas @ rem - | _ -> raise NoMatch) - | Tpat_record (((_, lbl, _) :: _) as l,_) -> (* Records are normalized *) - let len = Array.length lbl.lbl_all in - (fun q rem -> match q.pat_desc with - | Tpat_record (((_, lbl', _) :: _) as l',_) - when Array.length lbl'.lbl_all = len -> - let l' = all_record_args l' in - p, List.fold_right (fun (_, _,p) r -> p::r) l' rem - | Tpat_any -> p,List.fold_right (fun (_, _,p) r -> p::r) l rem - | _ -> raise NoMatch) - | Tpat_lazy omega -> - (fun q rem -> match q.pat_desc with - | Tpat_lazy arg -> p, (arg::rem) - | Tpat_any -> p, (omega::rem) - | _ -> raise NoMatch) - | _ -> fatal_error "Matching.ctx_matcher" - - - - -let filter_ctx q ctx = - - let matcher = ctx_matcher q in - - let rec filter_rec = function - | ({right=p::ps} as l)::rem -> - begin match p.pat_desc with - | Tpat_or (p1,p2,_) -> - filter_rec ({l with right=p1::ps}::{l with right=p2::ps}::rem) - | Tpat_alias (p,_,_) -> - filter_rec ({l with right=p::ps}::rem) - | Tpat_var _ -> - filter_rec ({l with right=omega::ps}::rem) - | _ -> - begin let rem = filter_rec rem in - try - let to_left, right = matcher p ps in - {left=to_left::l.left ; right=right}::rem - with - | NoMatch -> rem - end - end - | [] -> [] - | _ -> fatal_error "Matching.filter_ctx" in - - filter_rec ctx - -let select_columns pss ctx = - let n = ncols pss in - List.fold_right - (fun ps r -> - List.fold_right - (fun {left=left ; right=right} r -> - let transfert, right = nchars n right in - try - {left = lubs transfert ps @ left ; right=right}::r - with - | Empty -> r) - ctx r) - pss [] - -let ctx_lub p ctx = - List.fold_right - (fun {left=left ; right=right} r -> - match right with - | q::rem -> - begin try - {left=left ; right = lub p q::rem}::r - with - | Empty -> r - end - | _ -> fatal_error "Matching.ctx_lub") - ctx [] - -let ctx_match ctx pss = - List.exists - (fun {right=qs} -> List.exists (fun ps -> may_compats qs ps) pss) - ctx - -type jumps = (int * ctx list) list - -let pretty_jumps (env : jumps) = match env with -| [] -> () -| _ -> - List.iter - (fun (i,ctx) -> - Printf.fprintf stderr "jump for %d\n" i ; - pretty_ctx ctx) - env - - -let rec jumps_extract i = function - | [] -> [],[] - | (j,pss) as x::rem as all -> - if i=j then pss,rem - else if j < i then [],all - else - let r,rem = jumps_extract i rem in - r,(x::rem) - -let rec jumps_remove i = function - | [] -> [] - | (j,_)::rem when i=j -> rem - | x::rem -> x::jumps_remove i rem - -let jumps_empty = [] -and jumps_is_empty = function - | [] -> true - | _ -> false - -let jumps_singleton i = function - | [] -> [] - | ctx -> [i,ctx] - -let jumps_add i pss jumps = match pss with -| [] -> jumps -| _ -> - let rec add = function - | [] -> [i,pss] - | (j,qss) as x::rem as all -> - if j > i then x::add rem - else if j < i then (i,pss)::all - else (i,(get_mins le_ctx (pss@qss)))::rem in - add jumps - - -let rec jumps_union (env1:(int*ctx list)list) env2 = match env1,env2 with -| [],_ -> env2 -| _,[] -> env1 -| ((i1,pss1) as x1::rem1), ((i2,pss2) as x2::rem2) -> - if i1=i2 then - (i1,get_mins le_ctx (pss1@pss2))::jumps_union rem1 rem2 - else if i1 > i2 then - x1::jumps_union rem1 env2 - else - x2::jumps_union env1 rem2 - - -let rec merge = function - | env1::env2::rem -> jumps_union env1 env2::merge rem - | envs -> envs - -let rec jumps_unions envs = match envs with - | [] -> [] - | [env] -> env - | _ -> jumps_unions (merge envs) - -let jumps_map f env = - List.map - (fun (i,pss) -> i,f pss) - env - -(* Pattern matching before any compilation *) - -type pattern_matching = - { mutable cases : (pattern list * lambda) list; - args : (lambda * let_kind) list ; - default : (matrix * int) list} - -(* Pattern matching after application of both the or-pat rule and the - mixture rule *) - -type pm_or_compiled = - {body : pattern_matching ; - handlers : - (matrix * int * (Ident.t * Lambda.value_kind) list * pattern_matching) - list; - or_matrix : matrix ; } - -type pm_half_compiled = - | PmOr of pm_or_compiled - | PmVar of pm_var_compiled - | Pm of pattern_matching - -and pm_var_compiled = - {inside : pm_half_compiled ; var_arg : lambda ; } - -type pm_half_compiled_info = - {me : pm_half_compiled ; - matrix : matrix ; - top_default : (matrix * int) list ; } - -let pretty_cases cases = - List.iter - (fun (ps,_l) -> - List.iter - (fun p -> Format.eprintf " %a%!" top_pretty p) - ps ; - Format.eprintf "\n") - cases - -let pretty_def def = - Format.eprintf "+++++ Defaults +++++\n" ; - List.iter - (fun (pss,i) -> Format.eprintf "Matrix for %d\n%a" i pretty_matrix pss) - def ; - Format.eprintf "+++++++++++++++++++++\n" - -let pretty_pm pm = - pretty_cases pm.cases ; - if pm.default <> [] then - pretty_def pm.default - - -let rec pretty_precompiled = function - | Pm pm -> - Format.eprintf "++++ PM ++++\n" ; - pretty_pm pm - | PmVar x -> - Format.eprintf "++++ VAR ++++\n" ; - pretty_precompiled x.inside - | PmOr x -> - Format.eprintf "++++ OR ++++\n" ; - pretty_pm x.body ; - pretty_matrix Format.err_formatter x.or_matrix ; - List.iter - (fun (_,i,_,pm) -> - eprintf "++ Handler %d ++\n" i ; - pretty_pm pm) - x.handlers - -let pretty_precompiled_res first nexts = - pretty_precompiled first ; - List.iter - (fun (e, pmh) -> - eprintf "** DEFAULT %d **\n" e ; - pretty_precompiled pmh) - nexts - - - -(* Identifying some semantically equivalent lambda-expressions, - Our goal here is also to - find alpha-equivalent (simple) terms *) - -(* However, as shown by PR#6359 such sharing may hinders the - lambda-code invariant that all bound idents are unique, - when switches are compiled to test sequences. - The definitive fix is the systematic introduction of exit/catch - in case action sharing is present. -*) - - -module StoreExp = - Switch.Store - (struct - type t = lambda - type key = lambda - let compare_key = Stdlib.compare - let make_key = Lambda.make_key - end) - - -let make_exit i = Lstaticraise (i,[]) - -(* Introduce a catch, if worth it *) -let make_catch d k = match d with -| Lstaticraise (_,[]) -> k d -| _ -> - let e = next_raise_count () in - Lstaticcatch (k (make_exit e),(e,[]),d) - -(* Introduce a catch, if worth it, delayed version *) -let rec as_simple_exit = function - | Lstaticraise (i,[]) -> Some i - | Llet (Alias,_k,_,_,e) -> as_simple_exit e - | _ -> None - - -let make_catch_delayed handler = match as_simple_exit handler with -| Some i -> i,(fun act -> act) -| None -> - let i = next_raise_count () in -(* - Printf.eprintf "SHARE LAMBDA: %i\n%s\n" i (string_of_lam handler); -*) - i, - (fun body -> match body with - | Lstaticraise (j,_) -> - if i=j then handler else body - | _ -> Lstaticcatch (body,(i,[]),handler)) - - -let raw_action l = - match make_key l with | Some l -> l | None -> l - - -let tr_raw act = match make_key act with -| Some act -> act -| None -> raise Exit - -let same_actions = function - | [] -> None - | [_,act] -> Some act - | (_,act0) :: rem -> - try - let raw_act0 = tr_raw act0 in - let rec s_rec = function - | [] -> Some act0 - | (_,act)::rem -> - if raw_act0 = tr_raw act then - s_rec rem - else - None in - s_rec rem - with - | Exit -> None - - -(* Test for swapping two clauses *) - -let up_ok_action act1 act2 = - try - let raw1 = tr_raw act1 - and raw2 = tr_raw act2 in - raw1 = raw2 - with - | Exit -> false - -let up_ok (ps,act_p) l = - List.for_all - (fun (qs,act_q) -> - up_ok_action act_p act_q || not (may_compats ps qs)) - l - -(* - The simplify function normalizes the first column of the match - - records are expanded so that they possess all fields - - aliases are removed and replaced by bindings in actions. - However or-patterns are simplified differently, - - aliases are not removed - - or-patterns (_|p) are changed into _ -*) - -exception Var of pattern - -let simplify_or p = - let rec simpl_rec p = match p with - | {pat_desc = Tpat_any|Tpat_var _} -> raise (Var p) - | {pat_desc = Tpat_alias (q,id,s)} -> - begin try - {p with pat_desc = Tpat_alias (simpl_rec q,id,s)} - with - | Var q -> raise (Var {p with pat_desc = Tpat_alias (q,id,s)}) - end - | {pat_desc = Tpat_or (p1,p2,o)} -> - let q1 = simpl_rec p1 in - begin try - let q2 = simpl_rec p2 in - {p with pat_desc = Tpat_or (q1, q2, o)} - with - | Var q2 -> raise (Var {p with pat_desc = Tpat_or (q1, q2, o)}) - end - | {pat_desc = Tpat_record (lbls,closed)} -> - let all_lbls = all_record_args lbls in - {p with pat_desc=Tpat_record (all_lbls, closed)} - | _ -> p in - try - simpl_rec p - with - | Var p -> p - -let simplify_cases args cls = match args with -| [] -> assert false -| (arg,_)::_ -> - let rec simplify = function - | [] -> [] - | ((pat :: patl, action) as cl) :: rem -> - begin match pat.pat_desc with - | Tpat_var (id, _) -> - let k = Typeopt.value_kind pat.pat_env pat.pat_type in - (omega :: patl, bind_with_value_kind Alias (id, k) arg action) :: - simplify rem - | Tpat_any -> - cl :: simplify rem - | Tpat_alias(p, id,_) -> - let k = Typeopt.value_kind pat.pat_env pat.pat_type in - simplify ((p :: patl, - bind_with_value_kind Alias (id, k) arg action) :: rem) - | Tpat_record ([],_) -> - (omega :: patl, action):: - simplify rem - | Tpat_record (lbls, closed) -> - let all_lbls = all_record_args lbls in - let full_pat = - {pat with pat_desc=Tpat_record (all_lbls, closed)} in - (full_pat::patl,action):: - simplify rem - | Tpat_or _ -> - let pat_simple = simplify_or pat in - begin match pat_simple.pat_desc with - | Tpat_or _ -> - (pat_simple :: patl, action) :: - simplify rem - | _ -> - simplify ((pat_simple::patl,action) :: rem) - end - | _ -> cl :: simplify rem - end - | _ -> assert false in - - simplify cls - - - -(* Once matchings are simplified one can easily find - their nature *) - -let rec what_is_cases cases = match cases with -| ({pat_desc=Tpat_any} :: _, _) :: rem -> what_is_cases rem -| (({pat_desc=(Tpat_var _|Tpat_or (_,_,_)|Tpat_alias (_,_,_))}::_),_)::_ - -> assert false (* applies to simplified matchings only *) -| (p::_,_)::_ -> p -| [] -> omega -| _ -> assert false - - - -(* A few operations on default environments *) -let as_matrix cases = get_mins le_pats (List.map (fun (ps,_) -> ps) cases) - -let cons_default matrix raise_num default = - match matrix with - | [] -> default - | _ -> (matrix,raise_num)::default - -let default_compat p def = - List.fold_right - (fun (pss,i) r -> - let qss = - List.fold_right - (fun qs r -> match qs with - | q::rem when may_compat p q -> rem::r - | _ -> r) - pss [] in - match qss with - | [] -> r - | _ -> (qss,i)::r) - def [] - -(* Or-pattern expansion, variables are a complication w.r.t. the article *) - -exception Cannot_flatten - -let mk_alpha_env arg aliases ids = - List.map - (fun id -> id, - if List.mem id aliases then - match arg with - | Some v -> v - | _ -> raise Cannot_flatten - else - Ident.create_local (Ident.name id)) - ids - -let rec explode_or_pat arg patl mk_action rem vars aliases = function - | {pat_desc = Tpat_or (p1,p2,_)} -> - explode_or_pat - arg patl mk_action - (explode_or_pat arg patl mk_action rem vars aliases p2) - vars aliases p1 - | {pat_desc = Tpat_alias (p,id, _)} -> - explode_or_pat arg patl mk_action rem vars (id::aliases) p - | {pat_desc = Tpat_var (x, _)} -> - let env = mk_alpha_env arg (x::aliases) vars in - (omega::patl,mk_action (List.map snd env))::rem - | p -> - let env = mk_alpha_env arg aliases vars in - (alpha_pat env p::patl,mk_action (List.map snd env))::rem - -let pm_free_variables {cases=cases} = - List.fold_right - (fun (_,act) r -> Ident.Set.union (free_variables act) r) - cases Ident.Set.empty - - -(* Basic grouping predicates *) -let pat_as_constr = function - | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr - | _ -> fatal_error "Matching.pat_as_constr" - -let group_const_int = function - | {pat_desc= Tpat_constant Const_int _ } -> true - | _ -> false - -let group_const_char = function - | {pat_desc= Tpat_constant Const_char _ } -> true - | _ -> false - -let group_const_string = function - | {pat_desc= Tpat_constant Const_string _ } -> true - | _ -> false - -let group_const_float = function - | {pat_desc= Tpat_constant Const_float _ } -> true - | _ -> false - -let group_const_int32 = function - | {pat_desc= Tpat_constant Const_int32 _ } -> true - | _ -> false - -let group_const_int64 = function - | {pat_desc= Tpat_constant Const_int64 _ } -> true - | _ -> false - -let group_const_nativeint = function - | {pat_desc= Tpat_constant Const_nativeint _ } -> true - | _ -> false - -and group_constructor = function - | {pat_desc = Tpat_construct (_,_,_)} -> true - | _ -> false - -and group_variant = function - | {pat_desc = Tpat_variant (_, _, _)} -> true - | _ -> false - -and group_var = function - | {pat_desc=Tpat_any} -> true - | _ -> false - -and group_tuple = function - | {pat_desc = (Tpat_tuple _|Tpat_any)} -> true - | _ -> false - -and group_record = function - | {pat_desc = (Tpat_record _|Tpat_any)} -> true - | _ -> false - -and group_array = function - | {pat_desc=Tpat_array _} -> true - | _ -> false - -and group_lazy = function - | {pat_desc = Tpat_lazy _} -> true - | _ -> false - -let get_group p = match p.pat_desc with -| Tpat_any -> group_var -| Tpat_constant Const_int _ -> group_const_int -| Tpat_constant Const_char _ -> group_const_char -| Tpat_constant Const_string _ -> group_const_string -| Tpat_constant Const_float _ -> group_const_float -| Tpat_constant Const_int32 _ -> group_const_int32 -| Tpat_constant Const_int64 _ -> group_const_int64 -| Tpat_constant Const_nativeint _ -> group_const_nativeint -| Tpat_construct _ -> group_constructor -| Tpat_tuple _ -> group_tuple -| Tpat_record _ -> group_record -| Tpat_array _ -> group_array -| Tpat_variant (_,_,_) -> group_variant -| Tpat_lazy _ -> group_lazy -| _ -> fatal_error "Matching.get_group" - - - -let is_or p = match p.pat_desc with -| Tpat_or _ -> true -| _ -> false - -(* Conditions for appending to the Or matrix *) -let conda p q = not (may_compat p q) -and condb act ps qs = not (is_guarded act) && Parmatch.le_pats qs ps - -let or_ok p ps l = - List.for_all - (function - | ({pat_desc=Tpat_or _} as q::qs,act) -> - conda p q || condb act ps qs - | _ -> true) - l - -(* Insert or append a pattern in the Or matrix *) - -let equiv_pat p q = le_pat p q && le_pat q p - -let rec get_equiv p l = match l with - | (q::_,_) as cl::rem -> - if equiv_pat p q then - let others,rem = get_equiv p rem in - cl::others,rem - else - [],l - | _ -> [],l - - -let insert_or_append p ps act ors no = - let rec attempt seen = function - | (q::qs,act_q) as cl::rem -> - if is_or q then begin - if may_compat p q then - if - Typedtree.pat_bound_idents p = [] && - Typedtree.pat_bound_idents q = [] && - equiv_pat p q - then (* attempt insert, for equivalent orpats with no variables *) - let _, not_e = get_equiv q rem in - if - or_ok p ps not_e && (* check append condition for head of O *) - List.for_all (* check insert condition for tail of O *) - (fun cl -> match cl with - | (q::_,_) -> not (may_compat p q) - | _ -> assert false) - seen - then (* insert *) - List.rev_append seen ((p::ps,act)::cl::rem), no - else (* fail to insert or append *) - ors,(p::ps,act)::no - else if condb act_q ps qs then (* check condition (b) for append *) - attempt (cl::seen) rem - else - ors,(p::ps,act)::no - else (* p # q, go on with append/insert *) - attempt (cl::seen) rem - end else (* q is not an or-pat, go on with append/insert *) - attempt (cl::seen) rem - | _ -> (* [] in fact *) - (p::ps,act)::ors,no in (* success in appending *) - attempt [] ors - -(* Reconstruct default information from half_compiled pm list *) - -let rec rebuild_matrix pmh = match pmh with - | Pm pm -> as_matrix pm.cases - | PmOr {or_matrix=m} -> m - | PmVar x -> add_omega_column (rebuild_matrix x.inside) - -let rec rebuild_default nexts def = match nexts with -| [] -> def -| (e, pmh)::rem -> - (add_omega_column (rebuild_matrix pmh), e):: - rebuild_default rem def - -let rebuild_nexts arg nexts k = - List.fold_right - (fun (e, pm) k -> (e, PmVar {inside=pm ; var_arg=arg})::k) - nexts k - - -(* - Split a matching. - Splitting is first directed by or-patterns, then by - tests (e.g. constructors)/variable transitions. - - The approach is greedy, every split function attempts to - raise rows as much as possible in the top matrix, - then splitting applies again to the remaining rows. - - Some precompilation of or-patterns and - variable pattern occurs. Mostly this means that bindings - are performed now, being replaced by let-bindings - in actions (cf. simplify_cases). - - Additionally, if the match argument is a variable, matchings whose - first column is made of variables only are split further - (cf. precompile_var). - -*) - - -let rec split_or argo cls args def = - - let cls = simplify_cases args cls in - - let rec do_split before ors no = function - | [] -> - cons_next - (List.rev before) (List.rev ors) (List.rev no) - | ((p::ps,act) as cl)::rem -> - if up_ok cl no then - if is_or p then - let ors, no = insert_or_append p ps act ors no in - do_split before ors no rem - else begin - if up_ok cl ors then - do_split (cl::before) ors no rem - else if or_ok p ps ors then - do_split before (cl::ors) no rem - else - do_split before ors (cl::no) rem - end - else - do_split before ors (cl::no) rem - | _ -> assert false - - and cons_next yes yesor = function - | [] -> - precompile_or argo yes yesor args def [] - | rem -> - let {me=next ; matrix=matrix ; top_default=def},nexts = - do_split [] [] [] rem in - let idef = next_raise_count () in - precompile_or - argo yes yesor args - (cons_default matrix idef def) - ((idef,next)::nexts) in - - do_split [] [] [] cls - -(* Ultra-naive splitting, close to semantics, used for extension, - as potential rebind prevents any kind of optimisation *) - -and split_naive cls args def k = - - let rec split_exc cstr0 yes = function - | [] -> - let yes = List.rev yes in - { me = Pm {cases=yes; args=args; default=def;} ; - matrix = as_matrix yes ; - top_default=def}, - k - | (p::_,_ as cl)::rem -> - if group_constructor p then - let cstr = pat_as_constr p in - if cstr = cstr0 then split_exc cstr0 (cl::yes) rem - else - let yes = List.rev yes in - let {me=next ; matrix=matrix ; top_default=def}, nexts = - split_exc cstr [cl] rem in - let idef = next_raise_count () in - let def = cons_default matrix idef def in - { me = Pm {cases=yes; args=args; default=def} ; - matrix = as_matrix yes ; - top_default = def; }, - (idef,next)::nexts - else - let yes = List.rev yes in - let {me=next ; matrix=matrix ; top_default=def}, nexts = - split_noexc [cl] rem in - let idef = next_raise_count () in - let def = cons_default matrix idef def in - { me = Pm {cases=yes; args=args; default=def} ; - matrix = as_matrix yes ; - top_default = def; }, - (idef,next)::nexts - | _ -> assert false - - and split_noexc yes = function - | [] -> precompile_var args (List.rev yes) def k - | (p::_,_ as cl)::rem -> - if group_constructor p then - let yes= List.rev yes in - let {me=next; matrix=matrix; top_default=def;},nexts = - split_exc (pat_as_constr p) [cl] rem in - let idef = next_raise_count () in - precompile_var - args yes - (cons_default matrix idef def) - ((idef,next)::nexts) - else split_noexc (cl::yes) rem - | _ -> assert false in - - match cls with - | [] -> assert false - | (p::_,_ as cl)::rem -> - if group_constructor p then - split_exc (pat_as_constr p) [cl] rem - else - split_noexc [cl] rem - | _ -> assert false - -and split_constr cls args def k = - let ex_pat = what_is_cases cls in - match ex_pat.pat_desc with - | Tpat_any -> precompile_var args cls def k - | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> - split_naive cls args def k - | _ -> - - let group = get_group ex_pat in - - let rec split_ex yes no = function - | [] -> - let yes = List.rev yes and no = List.rev no in - begin match no with - | [] -> - {me = Pm {cases=yes ; args=args ; default=def} ; - matrix = as_matrix yes ; - top_default = def}, - k - | cl::rem -> - begin match yes with - | [] -> - (* Could not success in raising up a constr matching up *) - split_noex [cl] [] rem - | _ -> - let {me=next ; matrix=matrix ; top_default=def}, nexts = - split_noex [cl] [] rem in - let idef = next_raise_count () in - let def = cons_default matrix idef def in - {me = Pm {cases=yes ; args=args ; default=def} ; - matrix = as_matrix yes ; - top_default = def }, - (idef, next)::nexts - end - end - | (p::_,_) as cl::rem -> - if group p && up_ok cl no then - split_ex (cl::yes) no rem - else - split_ex yes (cl::no) rem - | _ -> assert false - - and split_noex yes no = function - | [] -> - let yes = List.rev yes and no = List.rev no in - begin match no with - | [] -> precompile_var args yes def k - | cl::rem -> - let {me=next ; matrix=matrix ; top_default=def}, nexts = - split_ex [cl] [] rem in - let idef = next_raise_count () in - precompile_var - args yes - (cons_default matrix idef def) - ((idef,next)::nexts) - end - | [ps,_ as cl] - when List.for_all group_var ps && yes <> [] -> - (* This enables an extra division in some frequent cases : - last row is made of variables only *) - split_noex yes (cl::no) [] - | (p::_,_) as cl::rem -> - if not (group p) && up_ok cl no then - split_noex (cl::yes) no rem - else - split_noex yes (cl::no) rem - | _ -> assert false in - - match cls with - | ((p::_,_) as cl)::rem -> - if group p then split_ex [cl] [] rem - else split_noex [cl] [] rem - | _ -> assert false - -and precompile_var args cls def k = match args with -| [] -> assert false -| _::((Lvar v as av,_) as arg)::rargs -> - begin match cls with - | [_] -> (* as split as it can *) - dont_precompile_var args cls def k - | _ -> -(* Precompile *) - let var_cls = - List.map - (fun (ps,act) -> match ps with - | _::ps -> ps,act | _ -> assert false) - cls - and var_def = make_default (fun _ rem -> rem) def in - let {me=first ; matrix=matrix}, nexts = - split_or (Some v) var_cls (arg::rargs) var_def in - -(* Compute top information *) - match nexts with - | [] -> (* If you need *) - dont_precompile_var args cls def k - | _ -> - let rfirst = - {me = PmVar {inside=first ; var_arg = av} ; - matrix = add_omega_column matrix ; - top_default = rebuild_default nexts def ; } - and rnexts = rebuild_nexts av nexts k in - rfirst, rnexts - end -| _ -> - dont_precompile_var args cls def k - -and dont_precompile_var args cls def k = - {me = Pm {cases = cls ; args = args ; default = def } ; - matrix=as_matrix cls ; - top_default=def},k - -and precompile_or argo cls ors args def k = match ors with -| [] -> split_constr cls args def k -| _ -> - let rec do_cases = function - | ({pat_desc=Tpat_or _} as orp::patl, action)::rem -> - let others,rem = get_equiv orp rem in - let orpm = - {cases = - (patl, action):: - List.map - (function - | (_::ps,action) -> ps,action - | _ -> assert false) - others ; - args = (match args with _::r -> r | _ -> assert false) ; - default = default_compat orp def} in - let pm_fv = pm_free_variables orpm in - let vars = - Typedtree.pat_bound_idents_full orp - |> List.filter (fun (id, _, _) -> Ident.Set.mem id pm_fv) - |> List.map (fun (id,_,ty) -> id,Typeopt.value_kind orp.pat_env ty) - in - let or_num = next_raise_count () in - let new_patl = Parmatch.omega_list patl in - - let mk_new_action vs = - Lstaticraise - (or_num, List.map (fun v -> Lvar v) vs) in - - let body,handlers = do_cases rem in - explode_or_pat - argo new_patl mk_new_action body (List.map fst vars) [] orp, - let mat = [[orp]] in - ((mat, or_num, vars , orpm):: handlers) - | cl::rem -> - let new_ord,new_to_catch = do_cases rem in - cl::new_ord,new_to_catch - | [] -> [],[] in - - let end_body, handlers = do_cases ors in - let matrix = as_matrix (cls@ors) - and body = {cases=cls@end_body ; args=args ; default=def} in - {me = PmOr {body=body ; handlers=handlers ; or_matrix=matrix} ; - matrix=matrix ; - top_default=def}, - k - -let split_precompile argo pm = - let {me=next}, nexts = split_or argo pm.cases pm.args pm.default in - if dbg && (nexts <> [] || (match next with PmOr _ -> true | _ -> false)) - then begin - Format.eprintf "** SPLIT **\n" ; - pretty_pm pm ; - pretty_precompiled_res next nexts - end ; - next, nexts - - -(* General divide functions *) - -let add_line patl_action pm = pm.cases <- patl_action :: pm.cases; pm - -type cell = - {pm : pattern_matching ; - ctx : ctx list ; - pat : pattern} - -let add make_matching_fun division eq_key key patl_action args = - try - let (_,cell) = List.find (fun (k,_) -> eq_key key k) division in - cell.pm.cases <- patl_action :: cell.pm.cases; - division - with Not_found -> - let cell = make_matching_fun args in - cell.pm.cases <- [patl_action] ; - (key, cell) :: division - - -let divide make eq_key get_key get_args ctx pm = - - let rec divide_rec = function - | (p::patl,action) :: rem -> - let this_match = divide_rec rem in - add - (make p pm.default ctx) - this_match eq_key (get_key p) (get_args p patl,action) pm.args - | _ -> [] in - - divide_rec pm.cases - - -let divide_line make_ctx make get_args pat ctx pm = - let rec divide_rec = function - | (p::patl,action) :: rem -> - let this_match = divide_rec rem in - add_line (get_args p patl, action) this_match - | _ -> make pm.default pm.args in - - {pm = divide_rec pm.cases ; - ctx=make_ctx ctx ; - pat=pat} - - - -(* Then come various functions, - There is one set of functions per matching style - (constants, constructors etc.) - - - matcher functions are arguments to make_default (for default handlers) - They may raise NoMatch or OrPat and perform the full - matching (selection + arguments). - - - - get_args and get_key are for the compiled matrices, note that - selection and getting arguments are separated. - - - make_ _matching combines the previous functions for producing - new ``pattern_matching'' records. -*) - - - -let rec matcher_const cst p rem = match p.pat_desc with -| Tpat_or (p1,p2,_) -> - begin try - matcher_const cst p1 rem with - | NoMatch -> matcher_const cst p2 rem - end -| Tpat_constant c1 when const_compare c1 cst = 0 -> rem -| Tpat_any -> rem -| _ -> raise NoMatch - -let get_key_constant caller = function - | {pat_desc= Tpat_constant cst} -> cst - | p -> - Format.eprintf "BAD: %s" caller ; - pretty_pat p ; - assert false - -let get_args_constant _ rem = rem - -let make_constant_matching p def ctx = function - [] -> fatal_error "Matching.make_constant_matching" - | (_ :: argl) -> - let def = - make_default - (matcher_const (get_key_constant "make" p)) def - and ctx = - filter_ctx p ctx in - {pm = {cases = []; args = argl ; default = def} ; - ctx = ctx ; - pat = normalize_pat p} - - - - -let divide_constant ctx m = - divide - make_constant_matching - (fun c d -> const_compare c d = 0) (get_key_constant "divide") - get_args_constant - ctx m - -(* Matching against a constructor *) - - -let make_field_args loc binding_kind arg first_pos last_pos argl = - let rec make_args pos = - if pos > last_pos - then argl - else (Lprim(Pfield pos, [arg], loc), binding_kind) :: make_args (pos + 1) - in make_args first_pos - -let get_key_constr = function - | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr.cstr_tag - | _ -> assert false - -let get_args_constr p rem = match p with -| {pat_desc=Tpat_construct (_, _, args)} -> args @ rem -| _ -> assert false - -(* NB: matcher_constr applies to default matrices. - - In that context, matching by constructors of extensible - types degrades to arity checking, due to potential rebinding. - This comparison is performed by Types.may_equal_constr. -*) - -let matcher_constr cstr = match cstr.cstr_arity with -| 0 -> - let rec matcher_rec q rem = match q.pat_desc with - | Tpat_or (p1,p2,_) -> - begin - try matcher_rec p1 rem - with NoMatch -> matcher_rec p2 rem - end - | Tpat_construct (_, cstr',[]) - when Types.may_equal_constr cstr cstr' -> rem - | Tpat_any -> rem - | _ -> raise NoMatch in - matcher_rec -| 1 -> - let rec matcher_rec q rem = match q.pat_desc with - | Tpat_or (p1,p2,_) -> - let r1 = try Some (matcher_rec p1 rem) with NoMatch -> None - and r2 = try Some (matcher_rec p2 rem) with NoMatch -> None in - begin match r1,r2 with - | None, None -> raise NoMatch - | Some r1, None -> r1 - | None, Some r2 -> r2 - | Some (a1::_), Some (a2::_) -> - {a1 with - pat_loc = Location.none ; - pat_desc = Tpat_or (a1, a2, None)}:: - rem - | _, _ -> assert false - end - | Tpat_construct (_, cstr', [arg]) - when Types.may_equal_constr cstr cstr' -> arg::rem - | Tpat_any -> omega::rem - | _ -> raise NoMatch in - matcher_rec -| _ -> - fun q rem -> match q.pat_desc with - | Tpat_or (_,_,_) -> raise OrPat - | Tpat_construct (_,cstr',args) - when Types.may_equal_constr cstr cstr' -> args @ rem - | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem - | _ -> raise NoMatch - -let make_constr_matching p def ctx = function - [] -> fatal_error "Matching.make_constr_matching" - | ((arg, _mut) :: argl) -> - let cstr = pat_as_constr p in - let newargs = - if cstr.cstr_inlined <> None then - (arg, Alias) :: argl - else match cstr.cstr_tag with - Cstr_constant _ | Cstr_block _ -> - make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl - | Cstr_unboxed -> (arg, Alias) :: argl - | Cstr_extension _ -> - make_field_args p.pat_loc Alias arg 1 cstr.cstr_arity argl in - {pm= - {cases = []; args = newargs; - default = make_default (matcher_constr cstr) def} ; - ctx = filter_ctx p ctx ; - pat=normalize_pat p} - - -let divide_constructor ctx pm = - divide - make_constr_matching - (=) get_key_constr get_args_constr - ctx pm - -(* Matching against a variant *) - -let rec matcher_variant_const lab p rem = match p.pat_desc with -| Tpat_or (p1, p2, _) -> - begin - try - matcher_variant_const lab p1 rem - with - | NoMatch -> matcher_variant_const lab p2 rem - end -| Tpat_variant (lab1,_,_) when lab1=lab -> rem -| Tpat_any -> rem -| _ -> raise NoMatch - - -let make_variant_matching_constant p lab def ctx = function - [] -> fatal_error "Matching.make_variant_matching_constant" - | (_ :: argl) -> - let def = make_default (matcher_variant_const lab) def - and ctx = filter_ctx p ctx in - {pm={ cases = []; args = argl ; default=def} ; - ctx=ctx ; - pat = normalize_pat p} - -let matcher_variant_nonconst lab p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_variant (lab1,Some arg,_) when lab1=lab -> arg::rem -| Tpat_any -> omega::rem -| _ -> raise NoMatch - - -let make_variant_matching_nonconst p lab def ctx = function - [] -> fatal_error "Matching.make_variant_matching_nonconst" - | ((arg, _mut) :: argl) -> - let def = make_default (matcher_variant_nonconst lab) def - and ctx = filter_ctx p ctx in - {pm= - {cases = []; args = (Lprim(Pfield 1, [arg], p.pat_loc), Alias) :: argl; - default=def} ; - ctx=ctx ; - pat = normalize_pat p} - -let divide_variant row ctx {cases = cl; args = al; default=def} = - let row = Btype.row_repr row in - let rec divide = function - ({pat_desc = Tpat_variant(lab, pato, _)} as p:: patl, action) :: rem -> - let variants = divide rem in - if try Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent - with Not_found -> true - then - variants - else begin - let tag = Btype.hash_variant lab in - match pato with - None -> - add (make_variant_matching_constant p lab def ctx) variants - (=) (Cstr_constant tag) (patl, action) al - | Some pat -> - add (make_variant_matching_nonconst p lab def ctx) variants - (=) (Cstr_block tag) (pat :: patl, action) al - end - | _ -> [] - in - divide cl - -(* - Three ``no-test'' cases - *) - -(* Matching against a variable *) - -let get_args_var _ rem = rem - - -let make_var_matching def = function - | [] -> fatal_error "Matching.make_var_matching" - | _::argl -> - {cases=[] ; - args = argl ; - default= make_default get_args_var def} - -let divide_var ctx pm = - divide_line ctx_lshift make_var_matching get_args_var omega ctx pm - -(* Matching and forcing a lazy value *) - -let get_arg_lazy p rem = match p with -| {pat_desc = Tpat_any} -> omega :: rem -| {pat_desc = Tpat_lazy arg} -> arg :: rem -| _ -> assert false - -let matcher_lazy p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_any -| Tpat_var _ -> omega :: rem -| Tpat_lazy arg -> arg :: rem -| _ -> raise NoMatch - -(* Inlining the tag tests before calling the primitive that works on - lazy blocks. This is also used in translcore.ml. - No other call than Obj.tag when the value has been forced before. -*) - -let prim_obj_tag = - Primitive.simple ~name:"caml_obj_tag" ~arity:1 ~alloc:false - -let get_mod_field modname field = - lazy ( - let mod_ident = Ident.create_persistent modname in - let env = Env.add_persistent_structure mod_ident Env.initial_safe_string in - match Env.open_pers_signature modname env with - | exception Not_found -> fatal_error ("Module "^modname^" unavailable.") - | env -> begin - match Env.lookup_value (Longident.Lident field) env with - | exception Not_found -> - fatal_error ("Primitive "^modname^"."^field^" not found.") - | (path, _) -> transl_value_path Location.none env path - end - ) - -let code_force_lazy_block = - get_mod_field "CamlinternalLazy" "force_lazy_block" -let code_force_lazy = - get_mod_field "CamlinternalLazy" "force" -;; - -(* inline_lazy_force inlines the beginning of the code of Lazy.force. When - the value argument is tagged as: - - forward, take field 0 - - lazy, call the primitive that forces (without testing again the tag) - - anything else, return it - - Using Lswitch below relies on the fact that the GC does not shortcut - Forward(val_out_of_heap). -*) - -let inline_lazy_force_cond arg loc = - let idarg = Ident.create_local "lzarg" in - let varg = Lvar idarg in - let tag = Ident.create_local "tag" in - let force_fun = Lazy.force code_force_lazy_block in - Llet(Strict, Pgenval, idarg, arg, - Llet(Alias, Pgenval, tag, Lprim(Pccall prim_obj_tag, [varg], loc), - Lifthenelse( - (* if (tag == Obj.forward_tag) then varg.(0) else ... *) - Lprim(Pintcomp Ceq, - [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))], - loc), - Lprim(Pfield 0, [varg], loc), - Lifthenelse( - (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *) - Lprim(Pintcomp Ceq, - [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))], - loc), - Lapply{ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=force_fun; - ap_args=[varg]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}, - (* ... arg *) - varg)))) - -let inline_lazy_force_switch arg loc = - let idarg = Ident.create_local "lzarg" in - let varg = Lvar idarg in - let force_fun = Lazy.force code_force_lazy_block in - Llet(Strict, Pgenval, idarg, arg, - Lifthenelse( - Lprim(Pisint, [varg], loc), varg, - (Lswitch - (varg, - { sw_numconsts = 0; sw_consts = []; - sw_numblocks = 256; (* PR#6033 - tag ranges from 0 to 255 *) - sw_blocks = - [ (Obj.forward_tag, Lprim(Pfield 0, [varg], loc)); - (Obj.lazy_tag, - Lapply{ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=force_fun; - ap_args=[varg]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}) ]; - sw_failaction = Some varg }, loc )))) - -let inline_lazy_force arg loc = - if !Clflags.afl_instrument then - (* Disable inlining optimisation if AFL instrumentation active, - so that the GC forwarding optimisation is not visible in the - instrumentation output. - (see https://github.com/stedolan/crowbar/issues/14) *) - Lapply{ap_should_be_tailcall = false; - ap_loc=loc; - ap_func=Lazy.force code_force_lazy; - ap_args=[arg]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} - else - if !Clflags.native_code then - (* Lswitch generates compact and efficient native code *) - inline_lazy_force_switch arg loc - else - (* generating bytecode: Lswitch would generate too many rather big - tables (~ 250 elts); conditionals are better *) - inline_lazy_force_cond arg loc - -let make_lazy_matching def = function - [] -> fatal_error "Matching.make_lazy_matching" - | (arg,_mut) :: argl -> - { cases = []; - args = - (inline_lazy_force arg Location.none, Strict) :: argl; - default = make_default matcher_lazy def } - -let divide_lazy p ctx pm = - divide_line - (filter_ctx p) - make_lazy_matching - get_arg_lazy - p ctx pm - -(* Matching against a tuple pattern *) - - -let get_args_tuple arity p rem = match p with -| {pat_desc = Tpat_any} -> omegas arity @ rem -| {pat_desc = Tpat_tuple args} -> - args @ rem -| _ -> assert false - -let matcher_tuple arity p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_any -| Tpat_var _ -> omegas arity @ rem -| Tpat_tuple args when List.length args = arity -> args @ rem -| _ -> raise NoMatch - -let make_tuple_matching loc arity def = function - [] -> fatal_error "Matching.make_tuple_matching" - | (arg, _mut) :: argl -> - let rec make_args pos = - if pos >= arity - then argl - else (Lprim(Pfield pos, [arg], loc), Alias) :: make_args (pos + 1) in - {cases = []; args = make_args 0 ; - default=make_default (matcher_tuple arity) def} - - -let divide_tuple arity p ctx pm = - divide_line - (filter_ctx p) - (make_tuple_matching p.pat_loc arity) - (get_args_tuple arity) p ctx pm - -(* Matching against a record pattern *) - - -let record_matching_line num_fields lbl_pat_list = - let patv = Array.make num_fields omega in - List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; - Array.to_list patv - -let get_args_record num_fields p rem = match p with -| {pat_desc=Tpat_any} -> - record_matching_line num_fields [] @ rem -| {pat_desc=Tpat_record (lbl_pat_list,_)} -> - record_matching_line num_fields lbl_pat_list @ rem -| _ -> assert false - -let matcher_record num_fields p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_any -| Tpat_var _ -> - record_matching_line num_fields [] @ rem -| Tpat_record ([], _) when num_fields = 0 -> rem -| Tpat_record ((_, lbl, _) :: _ as lbl_pat_list, _) - when Array.length lbl.lbl_all = num_fields -> - record_matching_line num_fields lbl_pat_list @ rem -| _ -> raise NoMatch - -let make_record_matching loc all_labels def = function - [] -> fatal_error "Matching.make_record_matching" - | ((arg, _mut) :: argl) -> - let rec make_args pos = - if pos >= Array.length all_labels then argl else begin - let lbl = all_labels.(pos) in - let access = - match lbl.lbl_repres with - | Record_regular | Record_inlined _ -> - Lprim (Pfield lbl.lbl_pos, [arg], loc) - | Record_unboxed _ -> arg - | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [arg], loc) - | Record_extension _ -> Lprim (Pfield (lbl.lbl_pos + 1), [arg], loc) - in - let str = - match lbl.lbl_mut with - Immutable -> Alias - | Mutable -> StrictOpt in - (access, str) :: make_args(pos + 1) - end in - let nfields = Array.length all_labels in - let def= make_default (matcher_record nfields) def in - {cases = []; args = make_args 0 ; default = def} - - -let divide_record all_labels p ctx pm = - let get_args = get_args_record (Array.length all_labels) in - divide_line - (filter_ctx p) - (make_record_matching p.pat_loc all_labels) - get_args - p ctx pm - -(* Matching against an array pattern *) - -let get_key_array = function - | {pat_desc=Tpat_array patl} -> List.length patl - | _ -> assert false - -let get_args_array p rem = match p with -| {pat_desc=Tpat_array patl} -> patl@rem -| _ -> assert false - -let matcher_array len p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_array args when List.length args=len -> args @ rem -| Tpat_any -> Parmatch.omegas len @ rem -| _ -> raise NoMatch - -let make_array_matching kind p def ctx = function - | [] -> fatal_error "Matching.make_array_matching" - | ((arg, _mut) :: argl) -> - let len = get_key_array p in - let rec make_args pos = - if pos >= len - then argl - else (Lprim(Parrayrefu kind, - [arg; Lconst(Const_base(Const_int pos))], - p.pat_loc), - StrictOpt) :: make_args (pos + 1) in - let def = make_default (matcher_array len) def - and ctx = filter_ctx p ctx in - {pm={cases = []; args = make_args 0 ; default = def} ; - ctx=ctx ; - pat = normalize_pat p} - -let divide_array kind ctx pm = - divide - (make_array_matching kind) - (=) get_key_array get_args_array ctx pm - - -(* - Specific string test sequence - Will be called by the bytecode compiler, from bytegen.ml. - The strategy is first dichotomic search (we perform 3-way tests - with compare_string), then sequence of equality tests - when there are less then T=strings_test_threshold static strings to match. - - Increasing T entails (slightly) less code, decreasing T - (slightly) favors runtime speed. - T=8 looks a decent tradeoff. -*) - -(* Utilities *) - -let strings_test_threshold = 8 - -let prim_string_notequal = - Pccall(Primitive.simple - ~name:"caml_string_notequal" - ~arity:2 - ~alloc:false) - -let prim_string_compare = - Pccall(Primitive.simple - ~name:"caml_string_compare" - ~arity:2 - ~alloc:false) - -let bind_sw arg k = match arg with -| Lvar _ -> k arg -| _ -> - let id = Ident.create_local "switch" in - Llet (Strict,Pgenval,id,arg,k (Lvar id)) - - -(* Sequential equality tests *) - -let make_string_test_sequence loc arg sw d = - let d,sw = match d with - | None -> - begin match sw with - | (_,d)::sw -> d,sw - | [] -> assert false - end - | Some d -> d,sw in - bind_sw arg - (fun arg -> - List.fold_right - (fun (s,lam) k -> - Lifthenelse - (Lprim - (prim_string_notequal, - [arg; Lconst (Const_immstring s)], loc), - k,lam)) - sw d) - -let rec split k xs = match xs with -| [] -> assert false -| x0::xs -> - if k <= 1 then [],x0,xs - else - let xs,y0,ys = split (k-2) xs in - x0::xs,y0,ys - -let zero_lam = Lconst (Const_base (Const_int 0)) - -let tree_way_test loc arg lt eq gt = - Lifthenelse - (Lprim (Pintcomp Clt,[arg;zero_lam], loc),lt, - Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg], loc),gt,eq)) - -(* Dichotomic tree *) - - -let rec do_make_string_test_tree loc arg sw delta d = - let len = List.length sw in - if len <= strings_test_threshold+delta then - make_string_test_sequence loc arg sw d - else - let lt,(s,act),gt = split len sw in - bind_sw - (Lprim - (prim_string_compare, - [arg; Lconst (Const_immstring s)], loc)) - (fun r -> - tree_way_test loc r - (do_make_string_test_tree loc arg lt delta d) - act - (do_make_string_test_tree loc arg gt delta d)) - -(* Entry point *) -let expand_stringswitch loc arg sw d = match d with -| None -> - bind_sw arg - (fun arg -> do_make_string_test_tree loc arg sw 0 None) -| Some e -> - bind_sw arg - (fun arg -> - make_catch e - (fun d -> do_make_string_test_tree loc arg sw 1 (Some d))) - -(**********************) -(* Generic test trees *) -(**********************) - -(* Sharing *) - -(* Add handler, if shared *) -let handle_shared () = - let hs = ref (fun x -> x) in - let handle_shared act = match act with - | Switch.Single act -> act - | Switch.Shared act -> - let i,h = make_catch_delayed act in - let ohs = !hs in - hs := (fun act -> h (ohs act)) ; - make_exit i in - hs,handle_shared - - -let share_actions_tree sw d = - let store = StoreExp.mk_store () in -(* Default action is always shared *) - let d = - match d with - | None -> None - | Some d -> Some (store.Switch.act_store_shared () d) in -(* Store all other actions *) - let sw = - List.map (fun (cst,act) -> cst,store.Switch.act_store () act) sw in - -(* Retrieve all actions, including potential default *) - let acts = store.Switch.act_get_shared () in - -(* Array of actual actions *) - let hs,handle_shared = handle_shared () in - let acts = Array.map handle_shared acts in - -(* Reconstruct default and switch list *) - let d = match d with - | None -> None - | Some d -> Some (acts.(d)) in - let sw = List.map (fun (cst,j) -> cst,acts.(j)) sw in - !hs,sw,d - -(* Note: dichotomic search requires sorted input with no duplicates *) -let rec uniq_lambda_list sw = match sw with - | []|[_] -> sw - | (c1,_ as p1)::((c2,_)::sw2 as sw1) -> - if const_compare c1 c2 = 0 then uniq_lambda_list (p1::sw2) - else p1::uniq_lambda_list sw1 - -let sort_lambda_list l = - let l = - List.stable_sort (fun (x,_) (y,_) -> const_compare x y) l in - uniq_lambda_list l - -let rec cut n l = - if n = 0 then [],l - else match l with - [] -> raise (Invalid_argument "cut") - | a::l -> let l1,l2 = cut (n-1) l in a::l1, l2 - -let rec do_tests_fail loc fail tst arg = function - | [] -> fail - | (c, act)::rem -> - Lifthenelse - (Lprim (tst, [arg ; Lconst (Const_base c)], loc), - do_tests_fail loc fail tst arg rem, - act) - -let rec do_tests_nofail loc tst arg = function - | [] -> fatal_error "Matching.do_tests_nofail" - | [_,act] -> act - | (c,act)::rem -> - Lifthenelse - (Lprim (tst, [arg ; Lconst (Const_base c)], loc), - do_tests_nofail loc tst arg rem, - act) - -let make_test_sequence loc fail tst lt_tst arg const_lambda_list = - let const_lambda_list = sort_lambda_list const_lambda_list in - let hs,const_lambda_list,fail = - share_actions_tree const_lambda_list fail in - - let rec make_test_sequence const_lambda_list = - if List.length const_lambda_list >= 4 && lt_tst <> Pignore then - split_sequence const_lambda_list - else match fail with - | None -> do_tests_nofail loc tst arg const_lambda_list - | Some fail -> do_tests_fail loc fail tst arg const_lambda_list - - and split_sequence const_lambda_list = - let list1, list2 = - cut (List.length const_lambda_list / 2) const_lambda_list in - Lifthenelse(Lprim(lt_tst, - [arg; Lconst(Const_base (fst(List.hd list2)))], - loc), - make_test_sequence list1, make_test_sequence list2) - in - hs (make_test_sequence const_lambda_list) - - -module SArg = struct - type primitive = Lambda.primitive - - let eqint = Pintcomp Ceq - let neint = Pintcomp Cne - let leint = Pintcomp Cle - let ltint = Pintcomp Clt - let geint = Pintcomp Cge - let gtint = Pintcomp Cgt - - type act = Lambda.lambda - - let make_prim p args = Lprim (p,args,Location.none) - let make_offset arg n = match n with - | 0 -> arg - | _ -> Lprim (Poffsetint n,[arg],Location.none) - - let bind arg body = - let newvar,newarg = match arg with - | Lvar v -> v,arg - | _ -> - let newvar = Ident.create_local "switcher" in - newvar,Lvar newvar in - bind Alias newvar arg (body newarg) - let make_const i = Lconst (Const_base (Const_int i)) - let make_isout h arg = Lprim (Pisout, [h ; arg],Location.none) - let make_isin h arg = Lprim (Pnot,[make_isout h arg],Location.none) - let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) - let make_switch loc arg cases acts = - let l = ref [] in - for i = Array.length cases-1 downto 0 do - l := (i,acts.(cases.(i))) :: !l - done ; - Lswitch(arg, - {sw_numconsts = Array.length cases ; sw_consts = !l ; - sw_numblocks = 0 ; sw_blocks = [] ; - sw_failaction = None}, loc) - let make_catch = make_catch_delayed - let make_exit = make_exit - -end - -(* Action sharing for Lswitch argument *) -let share_actions_sw sw = -(* Attempt sharing on all actions *) - let store = StoreExp.mk_store () in - let fail = match sw.sw_failaction with - | None -> None - | Some fail -> - (* Fail is translated to exit, whatever happens *) - Some (store.Switch.act_store_shared () fail) in - let consts = - List.map - (fun (i,e) -> i,store.Switch.act_store () e) - sw.sw_consts - and blocks = - List.map - (fun (i,e) -> i,store.Switch.act_store () e) - sw.sw_blocks in - let acts = store.Switch.act_get_shared () in - let hs,handle_shared = handle_shared () in - let acts = Array.map handle_shared acts in - let fail = match fail with - | None -> None - | Some fail -> Some (acts.(fail)) in - !hs, - { sw with - sw_consts = List.map (fun (i,j) -> i,acts.(j)) consts ; - sw_blocks = List.map (fun (i,j) -> i,acts.(j)) blocks ; - sw_failaction = fail; } - -(* Reintroduce fail action in switch argument, - for the sake of avoiding carrying over huge switches *) - -let reintroduce_fail sw = match sw.sw_failaction with -| None -> - let t = Hashtbl.create 17 in - let seen (_,l) = match as_simple_exit l with - | Some i -> - let old = try Hashtbl.find t i with Not_found -> 0 in - Hashtbl.replace t i (old+1) - | None -> () in - List.iter seen sw.sw_consts ; - List.iter seen sw.sw_blocks ; - let i_max = ref (-1) - and max = ref (-1) in - Hashtbl.iter - (fun i c -> - if c > !max then begin - i_max := i ; - max := c - end) t ; - if !max >= 3 then - let default = !i_max in - let remove = - List.filter - (fun (_,lam) -> match as_simple_exit lam with - | Some j -> j <> default - | None -> true) in - {sw with - sw_consts = remove sw.sw_consts ; - sw_blocks = remove sw.sw_blocks ; - sw_failaction = Some (make_exit default)} - else sw -| Some _ -> sw - - -module Switcher = Switch.Make(SArg) -open Switch - -let rec last def = function - | [] -> def - | [x,_] -> x - | _::rem -> last def rem - -let get_edges low high l = match l with -| [] -> low, high -| (x,_)::_ -> x, last high l - - -let as_interval_canfail fail low high l = - let store = StoreExp.mk_store () in - - let do_store _tag act = - - let i = store.act_store () act in -(* - eprintf "STORE [%s] %i %s\n" tag i (string_of_lam act) ; -*) - i in - - let rec nofail_rec cur_low cur_high cur_act = function - | [] -> - if cur_high = high then - [cur_low,cur_high,cur_act] - else - [(cur_low,cur_high,cur_act) ; (cur_high+1,high, 0)] - | ((i,act_i)::rem) as all -> - let act_index = do_store "NO" act_i in - if cur_high+1= i then - if act_index=cur_act then - nofail_rec cur_low i cur_act rem - else if act_index=0 then - (cur_low,i-1, cur_act)::fail_rec i i rem - else - (cur_low, i-1, cur_act)::nofail_rec i i act_index rem - else if act_index = 0 then - (cur_low, cur_high, cur_act):: - fail_rec (cur_high+1) (cur_high+1) all - else - (cur_low, cur_high, cur_act):: - (cur_high+1,i-1,0):: - nofail_rec i i act_index rem - - and fail_rec cur_low cur_high = function - | [] -> [(cur_low, cur_high, 0)] - | (i,act_i)::rem -> - let index = do_store "YES" act_i in - if index=0 then fail_rec cur_low i rem - else - (cur_low,i-1,0):: - nofail_rec i i index rem in - - let init_rec = function - | [] -> [low,high,0] - | (i,act_i)::rem -> - let index = do_store "INIT" act_i in - if index=0 then - fail_rec low i rem - else - if low < i then - (low,i-1,0)::nofail_rec i i index rem - else - nofail_rec i i index rem in - - assert (do_store "FAIL" fail = 0) ; (* fail has action index 0 *) - let r = init_rec l in - Array.of_list r, store - -let as_interval_nofail l = - let store = StoreExp.mk_store () in - let rec some_hole = function - | []|[_] -> false - | (i,_)::((j,_)::_ as rem) -> - j > i+1 || some_hole rem in - let rec i_rec cur_low cur_high cur_act = function - | [] -> - [cur_low, cur_high, cur_act] - | (i,act)::rem -> - let act_index = store.act_store () act in - if act_index = cur_act then - i_rec cur_low i cur_act rem - else - (cur_low, cur_high, cur_act):: - i_rec i i act_index rem in - let inters = match l with - | (i,act)::rem -> - let act_index = - (* In case there is some hole and that a switch is emitted, - action 0 will be used as the action of unreachable - cases (cf. switch.ml, make_switch). - Hence, this action will be shared *) - if some_hole rem then - store.act_store_shared () act - else - store.act_store () act in - assert (act_index = 0) ; - i_rec i i act_index rem - | _ -> assert false in - - Array.of_list inters, store - - -let sort_int_lambda_list l = - List.sort - (fun (i1,_) (i2,_) -> - if i1 < i2 then -1 - else if i2 < i1 then 1 - else 0) - l - -let as_interval fail low high l = - let l = sort_int_lambda_list l in - get_edges low high l, - (match fail with - | None -> as_interval_nofail l - | Some act -> as_interval_canfail act low high l) - -let call_switcher loc fail arg low high int_lambda_list = - let edges, (cases, actions) = - as_interval fail low high int_lambda_list in - Switcher.zyva loc edges arg cases actions - - -let rec list_as_pat = function - | [] -> fatal_error "Matching.list_as_pat" - | [pat] -> pat - | pat::rem -> - {pat with pat_desc = Tpat_or (pat,list_as_pat rem,None)} - - -let complete_pats_constrs = function - | p::_ as pats -> - List.map - (pat_of_constr p) - (complete_constrs p (List.map get_key_constr pats)) - | _ -> assert false - - -(* - Following two ``failaction'' function compute n, the trap handler - to jump to in case of failure of elementary tests -*) - -let mk_failaction_neg partial ctx def = match partial with -| Partial -> - begin match def with - | (_,idef)::_ -> - Some (Lstaticraise (idef,[])),jumps_singleton idef ctx - | [] -> - (* Act as Total, this means - If no appropriate default matrix exists, - then this switch cannot fail *) - None, jumps_empty - end -| Total -> - None, jumps_empty - - - -(* In line with the article and simpler than before *) -let mk_failaction_pos partial seen ctx defs = - if dbg then begin - Format.eprintf "**POS**\n" ; - pretty_def defs ; - () - end ; - let rec scan_def env to_test defs = match to_test,defs with - | ([],_)|(_,[]) -> - List.fold_left - (fun (klist,jumps) (pats,i)-> - let action = Lstaticraise (i,[]) in - let klist = - List.fold_right - (fun pat r -> (get_key_constr pat,action)::r) - pats klist - and jumps = - jumps_add i (ctx_lub (list_as_pat pats) ctx) jumps in - klist,jumps) - ([],jumps_empty) env - | _,(pss,idef)::rem -> - let now, later = - List.partition - (fun (_p,p_ctx) -> ctx_match p_ctx pss) to_test in - match now with - | [] -> scan_def env to_test rem - | _ -> scan_def ((List.map fst now,idef)::env) later rem in - - let fail_pats = complete_pats_constrs seen in - if List.length fail_pats < !Clflags.match_context_rows then begin - let fail,jmps = - scan_def - [] - (List.map - (fun pat -> pat, ctx_lub pat ctx) - fail_pats) - defs in - if dbg then begin - eprintf "POSITIVE JUMPS [%i]:\n" (List.length fail_pats); - pretty_jumps jmps - end ; - None,fail,jmps - end else begin (* Too many non-matched constructors -> reduced information *) - if dbg then eprintf "POS->NEG!!!\n%!" ; - let fail,jumps = mk_failaction_neg partial ctx defs in - if dbg then - eprintf "FAIL: %s\n" - (match fail with - | None -> "" - | Some lam -> string_of_lam lam) ; - fail,[],jumps - end - -let combine_constant loc arg cst partial ctx def - (const_lambda_list, total, _pats) = - let fail, local_jumps = - mk_failaction_neg partial ctx def in - let lambda1 = - match cst with - | Const_int _ -> - let int_lambda_list = - List.map (function Const_int n, l -> n,l | _ -> assert false) - const_lambda_list in - call_switcher loc fail arg min_int max_int int_lambda_list - | Const_char _ -> - let int_lambda_list = - List.map (function Const_char c, l -> (Char.code c, l) - | _ -> assert false) - const_lambda_list in - call_switcher loc fail arg 0 255 int_lambda_list - | Const_string _ -> -(* Note as the bytecode compiler may resort to dichotomic search, - the clauses of stringswitch are sorted with duplicates removed. - This partly applies to the native code compiler, which requires - no duplicates *) - let const_lambda_list = sort_lambda_list const_lambda_list in - let sw = - List.map - (fun (c,act) -> match c with - | Const_string (s,_) -> s,act - | _ -> assert false) - const_lambda_list in - let hs,sw,fail = share_actions_tree sw fail in - hs (Lstringswitch (arg,sw,fail,loc)) - | Const_float _ -> - make_test_sequence loc - fail - (Pfloatcomp CFneq) (Pfloatcomp CFlt) - arg const_lambda_list - | Const_int32 _ -> - make_test_sequence loc - fail - (Pbintcomp(Pint32, Cne)) (Pbintcomp(Pint32, Clt)) - arg const_lambda_list - | Const_int64 _ -> - make_test_sequence loc - fail - (Pbintcomp(Pint64, Cne)) (Pbintcomp(Pint64, Clt)) - arg const_lambda_list - | Const_nativeint _ -> - make_test_sequence loc - fail - (Pbintcomp(Pnativeint, Cne)) (Pbintcomp(Pnativeint, Clt)) - arg const_lambda_list - in lambda1,jumps_union local_jumps total - - - -let split_cases tag_lambda_list = - let rec split_rec = function - [] -> ([], []) - | (cstr, act) :: rem -> - let (consts, nonconsts) = split_rec rem in - match cstr with - Cstr_constant n -> ((n, act) :: consts, nonconsts) - | Cstr_block n -> (consts, (n, act) :: nonconsts) - | Cstr_unboxed -> (consts, (0, act) :: nonconsts) - | Cstr_extension _ -> assert false in - let const, nonconst = split_rec tag_lambda_list in - sort_int_lambda_list const, - sort_int_lambda_list nonconst - -let split_extension_cases tag_lambda_list = - let rec split_rec = function - [] -> ([], []) - | (cstr, act) :: rem -> - let (consts, nonconsts) = split_rec rem in - match cstr with - Cstr_extension(path, true) -> ((path, act) :: consts, nonconsts) - | Cstr_extension(path, false) -> (consts, (path, act) :: nonconsts) - | _ -> assert false in - split_rec tag_lambda_list - - -let combine_constructor loc arg ex_pat cstr partial ctx def - (tag_lambda_list, total1, pats) = - if cstr.cstr_consts < 0 then begin - (* Special cases for extensions *) - let fail, local_jumps = - mk_failaction_neg partial ctx def in - let lambda1 = - let consts, nonconsts = split_extension_cases tag_lambda_list in - let default, consts, nonconsts = - match fail with - | None -> - begin match consts, nonconsts with - | _, (_, act)::rem -> act, consts, rem - | (_, act)::rem, _ -> act, rem, nonconsts - | _ -> assert false - end - | Some fail -> fail, consts, nonconsts in - let nonconst_lambda = - match nonconsts with - [] -> default - | _ -> - let tag = Ident.create_local "tag" in - let tests = - List.fold_right - (fun (path, act) rem -> - let ext = transl_extension_path loc ex_pat.pat_env path in - Lifthenelse(Lprim(Pintcomp Ceq, [Lvar tag; ext], loc), - act, rem)) - nonconsts - default - in - Llet(Alias, Pgenval,tag, Lprim(Pfield 0, [arg], loc), tests) - in - List.fold_right - (fun (path, act) rem -> - let ext = transl_extension_path loc ex_pat.pat_env path in - Lifthenelse(Lprim(Pintcomp Ceq, [arg; ext], loc), - act, rem)) - consts - nonconst_lambda - in - lambda1, jumps_union local_jumps total1 - end else begin - (* Regular concrete type *) - let ncases = List.length tag_lambda_list - and nconstrs = cstr.cstr_consts + cstr.cstr_nonconsts in - let sig_complete = ncases = nconstrs in - let fail_opt,fails,local_jumps = - if sig_complete then None,[],jumps_empty - else - mk_failaction_pos partial pats ctx def in - - let tag_lambda_list = fails @ tag_lambda_list in - let (consts, nonconsts) = split_cases tag_lambda_list in - let lambda1 = - match fail_opt,same_actions tag_lambda_list with - | None,Some act -> act (* Identical actions, no failure *) - | _ -> - match - (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) - with - | (1, 1, [0, act1], [0, act2]) -> - (* Typically, match on lists, will avoid isint primitive in that - case *) - Lifthenelse(arg, act2, act1) - | (n,0,_,[]) -> (* The type defines constant constructors only *) - call_switcher loc fail_opt arg 0 (n-1) consts - | (n, _, _, _) -> - let act0 = - (* = Some act when all non-const constructors match to act *) - match fail_opt,nonconsts with - | Some a,[] -> Some a - | Some _,_ -> - if List.length nonconsts = cstr.cstr_nonconsts then - same_actions nonconsts - else None - | None,_ -> same_actions nonconsts in - match act0 with - | Some act -> - Lifthenelse - (Lprim (Pisint, [arg], loc), - call_switcher loc - fail_opt arg - 0 (n-1) consts, - act) -(* Emit a switch, as bytecode implements this sophisticated instruction *) - | None -> - let sw = - {sw_numconsts = cstr.cstr_consts; sw_consts = consts; - sw_numblocks = cstr.cstr_nonconsts; sw_blocks = nonconsts; - sw_failaction = fail_opt} in - let hs,sw = share_actions_sw sw in - let sw = reintroduce_fail sw in - hs (Lswitch (arg,sw,loc)) in - lambda1, jumps_union local_jumps total1 - end - -let make_test_sequence_variant_constant fail arg int_lambda_list = - let _, (cases, actions) = - as_interval fail min_int max_int int_lambda_list in - Switcher.test_sequence arg cases actions - -let call_switcher_variant_constant loc fail arg int_lambda_list = - call_switcher loc fail arg min_int max_int int_lambda_list - - -let call_switcher_variant_constr loc fail arg int_lambda_list = - let v = Ident.create_local "variant" in - Llet(Alias, Pgenval, v, Lprim(Pfield 0, [arg], loc), - call_switcher loc - fail (Lvar v) min_int max_int int_lambda_list) - -let combine_variant loc row arg partial ctx def - (tag_lambda_list, total1, _pats) = - let row = Btype.row_repr row in - let num_constr = ref 0 in - if row.row_closed then - List.iter - (fun (_, f) -> - match Btype.row_field_repr f with - Rabsent | Reither(true, _::_, _, _) -> () - | _ -> incr num_constr) - row.row_fields - else - num_constr := max_int; - let test_int_or_block arg if_int if_block = - Lifthenelse(Lprim (Pisint, [arg], loc), if_int, if_block) in - let sig_complete = List.length tag_lambda_list = !num_constr - and one_action = same_actions tag_lambda_list in - let fail, local_jumps = - if - sig_complete || (match partial with Total -> true | _ -> false) - then - None, jumps_empty - else - mk_failaction_neg partial ctx def in - let (consts, nonconsts) = split_cases tag_lambda_list in - let lambda1 = match fail, one_action with - | None, Some act -> act - | _,_ -> - match (consts, nonconsts) with - | ([_, act1], [_, act2]) when fail=None -> - test_int_or_block arg act1 act2 - | (_, []) -> (* One can compare integers and pointers *) - make_test_sequence_variant_constant fail arg consts - | ([], _) -> - let lam = call_switcher_variant_constr loc - fail arg nonconsts in - (* One must not dereference integers *) - begin match fail with - | None -> lam - | Some fail -> test_int_or_block arg fail lam - end - | (_, _) -> - let lam_const = - call_switcher_variant_constant loc - fail arg consts - and lam_nonconst = - call_switcher_variant_constr loc - fail arg nonconsts in - test_int_or_block arg lam_const lam_nonconst - in - lambda1, jumps_union local_jumps total1 - - -let combine_array loc arg kind partial ctx def - (len_lambda_list, total1, _pats) = - let fail, local_jumps = mk_failaction_neg partial ctx def in - let lambda1 = - let newvar = Ident.create_local "len" in - let switch = - call_switcher loc - fail (Lvar newvar) - 0 max_int len_lambda_list in - bind - Alias newvar (Lprim(Parraylength kind, [arg], loc)) switch in - lambda1, jumps_union local_jumps total1 - -(* Insertion of debugging events *) - -let rec event_branch repr lam = - begin match lam, repr with - (_, None) -> - lam - | (Levent(lam', ev), Some r) -> - incr r; - Levent(lam', {lev_loc = ev.lev_loc; - lev_kind = ev.lev_kind; - lev_repr = repr; - lev_env = ev.lev_env}) - | (Llet(str, k, id, lam, body), _) -> - Llet(str, k, id, lam, event_branch repr body) - | Lstaticraise _,_ -> lam - | (_, Some _) -> - Printlambda.lambda Format.str_formatter lam ; - fatal_error - ("Matching.event_branch: "^Format.flush_str_formatter ()) - end - - -(* - This exception is raised when the compiler cannot produce code - because control cannot reach the compiled clause, - - Unused is raised initially in compile_test. - - compile_list (for compiling switch results) catch Unused - - comp_match_handlers (for compiling split matches) - may reraise Unused - - -*) - -exception Unused - -let compile_list compile_fun division = - - let rec c_rec totals = function - | [] -> [], jumps_unions totals, [] - | (key, cell) :: rem -> - begin match cell.ctx with - | [] -> c_rec totals rem - | _ -> - try - let (lambda1, total1) = compile_fun cell.ctx cell.pm in - let c_rem, total, new_pats = - c_rec - (jumps_map ctx_combine total1::totals) rem in - ((key,lambda1)::c_rem), total, (cell.pat::new_pats) - with - | Unused -> c_rec totals rem - end in - c_rec [] division - - -let compile_orhandlers compile_fun lambda1 total1 ctx to_catch = - let rec do_rec r total_r = function - | [] -> r,total_r - | (mat,i,vars,pm)::rem -> - begin try - let ctx = select_columns mat ctx in - let handler_i, total_i = - compile_fun ctx pm in - match raw_action r with - | Lstaticraise (j,args) -> - if i=j then - List.fold_right2 (bind_with_value_kind Alias) - vars args handler_i, - jumps_map (ctx_rshift_num (ncols mat)) total_i - else - do_rec r total_r rem - | _ -> - do_rec - (Lstaticcatch (r,(i,vars), handler_i)) - (jumps_union - (jumps_remove i total_r) - (jumps_map (ctx_rshift_num (ncols mat)) total_i)) - rem - with - | Unused -> - do_rec (Lstaticcatch (r, (i,vars), lambda_unit)) total_r rem - end in - do_rec lambda1 total1 to_catch - - -let compile_test compile_fun partial divide combine ctx to_match = - let division = divide ctx to_match in - let c_div = compile_list compile_fun division in - match c_div with - | [],_,_ -> - begin match mk_failaction_neg partial ctx to_match.default with - | None,_ -> raise Unused - | Some l,total -> l,total - end - | _ -> - combine ctx to_match.default c_div - -(* Attempt to avoid some useless bindings by lowering them *) - -(* Approximation of v present in lam *) -let rec approx_present v = function - | Lconst _ -> false - | Lstaticraise (_,args) -> - List.exists (fun lam -> approx_present v lam) args - | Lprim (_,args,_) -> - List.exists (fun lam -> approx_present v lam) args - | Llet (Alias, _k, _, l1, l2) -> - approx_present v l1 || approx_present v l2 - | Lvar vv -> Ident.same v vv - | _ -> true - -let rec lower_bind v arg lam = match lam with -| Lifthenelse (cond, ifso, ifnot) -> - let pcond = approx_present v cond - and pso = approx_present v ifso - and pnot = approx_present v ifnot in - begin match pcond, pso, pnot with - | false, false, false -> lam - | false, true, false -> - Lifthenelse (cond, lower_bind v arg ifso, ifnot) - | false, false, true -> - Lifthenelse (cond, ifso, lower_bind v arg ifnot) - | _,_,_ -> bind Alias v arg lam - end -| Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as sw), loc) - when not (approx_present v ls) -> - Lswitch (ls, {sw with sw_consts = [i,lower_bind v arg act]}, loc) -| Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw), loc) - when not (approx_present v ls) -> - Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]}, loc) -| Llet (Alias, k, vv, lv, l) -> - if approx_present v lv then - bind Alias v arg lam - else - Llet (Alias, k, vv, lv, lower_bind v arg l) -| _ -> - bind Alias v arg lam - -let bind_check str v arg lam = match str,arg with -| _, Lvar _ ->bind str v arg lam -| Alias,_ -> lower_bind v arg lam -| _,_ -> bind str v arg lam - -let comp_exit ctx m = match m.default with -| (_,i)::_ -> Lstaticraise (i,[]), jumps_singleton i ctx -| _ -> fatal_error "Matching.comp_exit" - - - -let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = - match next_matchs with - | [] -> comp_fun partial ctx arg first_match - | rem -> - let rec c_rec body total_body = function - | [] -> body, total_body - (* Hum, -1 means never taken - | (-1,pm)::rem -> c_rec body total_body rem *) - | (i,pm)::rem -> - let ctx_i,total_rem = jumps_extract i total_body in - begin match ctx_i with - | [] -> c_rec body total_body rem - | _ -> - try - let li,total_i = - comp_fun - (match rem with [] -> partial | _ -> Partial) - ctx_i arg pm in - c_rec - (Lstaticcatch (body,(i,[]),li)) - (jumps_union total_i total_rem) - rem - with - | Unused -> - c_rec (Lstaticcatch (body,(i,[]),lambda_unit)) - total_rem rem - end in - try - let first_lam,total = comp_fun Partial ctx arg first_match in - c_rec first_lam total rem - with Unused -> match next_matchs with - | [] -> raise Unused - | (_,x)::xs -> comp_match_handlers comp_fun partial ctx arg x xs - -(* To find reasonable names for variables *) - -let rec name_pattern default = function - (pat :: _, _) :: rem -> - begin match pat.pat_desc with - Tpat_var (id, _) -> id - | Tpat_alias(_, id, _) -> id - | _ -> name_pattern default rem - end - | _ -> Ident.create_local default - -let arg_to_var arg cls = match arg with -| Lvar v -> v,arg -| _ -> - let v = name_pattern "*match*" cls in - v,Lvar v - - -(* - The main compilation function. - Input: - repr=used for inserting debug events - partial=exhaustiveness information from Parmatch - ctx=a context - m=a pattern matching - - Output: a lambda term, a jump summary {..., exit number -> context, .. } -*) - -let rec compile_match repr partial ctx m = match m with -| { cases = []; args = [] } -> comp_exit ctx m -| { cases = ([], action) :: rem } -> - if is_guarded action then begin - let (lambda, total) = - compile_match None partial ctx { m with cases = rem } in - event_branch repr (patch_guarded lambda action), total - end else - (event_branch repr action, jumps_empty) -| { args = (arg, str)::argl } -> - let v,newarg = arg_to_var arg m.cases in - let first_match,rem = - split_precompile (Some v) - { m with args = (newarg, Alias) :: argl } in - let (lam, total) = - comp_match_handlers - ((if dbg then do_compile_matching_pr else do_compile_matching) repr) - partial ctx newarg first_match rem in - bind_check str v arg lam, total -| _ -> assert false - - -(* verbose version of do_compile_matching, for debug *) - -and do_compile_matching_pr repr partial ctx arg x = - Format.eprintf "COMPILE: %s\nMATCH\n" - (match partial with Partial -> "Partial" | Total -> "Total") ; - pretty_precompiled x ; - Format.eprintf "CTX\n" ; - pretty_ctx ctx ; - let (_, jumps) as r = do_compile_matching repr partial ctx arg x in - Format.eprintf "JUMPS\n" ; - pretty_jumps jumps ; - r - -and do_compile_matching repr partial ctx arg pmh = match pmh with -| Pm pm -> - let pat = what_is_cases pm.cases in - begin match pat.pat_desc with - | Tpat_any -> - compile_no_test - divide_var ctx_rshift repr partial ctx pm - | Tpat_tuple patl -> - compile_no_test - (divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine - repr partial ctx pm - | Tpat_record ((_, lbl,_)::_,_) -> - compile_no_test - (divide_record lbl.lbl_all (normalize_pat pat)) - ctx_combine repr partial ctx pm - | Tpat_constant cst -> - compile_test - (compile_match repr partial) partial - divide_constant - (combine_constant pat.pat_loc arg cst partial) - ctx pm - | Tpat_construct (_, cstr, _) -> - compile_test - (compile_match repr partial) partial - divide_constructor - (combine_constructor pat.pat_loc arg pat cstr partial) - ctx pm - | Tpat_array _ -> - let kind = Typeopt.array_pattern_kind pat in - compile_test (compile_match repr partial) partial - (divide_array kind) (combine_array pat.pat_loc arg kind partial) - ctx pm - | Tpat_lazy _ -> - compile_no_test - (divide_lazy (normalize_pat pat)) - ctx_combine repr partial ctx pm - | Tpat_variant(_, _, row) -> - compile_test (compile_match repr partial) partial - (divide_variant !row) - (combine_variant pat.pat_loc !row arg partial) - ctx pm - | _ -> assert false - end -| PmVar {inside=pmh ; var_arg=arg} -> - let lam, total = - do_compile_matching repr partial (ctx_lshift ctx) arg pmh in - lam, jumps_map ctx_rshift total -| PmOr {body=body ; handlers=handlers} -> - let lam, total = compile_match repr partial ctx body in - compile_orhandlers (compile_match repr partial) lam total ctx handlers - -and compile_no_test divide up_ctx repr partial ctx to_match = - let {pm=this_match ; ctx=this_ctx } = divide ctx to_match in - let lambda,total = compile_match repr partial this_ctx this_match in - lambda, jumps_map up_ctx total - - - - -(* The entry points *) - -(* - If there is a guard in a matching or a lazy pattern, - then set exhaustiveness info to Partial. - (because of side effects, assume the worst). - - Notice that exhaustiveness information is trusted by the compiler, - that is, a match flagged as Total should not fail at runtime. - More specifically, for instance if match y with x::_ -> x is flagged - total (as it happens during JoCaml compilation) then y cannot be [] - at runtime. As a consequence, the static Total exhaustiveness information - have to be downgraded to Partial, in the dubious cases where guards - or lazy pattern execute arbitrary code that may perform side effects - and change the subject values. -LM: - Lazy pattern was PR#5992, initial patch by lpw25. - I have generalized the patch, so as to also find mutable fields. -*) - -let find_in_pat pred = - let rec find_rec p = - pred p.pat_desc || - begin match p.pat_desc with - | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p -> - find_rec p - | Tpat_tuple ps|Tpat_construct (_,_,ps) | Tpat_array ps -> - List.exists find_rec ps - | Tpat_record (lpats,_) -> - List.exists - (fun (_, _, p) -> find_rec p) - lpats - | Tpat_or (p,q,_) -> - find_rec p || find_rec q - | Tpat_constant _ | Tpat_var _ - | Tpat_any | Tpat_variant (_,None,_) -> false - | Tpat_exception _ -> assert false - end in - find_rec - -let is_lazy_pat = function - | Tpat_lazy _ -> true - | Tpat_alias _ | Tpat_variant _ | Tpat_record _ - | Tpat_tuple _|Tpat_construct _ | Tpat_array _ - | Tpat_or _ | Tpat_constant _ | Tpat_var _ | Tpat_any - -> false - | Tpat_exception _ -> assert false - -let is_lazy p = find_in_pat is_lazy_pat p - -let have_mutable_field p = match p with -| Tpat_record (lps,_) -> - List.exists - (fun (_,lbl,_) -> - match lbl.Types.lbl_mut with - | Mutable -> true - | Immutable -> false) - lps -| Tpat_alias _ | Tpat_variant _ | Tpat_lazy _ -| Tpat_tuple _|Tpat_construct _ | Tpat_array _ -| Tpat_or _ -| Tpat_constant _ | Tpat_var _ | Tpat_any - -> false -| Tpat_exception _ -> assert false - -let is_mutable p = find_in_pat have_mutable_field p - -(* Downgrade Total when - 1. Matching accesses some mutable fields; - 2. And there are guards or lazy patterns. -*) - -let check_partial is_mutable is_lazy pat_act_list = function - | Partial -> Partial - | Total -> - if - pat_act_list = [] || (* allow empty case list *) - List.exists - (fun (pats, lam) -> - is_mutable pats && (is_guarded lam || is_lazy pats)) - pat_act_list - then Partial - else Total - -let check_partial_list = - check_partial (List.exists is_mutable) (List.exists is_lazy) -let check_partial = check_partial is_mutable is_lazy - -(* have toplevel handler when appropriate *) - -let start_ctx n = [{left=[] ; right = omegas n}] - -let check_total total lambda i handler_fun = - if jumps_is_empty total then - lambda - else begin - Lstaticcatch(lambda, (i,[]), handler_fun()) - end - -let compile_matching repr handler_fun arg pat_act_list partial = - let partial = check_partial pat_act_list partial in - match partial with - | Partial -> - let raise_num = next_raise_count () in - let pm = - { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [arg, Strict] ; - default = [[[omega]],raise_num]} in - begin try - let (lambda, total) = compile_match repr partial (start_ctx 1) pm in - check_total total lambda raise_num handler_fun - with - | Unused -> assert false (* ; handler_fun() *) - end - | Total -> - let pm = - { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [arg, Strict] ; - default = []} in - let (lambda, total) = compile_match repr partial (start_ctx 1) pm in - assert (jumps_is_empty total) ; - lambda - - -let partial_function loc () = - let slot = - transl_extension_path loc - Env.initial_safe_string Predef.path_match_failure - in - let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in - Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable, None), - [slot; Lconst(Const_block(0, - [Const_base(Const_string (fname, None)); - Const_base(Const_int line); - Const_base(Const_int char)]))], loc)], loc) - -let for_function loc repr param pat_act_list partial = - compile_matching repr (partial_function loc) param pat_act_list partial - -(* In the following two cases, exhaustiveness info is not available! *) -let for_trywith param pat_act_list = - compile_matching None - (fun () -> Lprim(Praise Raise_reraise, [param], Location.none)) - param pat_act_list Partial - -let simple_for_let loc param pat body = - compile_matching None (partial_function loc) param [pat, body] Partial - - -(* Optimize binding of immediate tuples - - The goal of the implementation of 'for_let' below, which replaces - 'simple_for_let', is to avoid tuple allocation in cases such as - this one: - - let (x,y) = - let foo = ... in - if foo then (1, 2) else (3,4) - in bar - - The compiler easily optimizes the simple `let (x,y) = (1,2) in ...` - case (call to Matching.for_multiple_match from Translcore), but - didn't optimize situations where the rhs tuples are hidden under - a more complex context. - - The idea comes from Alain Frisch who suggested and implemented - the following compilation method, based on Lassign: - - let x = dummy in let y = dummy in - begin - let foo = ... in - if foo then - (let x1 = 1 in let y1 = 2 in x <- x1; y <- y1) - else - (let x2 = 3 in let y2 = 4 in x <- x2; y <- y2) - end; - bar - - The current implementation from Gabriel Scherer uses Lstaticcatch / - Lstaticraise instead: - - catch - let foo = ... in - if foo then - (let x1 = 1 in let y1 = 2 in exit x1 y1) - else - (let x2 = 3 in let y2 = 4 in exit x2 y2) - with x y -> - bar - - The catch/exit is used to avoid duplication of the let body ('bar' - in the example), on 'if' branches for example; it is useless for - linear contexts such as 'let', but we don't need to be careful to - generate nice code because Simplif will remove such useless - catch/exit. -*) - -let rec map_return f = function - | Llet (str, k, id, l1, l2) -> Llet (str, k, id, l1, map_return f l2) - | Lletrec (l1, l2) -> Lletrec (l1, map_return f l2) - | Lifthenelse (lcond, lthen, lelse) -> - Lifthenelse (lcond, map_return f lthen, map_return f lelse) - | Lsequence (l1, l2) -> Lsequence (l1, map_return f l2) - | Levent (l, ev) -> Levent (map_return f l, ev) - | Ltrywith (l1, id, l2) -> Ltrywith (map_return f l1, id, map_return f l2) - | Lstaticcatch (l1, b, l2) -> - Lstaticcatch (map_return f l1, b, map_return f l2) - | Lstaticraise _ | Lprim(Praise _, _, _) as l -> l - | l -> f l - -(* The 'opt' reference indicates if the optimization is worthy. - - It is shared by the different calls to 'assign_pat' performed from - 'map_return'. For example with the code - let (x, y) = if foo then z else (1,2) - the else-branch will activate the optimization for both branches. - - That means that the optimization is activated if *there exists* an - interesting tuple in one hole of the let-rhs context. We could - choose to activate it only if *all* holes are interesting. We made - that choice because being optimistic is extremely cheap (one static - exit/catch overhead in the "wrong cases"), while being pessimistic - can be costly (one unnecessary tuple allocation). -*) - -let assign_pat opt nraise catch_ids loc pat lam = - let rec collect acc pat lam = match pat.pat_desc, lam with - | Tpat_tuple patl, Lprim(Pmakeblock _, lams, _) -> - opt := true; - List.fold_left2 collect acc patl lams - | Tpat_tuple patl, Lconst(Const_block(_, scl)) -> - opt := true; - let collect_const acc pat sc = collect acc pat (Lconst sc) in - List.fold_left2 collect_const acc patl scl - | _ -> - (* pattern idents will be bound in staticcatch (let body), so we - refresh them here to guarantee binders uniqueness *) - let pat_ids = pat_bound_idents pat in - let fresh_ids = List.map (fun id -> id, Ident.rename id) pat_ids in - (fresh_ids, alpha_pat fresh_ids pat, lam) :: acc - in - - (* sublets were accumulated by 'collect' with the leftmost tuple - pattern at the bottom of the list; to respect right-to-left - evaluation order for tuples, we must evaluate sublets - top-to-bottom. To preserve tail-rec, we will fold_left the - reversed list. *) - let rev_sublets = List.rev (collect [] pat lam) in - let exit = - (* build an Ident.tbl to avoid quadratic refreshing costs *) - let add t (id, fresh_id) = Ident.add id fresh_id t in - let add_ids acc (ids, _pat, _lam) = List.fold_left add acc ids in - let tbl = List.fold_left add_ids Ident.empty rev_sublets in - let fresh_var id = Lvar (Ident.find_same id tbl) in - Lstaticraise(nraise, List.map fresh_var catch_ids) - in - let push_sublet code (_ids, pat, lam) = simple_for_let loc lam pat code in - List.fold_left push_sublet exit rev_sublets - -let for_let loc param pat body = - match pat.pat_desc with - | Tpat_any -> - (* This eliminates a useless variable (and stack slot in bytecode) - for "let _ = ...". See #6865. *) - Lsequence(param, body) - | Tpat_var (id, _) -> - (* fast path, and keep track of simple bindings to unboxable numbers *) - let k = Typeopt.value_kind pat.pat_env pat.pat_type in - Llet(Strict, k, id, param, body) - | _ -> - let opt = ref false in - let nraise = next_raise_count () in - let catch_ids = pat_bound_idents_full pat in - let ids_with_kinds = - List.map (fun (id, _, typ) -> id, Typeopt.value_kind pat.pat_env typ) - catch_ids - in - let ids = List.map (fun (id, _, _) -> id) catch_ids in - let bind = map_return (assign_pat opt nraise ids loc pat) param in - if !opt then Lstaticcatch(bind, (nraise, ids_with_kinds), body) - else simple_for_let loc param pat body - -(* Handling of tupled functions and matchings *) - -(* Easy case since variables are available *) -let for_tupled_function loc paraml pats_act_list partial = - let partial = check_partial_list pats_act_list partial in - let raise_num = next_raise_count () in - let omegas = [List.map (fun _ -> omega) paraml] in - let pm = - { cases = pats_act_list; - args = List.map (fun id -> (Lvar id, Strict)) paraml ; - default = [omegas,raise_num] - } in - try - let (lambda, total) = compile_match None partial - (start_ctx (List.length paraml)) pm in - check_total total lambda raise_num (partial_function loc) - with - | Unused -> partial_function loc () - - - -let flatten_pattern size p = match p.pat_desc with -| Tpat_tuple args -> args -| Tpat_any -> omegas size -| _ -> raise Cannot_flatten - -let rec flatten_pat_line size p k = match p.pat_desc with -| Tpat_any -> omegas size::k -| Tpat_tuple args -> args::k -| Tpat_or (p1,p2,_) -> flatten_pat_line size p1 (flatten_pat_line size p2 k) -| Tpat_alias (p,_,_) -> (* Note: if this 'as' pat is here, then this is a - useless binding, solves PR#3780 *) - flatten_pat_line size p k -| _ -> fatal_error "Matching.flatten_pat_line" - -let flatten_cases size cases = - List.map - (fun (ps,action) -> match ps with - | [p] -> flatten_pattern size p,action - | _ -> fatal_error "Matching.flatten_case") - cases - -let flatten_matrix size pss = - List.fold_right - (fun ps r -> match ps with - | [p] -> flatten_pat_line size p r - | _ -> fatal_error "Matching.flatten_matrix") - pss [] - -let flatten_def size def = - List.map - (fun (pss,i) -> flatten_matrix size pss,i) - def - -let flatten_pm size args pm = - {args = args ; cases = flatten_cases size pm.cases ; - default = flatten_def size pm.default} - - -let flatten_precompiled size args pmh = match pmh with -| Pm pm -> Pm (flatten_pm size args pm) -| PmOr {body=b ; handlers=hs ; or_matrix=m} -> - PmOr - {body=flatten_pm size args b ; - handlers= - List.map - (fun (mat,i,vars,pm) -> flatten_matrix size mat,i,vars,pm) - hs ; - or_matrix=flatten_matrix size m ;} -| PmVar _ -> assert false - -(* - compiled_flattened is a ``comp_fun'' argument to comp_match_handlers. - Hence it needs a fourth argument, which it ignores -*) - -let compile_flattened repr partial ctx _ pmh = match pmh with -| Pm pm -> compile_match repr partial ctx pm -| PmOr {body=b ; handlers=hs} -> - let lam, total = compile_match repr partial ctx b in - compile_orhandlers (compile_match repr partial) lam total ctx hs -| PmVar _ -> assert false - -let do_for_multiple_match loc paraml pat_act_list partial = - let repr = None in - let partial = check_partial pat_act_list partial in - let raise_num,pm1 = - match partial with - | Partial -> - let raise_num = next_raise_count () in - raise_num, - { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [Lprim(Pmakeblock(0, Immutable, None), paraml, loc), Strict]; - default = [[[omega]],raise_num] } - | _ -> - -1, - { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [Lprim(Pmakeblock(0, Immutable, None), paraml, loc), Strict]; - default = [] } in - - try - try -(* Once for checking that compilation is possible *) - let next, nexts = split_precompile None pm1 in - - let size = List.length paraml - and idl = List.map (fun _ -> Ident.create_local "*match*") paraml in - let args = List.map (fun id -> Lvar id, Alias) idl in - - let flat_next = flatten_precompiled size args next - and flat_nexts = - List.map - (fun (e,pm) -> e,flatten_precompiled size args pm) - nexts in - - let lam, total = - comp_match_handlers - (compile_flattened repr) - partial (start_ctx size) () flat_next flat_nexts in - List.fold_right2 (bind Strict) idl paraml - (match partial with - | Partial -> - check_total total lam raise_num (partial_function loc) - | Total -> - assert (jumps_is_empty total) ; - lam) - with Cannot_flatten -> - let (lambda, total) = compile_match None partial (start_ctx 1) pm1 in - begin match partial with - | Partial -> - check_total total lambda raise_num (partial_function loc) - | Total -> - assert (jumps_is_empty total) ; - lambda - end - with Unused -> - assert false (* ; partial_function loc () *) - -(* PR#4828: Believe it or not, the 'paraml' argument below - may not be side effect free. *) - -let param_to_var param = match param with -| Lvar v -> v,None -| _ -> Ident.create_local "*match*",Some param - -let bind_opt (v,eo) k = match eo with -| None -> k -| Some e -> Lambda.bind Strict v e k - -let for_multiple_match loc paraml pat_act_list partial = - let v_paraml = List.map param_to_var paraml in - let paraml = List.map (fun (v,_) -> Lvar v) v_paraml in - List.fold_right bind_opt v_paraml - (do_for_multiple_match loc paraml pat_act_list partial) diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli deleted file mode 100644 index f29901bd..00000000 --- a/bytecomp/matching.mli +++ /dev/null @@ -1,46 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Compilation of pattern-matching *) - -open Typedtree -open Lambda - - -(* Entry points to match compiler *) -val for_function: - Location.t -> int ref option -> lambda -> (pattern * lambda) list -> - partial -> lambda -val for_trywith: - lambda -> (pattern * lambda) list -> lambda -val for_let: - Location.t -> lambda -> pattern -> lambda -> lambda -val for_multiple_match: - Location.t -> lambda list -> (pattern * lambda) list -> partial -> - lambda - -val for_tupled_function: - Location.t -> Ident.t list -> (pattern list * lambda) list -> - partial -> lambda - -exception Cannot_flatten - -val flatten_pattern: int -> pattern -> pattern list - -(* Expand stringswitch to string test tree *) -val expand_stringswitch: - Location.t -> lambda -> (string * lambda) list -> lambda option -> lambda - -val inline_lazy_force : lambda -> Location.t -> lambda diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml deleted file mode 100644 index e4bb26a6..00000000 --- a/bytecomp/printlambda.ml +++ /dev/null @@ -1,648 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Format -open Asttypes -open Primitive -open Types -open Lambda - - -let rec struct_const ppf = function - | Const_base(Const_int n) -> fprintf ppf "%i" n - | Const_base(Const_char c) -> fprintf ppf "%C" c - | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s - | Const_immstring s -> fprintf ppf "#%S" s - | Const_base(Const_float f) -> fprintf ppf "%s" f - | Const_base(Const_int32 n) -> fprintf ppf "%lil" n - | Const_base(Const_int64 n) -> fprintf ppf "%LiL" n - | Const_base(Const_nativeint n) -> fprintf ppf "%nin" n - | Const_pointer n -> fprintf ppf "%ia" n - | Const_block(tag, []) -> - fprintf ppf "[%i]" tag - | Const_block(tag, sc1::scl) -> - let sconsts ppf scl = - List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in - fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl - | Const_float_array [] -> - fprintf ppf "[| |]" - | Const_float_array (f1 :: fl) -> - let floats ppf fl = - List.iter (fun f -> fprintf ppf "@ %s" f) fl in - fprintf ppf "@[<1>[|@[%s%a@]|]@]" f1 floats fl - -let array_kind = function - | Pgenarray -> "gen" - | Paddrarray -> "addr" - | Pintarray -> "int" - | Pfloatarray -> "float" - -let boxed_integer_name = function - | Pnativeint -> "nativeint" - | Pint32 -> "int32" - | Pint64 -> "int64" - -let value_kind ppf = function - | Pgenval -> () - | Pintval -> fprintf ppf "[int]" - | Pfloatval -> fprintf ppf "[float]" - | Pboxedintval bi -> fprintf ppf "[%s]" (boxed_integer_name bi) - -let return_kind ppf = function - | Pgenval -> () - | Pintval -> fprintf ppf ": int@ " - | Pfloatval -> fprintf ppf ": float@ " - | Pboxedintval bi -> fprintf ppf ": %s@ " (boxed_integer_name bi) - -let field_kind = function - | Pgenval -> "*" - | Pintval -> "int" - | Pfloatval -> "float" - | Pboxedintval bi -> boxed_integer_name bi - -let print_boxed_integer_conversion ppf bi1 bi2 = - fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1) - -let boxed_integer_mark name = function - | Pnativeint -> Printf.sprintf "Nativeint.%s" name - | Pint32 -> Printf.sprintf "Int32.%s" name - | Pint64 -> Printf.sprintf "Int64.%s" name - -let print_boxed_integer name ppf bi = - fprintf ppf "%s" (boxed_integer_mark name bi);; - -let print_bigarray name unsafe kind ppf layout = - fprintf ppf "Bigarray.%s[%s,%s]" - (if unsafe then "unsafe_"^ name else name) - (match kind with - | Pbigarray_unknown -> "generic" - | Pbigarray_float32 -> "float32" - | Pbigarray_float64 -> "float64" - | Pbigarray_sint8 -> "sint8" - | Pbigarray_uint8 -> "uint8" - | Pbigarray_sint16 -> "sint16" - | Pbigarray_uint16 -> "uint16" - | Pbigarray_int32 -> "int32" - | Pbigarray_int64 -> "int64" - | Pbigarray_caml_int -> "camlint" - | Pbigarray_native_int -> "nativeint" - | Pbigarray_complex32 -> "complex32" - | Pbigarray_complex64 -> "complex64") - (match layout with - | Pbigarray_unknown_layout -> "unknown" - | Pbigarray_c_layout -> "C" - | Pbigarray_fortran_layout -> "Fortran") - -let record_rep ppf r = - match r with - | Record_regular -> fprintf ppf "regular" - | Record_inlined i -> fprintf ppf "inlined(%i)" i - | Record_unboxed false -> fprintf ppf "unboxed" - | Record_unboxed true -> fprintf ppf "inlined(unboxed)" - | Record_float -> fprintf ppf "float" - | Record_extension path -> fprintf ppf "ext(%a)" Printtyp.path path -;; - -let block_shape ppf shape = match shape with - | None | Some [] -> () - | Some l when List.for_all ((=) Pgenval) l -> () - | Some [elt] -> - Format.fprintf ppf " (%s)" (field_kind elt) - | Some (h :: t) -> - Format.fprintf ppf " (%s" (field_kind h); - List.iter (fun elt -> - Format.fprintf ppf ",%s" (field_kind elt)) - t; - Format.fprintf ppf ")" - -let integer_comparison ppf = function - | Ceq -> fprintf ppf "==" - | Cne -> fprintf ppf "!=" - | Clt -> fprintf ppf "<" - | Cle -> fprintf ppf "<=" - | Cgt -> fprintf ppf ">" - | Cge -> fprintf ppf ">=" - -let float_comparison ppf = function - | CFeq -> fprintf ppf "==." - | CFneq -> fprintf ppf "!=." - | CFlt -> fprintf ppf "<." - | CFnlt -> fprintf ppf "!<." - | CFle -> fprintf ppf "<=." - | CFnle -> fprintf ppf "!<=." - | CFgt -> fprintf ppf ">." - | CFngt -> fprintf ppf "!>." - | CFge -> fprintf ppf ">=." - | CFnge -> fprintf ppf "!>=." - -let primitive ppf = function - | Pidentity -> fprintf ppf "id" - | Pbytes_to_string -> fprintf ppf "bytes_to_string" - | Pbytes_of_string -> fprintf ppf "bytes_of_string" - | Pignore -> fprintf ppf "ignore" - | Prevapply -> fprintf ppf "revapply" - | Pdirapply -> fprintf ppf "dirapply" - | Pgetglobal id -> fprintf ppf "global %a" Ident.print id - | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id - | Pmakeblock(tag, Immutable, shape) -> - fprintf ppf "makeblock %i%a" tag block_shape shape - | Pmakeblock(tag, Mutable, shape) -> - fprintf ppf "makemutable %i%a" tag block_shape shape - | Pfield n -> fprintf ppf "field %i" n - | Pfield_computed -> fprintf ppf "field_computed" - | Psetfield(n, ptr, init) -> - let instr = - match ptr with - | Pointer -> "ptr" - | Immediate -> "imm" - in - let init = - match init with - | Heap_initialization -> "(heap-init)" - | Root_initialization -> "(root-init)" - | Assignment -> "" - in - fprintf ppf "setfield_%s%s %i" instr init n - | Psetfield_computed (ptr, init) -> - let instr = - match ptr with - | Pointer -> "ptr" - | Immediate -> "imm" - in - let init = - match init with - | Heap_initialization -> "(heap-init)" - | Root_initialization -> "(root-init)" - | Assignment -> "" - in - fprintf ppf "setfield_%s%s_computed" instr init - | Pfloatfield n -> fprintf ppf "floatfield %i" n - | Psetfloatfield (n, init) -> - let init = - match init with - | Heap_initialization -> "(heap-init)" - | Root_initialization -> "(root-init)" - | Assignment -> "" - in - fprintf ppf "setfloatfield%s %i" init n - | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size - | Pccall p -> fprintf ppf "%s" p.prim_name - | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) - | Psequand -> fprintf ppf "&&" - | Psequor -> fprintf ppf "||" - | Pnot -> fprintf ppf "not" - | Pnegint -> fprintf ppf "~" - | Paddint -> fprintf ppf "+" - | Psubint -> fprintf ppf "-" - | Pmulint -> fprintf ppf "*" - | Pdivint Safe -> fprintf ppf "/" - | Pdivint Unsafe -> fprintf ppf "/u" - | Pmodint Safe -> fprintf ppf "mod" - | Pmodint Unsafe -> fprintf ppf "mod_unsafe" - | Pandint -> fprintf ppf "and" - | Porint -> fprintf ppf "or" - | Pxorint -> fprintf ppf "xor" - | Plslint -> fprintf ppf "lsl" - | Plsrint -> fprintf ppf "lsr" - | Pasrint -> fprintf ppf "asr" - | Pintcomp(cmp) -> integer_comparison ppf cmp - | Poffsetint n -> fprintf ppf "%i+" n - | Poffsetref n -> fprintf ppf "+:=%i"n - | Pintoffloat -> fprintf ppf "int_of_float" - | Pfloatofint -> fprintf ppf "float_of_int" - | Pnegfloat -> fprintf ppf "~." - | Pabsfloat -> fprintf ppf "abs." - | Paddfloat -> fprintf ppf "+." - | Psubfloat -> fprintf ppf "-." - | Pmulfloat -> fprintf ppf "*." - | Pdivfloat -> fprintf ppf "/." - | Pfloatcomp(cmp) -> float_comparison ppf cmp - | Pstringlength -> fprintf ppf "string.length" - | Pstringrefu -> fprintf ppf "string.unsafe_get" - | Pstringrefs -> fprintf ppf "string.get" - | Pbyteslength -> fprintf ppf "bytes.length" - | Pbytesrefu -> fprintf ppf "bytes.unsafe_get" - | Pbytessetu -> fprintf ppf "bytes.unsafe_set" - | Pbytesrefs -> fprintf ppf "bytes.get" - | Pbytessets -> fprintf ppf "bytes.set" - - | Parraylength k -> fprintf ppf "array.length[%s]" (array_kind k) - | Pmakearray (k, Mutable) -> fprintf ppf "makearray[%s]" (array_kind k) - | Pmakearray (k, Immutable) -> fprintf ppf "makearray_imm[%s]" (array_kind k) - | Pduparray (k, Mutable) -> fprintf ppf "duparray[%s]" (array_kind k) - | Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k) - | Parrayrefu k -> fprintf ppf "array.unsafe_get[%s]" (array_kind k) - | Parraysetu k -> fprintf ppf "array.unsafe_set[%s]" (array_kind k) - | Parrayrefs k -> fprintf ppf "array.get[%s]" (array_kind k) - | Parraysets k -> fprintf ppf "array.set[%s]" (array_kind k) - | Pctconst c -> - let const_name = match c with - | Big_endian -> "big_endian" - | Word_size -> "word_size" - | Int_size -> "int_size" - | Max_wosize -> "max_wosize" - | Ostype_unix -> "ostype_unix" - | Ostype_win32 -> "ostype_win32" - | Ostype_cygwin -> "ostype_cygwin" - | Backend_type -> "backend_type" in - fprintf ppf "sys.constant_%s" const_name - | Pisint -> fprintf ppf "isint" - | Pisout -> fprintf ppf "isout" - | Pbintofint bi -> print_boxed_integer "of_int" ppf bi - | Pintofbint bi -> print_boxed_integer "to_int" ppf bi - | Pcvtbint (bi1, bi2) -> print_boxed_integer_conversion ppf bi1 bi2 - | Pnegbint bi -> print_boxed_integer "neg" ppf bi - | Paddbint bi -> print_boxed_integer "add" ppf bi - | Psubbint bi -> print_boxed_integer "sub" ppf bi - | Pmulbint bi -> print_boxed_integer "mul" ppf bi - | Pdivbint { size = bi; is_safe = Safe } -> - print_boxed_integer "div" ppf bi - | Pdivbint { size = bi; is_safe = Unsafe } -> - print_boxed_integer "div_unsafe" ppf bi - | Pmodbint { size = bi; is_safe = Safe } -> - print_boxed_integer "mod" ppf bi - | Pmodbint { size = bi; is_safe = Unsafe } -> - print_boxed_integer "mod_unsafe" ppf bi - | Pandbint bi -> print_boxed_integer "and" ppf bi - | Porbint bi -> print_boxed_integer "or" ppf bi - | Pxorbint bi -> print_boxed_integer "xor" ppf bi - | Plslbint bi -> print_boxed_integer "lsl" ppf bi - | Plsrbint bi -> print_boxed_integer "lsr" ppf bi - | Pasrbint bi -> print_boxed_integer "asr" ppf bi - | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi - | Pbintcomp(bi, Cne) -> print_boxed_integer "!=" ppf bi - | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi - | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi - | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi - | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi - | Pbigarrayref(unsafe, _n, kind, layout) -> - print_bigarray "get" unsafe kind ppf layout - | Pbigarrayset(unsafe, _n, kind, layout) -> - print_bigarray "set" unsafe kind ppf layout - | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n - | Pstring_load_16(unsafe) -> - if unsafe then fprintf ppf "string.unsafe_get16" - else fprintf ppf "string.get16" - | Pstring_load_32(unsafe) -> - if unsafe then fprintf ppf "string.unsafe_get32" - else fprintf ppf "string.get32" - | Pstring_load_64(unsafe) -> - if unsafe then fprintf ppf "string.unsafe_get64" - else fprintf ppf "string.get64" - | Pbytes_load_16(unsafe) -> - if unsafe then fprintf ppf "bytes.unsafe_get16" - else fprintf ppf "bytes.get16" - | Pbytes_load_32(unsafe) -> - if unsafe then fprintf ppf "bytes.unsafe_get32" - else fprintf ppf "bytes.get32" - | Pbytes_load_64(unsafe) -> - if unsafe then fprintf ppf "bytes.unsafe_get64" - else fprintf ppf "bytes.get64" - | Pbytes_set_16(unsafe) -> - if unsafe then fprintf ppf "bytes.unsafe_set16" - else fprintf ppf "bytes.set16" - | Pbytes_set_32(unsafe) -> - if unsafe then fprintf ppf "bytes.unsafe_set32" - else fprintf ppf "bytes.set32" - | Pbytes_set_64(unsafe) -> - if unsafe then fprintf ppf "bytes.unsafe_set64" - else fprintf ppf "bytes.set64" - | Pbigstring_load_16(unsafe) -> - if unsafe then fprintf ppf "bigarray.array1.unsafe_get16" - else fprintf ppf "bigarray.array1.get16" - | Pbigstring_load_32(unsafe) -> - if unsafe then fprintf ppf "bigarray.array1.unsafe_get32" - else fprintf ppf "bigarray.array1.get32" - | Pbigstring_load_64(unsafe) -> - if unsafe then fprintf ppf "bigarray.array1.unsafe_get64" - else fprintf ppf "bigarray.array1.get64" - | Pbigstring_set_16(unsafe) -> - if unsafe then fprintf ppf "bigarray.array1.unsafe_set16" - else fprintf ppf "bigarray.array1.set16" - | Pbigstring_set_32(unsafe) -> - if unsafe then fprintf ppf "bigarray.array1.unsafe_set32" - else fprintf ppf "bigarray.array1.set32" - | Pbigstring_set_64(unsafe) -> - if unsafe then fprintf ppf "bigarray.array1.unsafe_set64" - else fprintf ppf "bigarray.array1.set64" - | Pbswap16 -> fprintf ppf "bswap16" - | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi - | Pint_as_pointer -> fprintf ppf "int_as_pointer" - | Popaque -> fprintf ppf "opaque" - -let name_of_primitive = function - | Pidentity -> "Pidentity" - | Pbytes_of_string -> "Pbytes_of_string" - | Pbytes_to_string -> "Pbytes_to_string" - | Pignore -> "Pignore" - | Prevapply -> "Prevapply" - | Pdirapply -> "Pdirapply" - | Pgetglobal _ -> "Pgetglobal" - | Psetglobal _ -> "Psetglobal" - | Pmakeblock _ -> "Pmakeblock" - | Pfield _ -> "Pfield" - | Pfield_computed -> "Pfield_computed" - | Psetfield _ -> "Psetfield" - | Psetfield_computed _ -> "Psetfield_computed" - | Pfloatfield _ -> "Pfloatfield" - | Psetfloatfield _ -> "Psetfloatfield" - | Pduprecord _ -> "Pduprecord" - | Pccall _ -> "Pccall" - | Praise _ -> "Praise" - | Psequand -> "Psequand" - | Psequor -> "Psequor" - | Pnot -> "Pnot" - | Pnegint -> "Pnegint" - | Paddint -> "Paddint" - | Psubint -> "Psubint" - | Pmulint -> "Pmulint" - | Pdivint _ -> "Pdivint" - | Pmodint _ -> "Pmodint" - | Pandint -> "Pandint" - | Porint -> "Porint" - | Pxorint -> "Pxorint" - | Plslint -> "Plslint" - | Plsrint -> "Plsrint" - | Pasrint -> "Pasrint" - | Pintcomp _ -> "Pintcomp" - | Poffsetint _ -> "Poffsetint" - | Poffsetref _ -> "Poffsetref" - | Pintoffloat -> "Pintoffloat" - | Pfloatofint -> "Pfloatofint" - | Pnegfloat -> "Pnegfloat" - | Pabsfloat -> "Pabsfloat" - | Paddfloat -> "Paddfloat" - | Psubfloat -> "Psubfloat" - | Pmulfloat -> "Pmulfloat" - | Pdivfloat -> "Pdivfloat" - | Pfloatcomp _ -> "Pfloatcomp" - | Pstringlength -> "Pstringlength" - | Pstringrefu -> "Pstringrefu" - | Pstringrefs -> "Pstringrefs" - | Pbyteslength -> "Pbyteslength" - | Pbytesrefu -> "Pbytesrefu" - | Pbytessetu -> "Pbytessetu" - | Pbytesrefs -> "Pbytesrefs" - | Pbytessets -> "Pbytessets" - | Parraylength _ -> "Parraylength" - | Pmakearray _ -> "Pmakearray" - | Pduparray _ -> "Pduparray" - | Parrayrefu _ -> "Parrayrefu" - | Parraysetu _ -> "Parraysetu" - | Parrayrefs _ -> "Parrayrefs" - | Parraysets _ -> "Parraysets" - | Pctconst _ -> "Pctconst" - | Pisint -> "Pisint" - | Pisout -> "Pisout" - | Pbintofint _ -> "Pbintofint" - | Pintofbint _ -> "Pintofbint" - | Pcvtbint _ -> "Pcvtbint" - | Pnegbint _ -> "Pnegbint" - | Paddbint _ -> "Paddbint" - | Psubbint _ -> "Psubbint" - | Pmulbint _ -> "Pmulbint" - | Pdivbint _ -> "Pdivbint" - | Pmodbint _ -> "Pmodbint" - | Pandbint _ -> "Pandbint" - | Porbint _ -> "Porbint" - | Pxorbint _ -> "Pxorbint" - | Plslbint _ -> "Plslbint" - | Plsrbint _ -> "Plsrbint" - | Pasrbint _ -> "Pasrbint" - | Pbintcomp _ -> "Pbintcomp" - | Pbigarrayref _ -> "Pbigarrayref" - | Pbigarrayset _ -> "Pbigarrayset" - | Pbigarraydim _ -> "Pbigarraydim" - | Pstring_load_16 _ -> "Pstring_load_16" - | Pstring_load_32 _ -> "Pstring_load_32" - | Pstring_load_64 _ -> "Pstring_load_64" - | Pbytes_load_16 _ -> "Pbytes_load_16" - | Pbytes_load_32 _ -> "Pbytes_load_32" - | Pbytes_load_64 _ -> "Pbytes_load_64" - | Pbytes_set_16 _ -> "Pbytes_set_16" - | Pbytes_set_32 _ -> "Pbytes_set_32" - | Pbytes_set_64 _ -> "Pbytes_set_64" - | Pbigstring_load_16 _ -> "Pbigstring_load_16" - | Pbigstring_load_32 _ -> "Pbigstring_load_32" - | Pbigstring_load_64 _ -> "Pbigstring_load_64" - | Pbigstring_set_16 _ -> "Pbigstring_set_16" - | Pbigstring_set_32 _ -> "Pbigstring_set_32" - | Pbigstring_set_64 _ -> "Pbigstring_set_64" - | Pbswap16 -> "Pbswap16" - | Pbbswap _ -> "Pbbswap" - | Pint_as_pointer -> "Pint_as_pointer" - | Popaque -> "Popaque" - -let function_attribute ppf { inline; specialise; local; is_a_functor; stub } = - if is_a_functor then - fprintf ppf "is_a_functor@ "; - if stub then - fprintf ppf "stub@ "; - begin match inline with - | Default_inline -> () - | Always_inline -> fprintf ppf "always_inline@ " - | Never_inline -> fprintf ppf "never_inline@ " - | Unroll i -> fprintf ppf "unroll(%i)@ " i - end; - begin match specialise with - | Default_specialise -> () - | Always_specialise -> fprintf ppf "always_specialise@ " - | Never_specialise -> fprintf ppf "never_specialise@ " - end; - begin match local with - | Default_local -> () - | Always_local -> fprintf ppf "always_local@ " - | Never_local -> fprintf ppf "never_local@ " - end - -let apply_tailcall_attribute ppf tailcall = - if tailcall then - fprintf ppf " @@tailcall" - -let apply_inlined_attribute ppf = function - | Default_inline -> () - | Always_inline -> fprintf ppf " always_inline" - | Never_inline -> fprintf ppf " never_inline" - | Unroll i -> fprintf ppf " never_inline(%i)" i - -let apply_specialised_attribute ppf = function - | Default_specialise -> () - | Always_specialise -> fprintf ppf " always_specialise" - | Never_specialise -> fprintf ppf " never_specialise" - -let rec lam ppf = function - | Lvar id -> - Ident.print ppf id - | Lconst cst -> - struct_const ppf cst - | Lapply ap -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(apply@ %a%a%a%a%a)@]" lam ap.ap_func lams ap.ap_args - apply_tailcall_attribute ap.ap_should_be_tailcall - apply_inlined_attribute ap.ap_inlined - apply_specialised_attribute ap.ap_specialised - | Lfunction{kind; params; return; body; attr} -> - let pr_params ppf params = - match kind with - | Curried -> - List.iter (fun (param, k) -> - fprintf ppf "@ %a%a" Ident.print param value_kind k) params - | Tupled -> - fprintf ppf " ("; - let first = ref true in - List.iter - (fun (param, k) -> - if !first then first := false else fprintf ppf ",@ "; - Ident.print ppf param; - value_kind ppf k) - params; - fprintf ppf ")" in - fprintf ppf "@[<2>(function%a@ %a%a%a)@]" pr_params params - function_attribute attr return_kind return lam body - | Llet(str, k, id, arg, body) -> - let kind = function - Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v" - in - let rec letbody = function - | Llet(str, k, id, arg, body) -> - fprintf ppf "@ @[<2>%a =%s%a@ %a@]" - Ident.print id (kind str) value_kind k lam arg; - letbody body - | expr -> expr in - fprintf ppf "@[<2>(let@ @[(@[<2>%a =%s%a@ %a@]" - Ident.print id (kind str) value_kind k lam arg; - let expr = letbody body in - fprintf ppf ")@]@ %a)@]" lam expr - | Lletrec(id_arg_list, body) -> - let bindings ppf id_arg_list = - let spc = ref false in - List.iter - (fun (id, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<2>%a@ %a@]" Ident.print id lam l) - id_arg_list in - fprintf ppf - "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body - | Lprim(prim, largs, _) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs - | Lswitch(larg, sw, _loc) -> - let switch ppf sw = - let spc = ref false in - List.iter - (fun (n, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case int %i:@ %a@]" n lam l) - sw.sw_consts; - List.iter - (fun (n, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case tag %i:@ %a@]" n lam l) - sw.sw_blocks ; - begin match sw.sw_failaction with - | None -> () - | Some l -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam l - end in - fprintf ppf - "@[<1>(%s %a@ @[%a@])@]" - (match sw.sw_failaction with None -> "switch*" | _ -> "switch") - lam larg switch sw - | Lstringswitch(arg, cases, default, _) -> - let switch ppf cases = - let spc = ref false in - List.iter - (fun (s, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) - cases; - begin match default with - | Some default -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam default - | None -> () - end in - fprintf ppf - "@[<1>(stringswitch %a@ @[%a@])@]" lam arg switch cases - | Lstaticraise (i, ls) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls; - | Lstaticcatch(lbody, (i, vars), lhandler) -> - fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" - lam lbody i - (fun ppf vars -> - List.iter - (fun (x, k) -> fprintf ppf " %a%a" Ident.print x value_kind k) - vars - ) - vars - lam lhandler - | Ltrywith(lbody, param, lhandler) -> - fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" - lam lbody Ident.print param lam lhandler - | Lifthenelse(lcond, lif, lelse) -> - fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse - | Lsequence(l1, l2) -> - fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 - | Lwhile(lcond, lbody) -> - fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody - | Lfor(param, lo, hi, dir, body) -> - fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" - Ident.print param lam lo - (match dir with Upto -> "to" | Downto -> "downto") - lam hi lam body - | Lassign(id, expr) -> - fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr - | Lsend (k, met, obj, largs, _) -> - let args ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - let kind = - if k = Self then "self" else if k = Cached then "cache" else "" in - fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs - | Levent(expr, ev) -> - let kind = - match ev.lev_kind with - | Lev_before -> "before" - | Lev_after _ -> "after" - | Lev_function -> "funct-body" - | Lev_pseudo -> "pseudo" - | Lev_module_definition ident -> - Format.asprintf "module-defn(%a)" Ident.print ident - in - fprintf ppf "@[<2>(%s %s(%i)%s:%i-%i@ %a)@]" kind - ev.lev_loc.Location.loc_start.Lexing.pos_fname - ev.lev_loc.Location.loc_start.Lexing.pos_lnum - (if ev.lev_loc.Location.loc_ghost then "" else "") - ev.lev_loc.Location.loc_start.Lexing.pos_cnum - ev.lev_loc.Location.loc_end.Lexing.pos_cnum - lam expr - | Lifused(id, expr) -> - fprintf ppf "@[<2>(ifused@ %a@ %a)@]" Ident.print id lam expr - -and sequence ppf = function - | Lsequence(l1, l2) -> - fprintf ppf "%a@ %a" sequence l1 sequence l2 - | l -> - lam ppf l - -let structured_constant = struct_const - -let lambda = lam - -let program ppf { code } = lambda ppf code diff --git a/bytecomp/printlambda.mli b/bytecomp/printlambda.mli deleted file mode 100644 index 137190ef..00000000 --- a/bytecomp/printlambda.mli +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Lambda - -open Format - -val structured_constant: formatter -> structured_constant -> unit -val lambda: formatter -> lambda -> unit -val program: formatter -> program -> unit -val primitive: formatter -> primitive -> unit -val name_of_primitive : primitive -> string -val value_kind : formatter -> value_kind -> unit -val array_kind : array_kind -> string diff --git a/bytecomp/runtimedef.mli b/bytecomp/runtimedef.mli deleted file mode 100644 index 3baabb64..00000000 --- a/bytecomp/runtimedef.mli +++ /dev/null @@ -1,19 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Values and functions known and/or provided by the runtime system *) - -val builtin_exceptions: string array -val builtin_primitives: string array diff --git a/bytecomp/semantics_of_primitives.ml b/bytecomp/semantics_of_primitives.ml deleted file mode 100644 index b6b09e19..00000000 --- a/bytecomp/semantics_of_primitives.ml +++ /dev/null @@ -1,180 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -type effects = No_effects | Only_generative_effects | Arbitrary_effects -type coeffects = No_coeffects | Has_coeffects - -let for_primitive (prim : Lambda.primitive) = - match prim with - | Pignore | Pidentity -> - No_effects, No_coeffects - | Pbytes_to_string | Pbytes_of_string -> - No_effects, No_coeffects - | Pmakeblock _ - | Pmakearray (_, Mutable) -> Only_generative_effects, No_coeffects - | Pmakearray (_, Immutable) -> No_effects, No_coeffects - | Pduparray (_, Immutable) -> - No_effects, No_coeffects (* Pduparray (_, Immutable) is allowed only on - immutable arrays. *) - | Pduparray (_, Mutable) | Pduprecord _ -> - Only_generative_effects, Has_coeffects - | Pccall { prim_name = - ( "caml_format_float" | "caml_format_int" | "caml_int32_format" - | "caml_nativeint_format" | "caml_int64_format" ) } -> - No_effects, No_coeffects - | Pccall _ -> Arbitrary_effects, Has_coeffects - | Praise _ -> Arbitrary_effects, No_coeffects - | Pnot - | Pnegint - | Paddint - | Psubint - | Pmulint - | Pandint - | Porint - | Pxorint - | Plslint - | Plsrint - | Pasrint - | Pintcomp _ -> No_effects, No_coeffects - | Pdivbint { is_safe = Unsafe } - | Pmodbint { is_safe = Unsafe } - | Pdivint Unsafe - | Pmodint Unsafe -> - No_effects, No_coeffects (* Will not raise [Division_by_zero]. *) - | Pdivbint { is_safe = Safe } - | Pmodbint { is_safe = Safe } - | Pdivint Safe - | Pmodint Safe -> - Arbitrary_effects, No_coeffects - | Poffsetint _ -> No_effects, No_coeffects - | Poffsetref _ -> Arbitrary_effects, Has_coeffects - | Pintoffloat - | Pfloatofint - | Pnegfloat - | Pabsfloat - | Paddfloat - | Psubfloat - | Pmulfloat - | Pdivfloat - | Pfloatcomp _ -> No_effects, No_coeffects - | Pstringlength | Pbyteslength - | Parraylength _ -> - No_effects, Has_coeffects (* That old chestnut: [Obj.truncate]. *) - | Pisint - | Pisout - | Pbintofint _ - | Pintofbint _ - | Pcvtbint _ - | Pnegbint _ - | Paddbint _ - | Psubbint _ - | Pmulbint _ - | Pandbint _ - | Porbint _ - | Pxorbint _ - | Plslbint _ - | Plsrbint _ - | Pasrbint _ - | Pbintcomp _ -> No_effects, No_coeffects - | Pbigarraydim _ -> - No_effects, Has_coeffects (* Some people resize bigarrays in place. *) - | Pfield _ - | Pfield_computed - | Pfloatfield _ - | Pgetglobal _ - | Parrayrefu _ - | Pstringrefu - | Pbytesrefu - | Pstring_load_16 true - | Pstring_load_32 true - | Pstring_load_64 true - | Pbytes_load_16 true - | Pbytes_load_32 true - | Pbytes_load_64 true - | Pbigarrayref (true, _, _, _) - | Pbigstring_load_16 true - | Pbigstring_load_32 true - | Pbigstring_load_64 true -> - No_effects, Has_coeffects - | Parrayrefs _ - | Pstringrefs - | Pbytesrefs - | Pstring_load_16 false - | Pstring_load_32 false - | Pstring_load_64 false - | Pbytes_load_16 false - | Pbytes_load_32 false - | Pbytes_load_64 false - | Pbigarrayref (false, _, _, _) - | Pbigstring_load_16 false - | Pbigstring_load_32 false - | Pbigstring_load_64 false -> - (* May trigger a bounds check exception. *) - Arbitrary_effects, Has_coeffects - | Psetfield _ - | Psetfield_computed _ - | Psetfloatfield _ - | Psetglobal _ - | Parraysetu _ - | Parraysets _ - | Pbytessetu - | Pbytessets - | Pbytes_set_16 _ - | Pbytes_set_32 _ - | Pbytes_set_64 _ - | Pbigarrayset _ - | Pbigstring_set_16 _ - | Pbigstring_set_32 _ - | Pbigstring_set_64 _ -> - (* Whether or not some of these are "unsafe" is irrelevant; they always - have an effect. *) - Arbitrary_effects, No_coeffects - | Pctconst _ -> No_effects, No_coeffects - | Pbswap16 - | Pbbswap _ -> No_effects, No_coeffects - | Pint_as_pointer -> No_effects, No_coeffects - | Popaque -> Arbitrary_effects, Has_coeffects - | Prevapply - | Pdirapply -> - (* Removed by [Simplif], but there is no reason to prevent using - the current analysis function before/during Simplif. *) - Arbitrary_effects, Has_coeffects - | Psequand - | Psequor -> - (* Removed by [Closure_conversion] in the flambda pipeline. *) - No_effects, No_coeffects - -type return_type = - | Float - | Other - -let return_type_of_primitive (prim:Lambda.primitive) = - match prim with - | Pfloatofint - | Pnegfloat - | Pabsfloat - | Paddfloat - | Psubfloat - | Pmulfloat - | Pdivfloat - | Pfloatfield _ - | Parrayrefu Pfloatarray - | Parrayrefs Pfloatarray -> - Float - | _ -> - Other diff --git a/bytecomp/semantics_of_primitives.mli b/bytecomp/semantics_of_primitives.mli deleted file mode 100644 index c0c2b9aa..00000000 --- a/bytecomp/semantics_of_primitives.mli +++ /dev/null @@ -1,69 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Description of the semantics of primitives, to be used for optimization - purposes. - - "No effects" means that the primitive does not change the observable state - of the world. For example, it must not write to any mutable storage, - call arbitrary external functions or change control flow (e.g. by raising - an exception). Note that allocation is not "No effects" (see below). - - It is assumed in the compiler that applications of primitives with no - effects, whose results are not used, may be eliminated. It is further - assumed that applications of primitives with no effects may be - duplicated (and thus possibly executed more than once). - - (Exceptions arising from allocation points, for example "out of memory" or - exceptions propagated from finalizers or signal handlers, are treated as - "effects out of the ether" and thus ignored for our determination here - of effectfulness. The same goes for floating point operations that may - cause hardware traps on some platforms.) - - "Only generative effects" means that a primitive does not change the - observable state of the world save for possibly affecting the state of - the garbage collector by performing an allocation. Applications of - primitives that only have generative effects and whose results are unused - may be eliminated by the compiler. However, unlike "No effects" - primitives, such applications will never be eligible for duplication. - - "Arbitrary effects" covers all other primitives. - - "No coeffects" means that the primitive does not observe the effects (in - the sense described above) of other expressions. For example, it must not - read from any mutable storage or call arbitrary external functions. - - It is assumed in the compiler that, subject to data dependencies, - expressions with neither effects nor coeffects may be reordered with - respect to other expressions. -*) - -type effects = No_effects | Only_generative_effects | Arbitrary_effects -type coeffects = No_coeffects | Has_coeffects - -(** Describe the semantics of a primitive. This does not take into account of - the (non-)(co)effectfulness of the arguments in a primitive application. - To determine whether such an application is (co)effectful, the arguments - must also be analysed. *) -val for_primitive: Lambda.primitive -> effects * coeffects - -type return_type = - | Float - | Other - -val return_type_of_primitive: Lambda.primitive -> return_type diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml deleted file mode 100644 index 9e1eb926..00000000 --- a/bytecomp/simplif.ml +++ /dev/null @@ -1,848 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Elimination of useless Llet(Alias) bindings. - Also transform let-bound references into variables. *) - -open Asttypes -open Lambda - -(* To transform let-bound references into variables *) - -exception Real_reference - -let rec eliminate_ref id = function - Lvar v as lam -> - if Ident.same v id then raise Real_reference else lam - | Lconst _ as lam -> lam - | Lapply ap -> - Lapply{ap with ap_func = eliminate_ref id ap.ap_func; - ap_args = List.map (eliminate_ref id) ap.ap_args} - | Lfunction _ as lam -> - if Ident.Set.mem id (free_variables lam) - then raise Real_reference - else lam - | Llet(str, kind, v, e1, e2) -> - Llet(str, kind, v, eliminate_ref id e1, eliminate_ref id e2) - | Lletrec(idel, e2) -> - Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel, - eliminate_ref id e2) - | Lprim(Pfield 0, [Lvar v], _) when Ident.same v id -> - Lvar id - | Lprim(Psetfield(0, _, _), [Lvar v; e], _) when Ident.same v id -> - Lassign(id, eliminate_ref id e) - | Lprim(Poffsetref delta, [Lvar v], loc) when Ident.same v id -> - Lassign(id, Lprim(Poffsetint delta, [Lvar id], loc)) - | Lprim(p, el, loc) -> - Lprim(p, List.map (eliminate_ref id) el, loc) - | Lswitch(e, sw, loc) -> - Lswitch(eliminate_ref id e, - {sw_numconsts = sw.sw_numconsts; - sw_consts = - List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_consts; - sw_numblocks = sw.sw_numblocks; - sw_blocks = - List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks; - sw_failaction = - Misc.may_map (eliminate_ref id) sw.sw_failaction; }, - loc) - | Lstringswitch(e, sw, default, loc) -> - Lstringswitch - (eliminate_ref id e, - List.map (fun (s, e) -> (s, eliminate_ref id e)) sw, - Misc.may_map (eliminate_ref id) default, loc) - | Lstaticraise (i,args) -> - Lstaticraise (i,List.map (eliminate_ref id) args) - | Lstaticcatch(e1, i, e2) -> - Lstaticcatch(eliminate_ref id e1, i, eliminate_ref id e2) - | Ltrywith(e1, v, e2) -> - Ltrywith(eliminate_ref id e1, v, eliminate_ref id e2) - | Lifthenelse(e1, e2, e3) -> - Lifthenelse(eliminate_ref id e1, - eliminate_ref id e2, - eliminate_ref id e3) - | Lsequence(e1, e2) -> - Lsequence(eliminate_ref id e1, eliminate_ref id e2) - | Lwhile(e1, e2) -> - Lwhile(eliminate_ref id e1, eliminate_ref id e2) - | Lfor(v, e1, e2, dir, e3) -> - Lfor(v, eliminate_ref id e1, eliminate_ref id e2, - dir, eliminate_ref id e3) - | Lassign(v, e) -> - Lassign(v, eliminate_ref id e) - | Lsend(k, m, o, el, loc) -> - Lsend(k, eliminate_ref id m, eliminate_ref id o, - List.map (eliminate_ref id) el, loc) - | Levent(l, ev) -> - Levent(eliminate_ref id l, ev) - | Lifused(v, e) -> - Lifused(v, eliminate_ref id e) - -(* Simplification of exits *) - -type exit = { - mutable count: int; - mutable max_depth: int; -} - -let simplify_exits lam = - - (* Count occurrences of (exit n ...) statements *) - let exits = Hashtbl.create 17 in - - let try_depth = ref 0 in - - let get_exit i = - try Hashtbl.find exits i - with Not_found -> {count = 0; max_depth = 0} - - and incr_exit i nb d = - match Hashtbl.find_opt exits i with - | Some r -> - r.count <- r.count + nb; - r.max_depth <- max r.max_depth d - | None -> - let r = {count = nb; max_depth = d} in - Hashtbl.add exits i r - in - - let rec count = function - | (Lvar _| Lconst _) -> () - | Lapply ap -> count ap.ap_func; List.iter count ap.ap_args - | Lfunction {body} -> count body - | Llet(_str, _kind, _v, l1, l2) -> - count l2; count l1 - | Lletrec(bindings, body) -> - List.iter (fun (_v, l) -> count l) bindings; - count body - | Lprim(_p, ll, _) -> List.iter count ll - | Lswitch(l, sw, _loc) -> - count_default sw ; - count l; - List.iter (fun (_, l) -> count l) sw.sw_consts; - List.iter (fun (_, l) -> count l) sw.sw_blocks - | Lstringswitch(l, sw, d, _) -> - count l; - List.iter (fun (_, l) -> count l) sw; - begin match d with - | None -> () - | Some d -> match sw with - | []|[_] -> count d - | _ -> count d; count d (* default will get replicated *) - end - | Lstaticraise (i,ls) -> incr_exit i 1 !try_depth; List.iter count ls - | Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) -> - (* i will be replaced by j in l1, so each occurrence of i in l1 - increases j's ref count *) - count l1 ; - let ic = get_exit i in - incr_exit j ic.count (max !try_depth ic.max_depth) - | Lstaticcatch(l1, (i,_), l2) -> - count l1; - (* If l1 does not contain (exit i), - l2 will be removed, so don't count its exits *) - if (get_exit i).count > 0 then - count l2 - | Ltrywith(l1, _v, l2) -> incr try_depth; count l1; decr try_depth; count l2 - | Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3 - | Lsequence(l1, l2) -> count l1; count l2 - | Lwhile(l1, l2) -> count l1; count l2 - | Lfor(_, l1, l2, _dir, l3) -> count l1; count l2; count l3 - | Lassign(_v, l) -> count l - | Lsend(_k, m, o, ll, _) -> List.iter count (m::o::ll) - | Levent(l, _) -> count l - | Lifused(_v, l) -> count l - - and count_default sw = match sw.sw_failaction with - | None -> () - | Some al -> - let nconsts = List.length sw.sw_consts - and nblocks = List.length sw.sw_blocks in - if - nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks - then begin (* default action will occur twice in native code *) - count al ; count al - end else begin (* default action will occur once *) - assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ; - count al - end - in - count lam; - assert(!try_depth = 0); - - (* - Second pass simplify ``catch body with (i ...) handler'' - - if (exit i ...) does not occur in body, suppress catch - - if (exit i ...) occurs exactly once in body, - substitute it with handler - - If handler is a single variable, replace (exit i ..) with it - Note: - In ``catch body with (i x1 .. xn) handler'' - Substituted expression is - let y1 = x1 and ... yn = xn in - handler[x1 <- y1 ; ... ; xn <- yn] - For the sake of preserving the uniqueness of bound variables. - (No alpha conversion of ``handler'' is presently needed, since - substitution of several ``(exit i ...)'' - occurs only when ``handler'' is a variable.) - *) - - let subst = Hashtbl.create 17 in - - let rec simplif = function - | (Lvar _|Lconst _) as l -> l - | Lapply ap -> - Lapply{ap with ap_func = simplif ap.ap_func; - ap_args = List.map simplif ap.ap_args} - | Lfunction{kind; params; return; body = l; attr; loc} -> - Lfunction{kind; params; return; body = simplif l; attr; loc} - | Llet(str, kind, v, l1, l2) -> Llet(str, kind, v, simplif l1, simplif l2) - | Lletrec(bindings, body) -> - Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) - | Lprim(p, ll, loc) -> begin - let ll = List.map simplif ll in - match p, ll with - (* Simplify %revapply, for n-ary functions with n > 1 *) - | Prevapply, [x; Lapply ap] - | Prevapply, [x; Levent (Lapply ap,_)] -> - Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc} - | Prevapply, [x; f] -> Lapply {ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=f; - ap_args=[x]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} - - (* Simplify %apply, for n-ary functions with n > 1 *) - | Pdirapply, [Lapply ap; x] - | Pdirapply, [Levent (Lapply ap,_); x] -> - Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc} - | Pdirapply, [f; x] -> Lapply {ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=f; - ap_args=[x]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} - - | _ -> Lprim(p, ll, loc) - end - | Lswitch(l, sw, loc) -> - let new_l = simplif l - and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts - and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks - and new_fail = Misc.may_map simplif sw.sw_failaction in - Lswitch - (new_l, - {sw with sw_consts = new_consts ; sw_blocks = new_blocks; - sw_failaction = new_fail}, - loc) - | Lstringswitch(l,sw,d,loc) -> - Lstringswitch - (simplif l,List.map (fun (s,l) -> s,simplif l) sw, - Misc.may_map simplif d,loc) - | Lstaticraise (i,[]) as l -> - begin try - let _,handler = Hashtbl.find subst i in - handler - with - | Not_found -> l - end - | Lstaticraise (i,ls) -> - let ls = List.map simplif ls in - begin try - let xs,handler = Hashtbl.find subst i in - let ys = List.map (fun (x, k) -> Ident.rename x, k) xs in - let env = - List.fold_right2 - (fun (x, _) (y, _) env -> Ident.Map.add x y env) - xs ys Ident.Map.empty - in - List.fold_right2 - (fun (y, kind) l r -> Llet (Strict, kind, y, l, r)) - ys ls (Lambda.rename env handler) - with - | Not_found -> Lstaticraise (i,ls) - end - | Lstaticcatch (l1,(i,[]),(Lstaticraise (_j,[]) as l2)) -> - Hashtbl.add subst i ([],simplif l2) ; - simplif l1 - | Lstaticcatch (l1,(i,xs),l2) -> - let {count; max_depth} = get_exit i in - if count = 0 then - (* Discard staticcatch: not matching exit *) - simplif l1 - else if count = 1 && max_depth <= !try_depth then begin - (* Inline handler if there is a single occurrence and it is not - nested within an inner try..with *) - assert(max_depth = !try_depth); - Hashtbl.add subst i (xs,simplif l2); - simplif l1 - end else - Lstaticcatch (simplif l1, (i,xs), simplif l2) - | Ltrywith(l1, v, l2) -> - incr try_depth; - let l1 = simplif l1 in - decr try_depth; - Ltrywith(l1, v, simplif l2) - | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3) - | Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2) - | Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2) - | Lfor(v, l1, l2, dir, l3) -> - Lfor(v, simplif l1, simplif l2, dir, simplif l3) - | Lassign(v, l) -> Lassign(v, simplif l) - | Lsend(k, m, o, ll, loc) -> - Lsend(k, simplif m, simplif o, List.map simplif ll, loc) - | Levent(l, ev) -> Levent(simplif l, ev) - | Lifused(v, l) -> Lifused (v,simplif l) - in - simplif lam - -(* Compile-time beta-reduction of functions immediately applied: - Lapply(Lfunction(Curried, params, body), args, loc) -> - let paramN = argN in ... let param1 = arg1 in body - Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock(args))], loc) -> - let paramN = argN in ... let param1 = arg1 in body - Assumes |args| = |params|. -*) - -let beta_reduce params body args = - List.fold_left2 (fun l (param, kind) arg -> Llet(Strict, kind, param, arg, l)) - body params args - -(* Simplification of lets *) - -let simplify_lets lam = - - (* Disable optimisations for bytecode compilation with -g flag *) - let optimize = !Clflags.native_code || not !Clflags.debug in - - (* First pass: count the occurrences of all let-bound identifiers *) - - let occ = (Hashtbl.create 83: (Ident.t, int ref) Hashtbl.t) in - (* The global table [occ] associates to each let-bound identifier - the number of its uses (as a reference): - - 0 if never used - - 1 if used exactly once in and not under a lambda or within a loop - - > 1 if used several times or under a lambda or within a loop. - The local table [bv] associates to each locally-let-bound variable - its reference count, as above. [bv] is enriched at let bindings - but emptied when crossing lambdas and loops. *) - - (* Current use count of a variable. *) - let count_var v = - try - !(Hashtbl.find occ v) - with Not_found -> - 0 - - (* Entering a [let]. Returns updated [bv]. *) - and bind_var bv v = - let r = ref 0 in - Hashtbl.add occ v r; - Ident.Map.add v r bv - - (* Record a use of a variable *) - and use_var bv v n = - try - let r = Ident.Map.find v bv in r := !r + n - with Not_found -> - (* v is not locally bound, therefore this is a use under a lambda - or within a loop. Increase use count by 2 -- enough so - that single-use optimizations will not apply. *) - try - let r = Hashtbl.find occ v in r := !r + 2 - with Not_found -> - (* Not a let-bound variable, ignore *) - () in - - let rec count bv = function - | Lconst _ -> () - | Lvar v -> - use_var bv v 1 - | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args} - when optimize && List.length params = List.length args -> - count bv (beta_reduce params body args) - | Lapply{ap_func = Lfunction{kind = Tupled; params; body}; - ap_args = [Lprim(Pmakeblock _, args, _)]} - when optimize && List.length params = List.length args -> - count bv (beta_reduce params body args) - | Lapply{ap_func = l1; ap_args = ll} -> - count bv l1; List.iter (count bv) ll - | Lfunction {body} -> - count Ident.Map.empty body - | Llet(_str, _k, v, Lvar w, l2) when optimize -> - (* v will be replaced by w in l2, so each occurrence of v in l2 - increases w's refcount *) - count (bind_var bv v) l2; - use_var bv w (count_var v) - | Llet(str, _kind, v, l1, l2) -> - count (bind_var bv v) l2; - (* If v is unused, l1 will be removed, so don't count its variables *) - if str = Strict || count_var v > 0 then count bv l1 - | Lletrec(bindings, body) -> - List.iter (fun (_v, l) -> count bv l) bindings; - count bv body - | Lprim(_p, ll, _) -> List.iter (count bv) ll - | Lswitch(l, sw, _loc) -> - count_default bv sw ; - count bv l; - List.iter (fun (_, l) -> count bv l) sw.sw_consts; - List.iter (fun (_, l) -> count bv l) sw.sw_blocks - | Lstringswitch(l, sw, d, _) -> - count bv l ; - List.iter (fun (_, l) -> count bv l) sw ; - begin match d with - | Some d -> - begin match sw with - | []|[_] -> count bv d - | _ -> count bv d ; count bv d - end - | None -> () - end - | Lstaticraise (_i,ls) -> List.iter (count bv) ls - | Lstaticcatch(l1, _, l2) -> count bv l1; count bv l2 - | Ltrywith(l1, _v, l2) -> count bv l1; count bv l2 - | Lifthenelse(l1, l2, l3) -> count bv l1; count bv l2; count bv l3 - | Lsequence(l1, l2) -> count bv l1; count bv l2 - | Lwhile(l1, l2) -> count Ident.Map.empty l1; count Ident.Map.empty l2 - | Lfor(_, l1, l2, _dir, l3) -> - count bv l1; count bv l2; count Ident.Map.empty l3 - | Lassign(_v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refcount *) - count bv l - | Lsend(_, m, o, ll, _) -> List.iter (count bv) (m::o::ll) - | Levent(l, _) -> count bv l - | Lifused(v, l) -> - if count_var v > 0 then count bv l - - and count_default bv sw = match sw.sw_failaction with - | None -> () - | Some al -> - let nconsts = List.length sw.sw_consts - and nblocks = List.length sw.sw_blocks in - if - nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks - then begin (* default action will occur twice in native code *) - count bv al ; count bv al - end else begin (* default action will occur once *) - assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ; - count bv al - end - in - count Ident.Map.empty lam; - - (* Second pass: remove Lalias bindings of unused variables, - and substitute the bindings of variables used exactly once. *) - - let subst = Hashtbl.create 83 in - -(* This (small) optimisation is always legal, it may uncover some - tail call later on. *) - - let mklet str kind v e1 e2 = match e2 with - | Lvar w when optimize && Ident.same v w -> e1 - | _ -> Llet (str, kind,v,e1,e2) in - - - let rec simplif = function - Lvar v as l -> - begin try - Hashtbl.find subst v - with Not_found -> - l - end - | Lconst _ as l -> l - | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args} - when optimize && List.length params = List.length args -> - simplif (beta_reduce params body args) - | Lapply{ap_func = Lfunction{kind = Tupled; params; body}; - ap_args = [Lprim(Pmakeblock _, args, _)]} - when optimize && List.length params = List.length args -> - simplif (beta_reduce params body args) - | Lapply ap -> Lapply {ap with ap_func = simplif ap.ap_func; - ap_args = List.map simplif ap.ap_args} - | Lfunction{kind; params; return=return1; body = l; attr; loc} -> - begin match simplif l with - Lfunction{kind=Curried; params=params'; return=return2; body; attr; loc} - when kind = Curried && optimize -> - (* The return type is the type of the value returned after - applying all the parameters to the function. The return - type of the merged function taking [params @ params'] as - parameters is the type returned after applying [params']. *) - let return = return2 in - Lfunction{kind; params = params @ params'; return; body; attr; loc} - | body -> - Lfunction{kind; params; return = return1; body; attr; loc} - end - | Llet(_str, _k, v, Lvar w, l2) when optimize -> - Hashtbl.add subst v (simplif (Lvar w)); - simplif l2 - | Llet(Strict, kind, v, - Lprim(Pmakeblock(0, Mutable, kind_ref) as prim, [linit], loc), lbody) - when optimize -> - let slinit = simplif linit in - let slbody = simplif lbody in - begin try - let kind = match kind_ref with - | None -> Pgenval - | Some [field_kind] -> field_kind - | Some _ -> assert false - in - mklet Variable kind v slinit (eliminate_ref v slbody) - with Real_reference -> - mklet Strict kind v (Lprim(prim, [slinit], loc)) slbody - end - | Llet(Alias, kind, v, l1, l2) -> - begin match count_var v with - 0 -> simplif l2 - | 1 when optimize -> Hashtbl.add subst v (simplif l1); simplif l2 - | _ -> Llet(Alias, kind, v, simplif l1, simplif l2) - end - | Llet(StrictOpt, kind, v, l1, l2) -> - begin match count_var v with - 0 -> simplif l2 - | _ -> mklet StrictOpt kind v (simplif l1) (simplif l2) - end - | Llet(str, kind, v, l1, l2) -> mklet str kind v (simplif l1) (simplif l2) - | Lletrec(bindings, body) -> - Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) - | Lprim(p, ll, loc) -> Lprim(p, List.map simplif ll, loc) - | Lswitch(l, sw, loc) -> - let new_l = simplif l - and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts - and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks - and new_fail = Misc.may_map simplif sw.sw_failaction in - Lswitch - (new_l, - {sw with sw_consts = new_consts ; sw_blocks = new_blocks; - sw_failaction = new_fail}, - loc) - | Lstringswitch (l,sw,d,loc) -> - Lstringswitch - (simplif l,List.map (fun (s,l) -> s,simplif l) sw, - Misc.may_map simplif d,loc) - | Lstaticraise (i,ls) -> - Lstaticraise (i, List.map simplif ls) - | Lstaticcatch(l1, (i,args), l2) -> - Lstaticcatch (simplif l1, (i,args), simplif l2) - | Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2) - | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3) - | Lsequence(Lifused(v, l1), l2) -> - if count_var v > 0 - then Lsequence(simplif l1, simplif l2) - else simplif l2 - | Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2) - | Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2) - | Lfor(v, l1, l2, dir, l3) -> - Lfor(v, simplif l1, simplif l2, dir, simplif l3) - | Lassign(v, l) -> Lassign(v, simplif l) - | Lsend(k, m, o, ll, loc) -> - Lsend(k, simplif m, simplif o, List.map simplif ll, loc) - | Levent(l, ev) -> Levent(simplif l, ev) - | Lifused(v, l) -> - if count_var v > 0 then simplif l else lambda_unit - in - simplif lam - -(* Tail call info in annotation files *) - -let is_tail_native_heuristic : (int -> bool) ref = - ref (fun _ -> true) - -let rec emit_tail_infos is_tail lambda = - let call_kind args = - if is_tail - && ((not !Clflags.native_code) - || (!is_tail_native_heuristic (List.length args))) - then Annot.Tail - else Annot.Stack in - match lambda with - | Lvar _ -> () - | Lconst _ -> () - | Lapply ap -> - if ap.ap_should_be_tailcall - && not is_tail - && Warnings.is_active Warnings.Expect_tailcall - then Location.prerr_warning ap.ap_loc Warnings.Expect_tailcall; - emit_tail_infos false ap.ap_func; - list_emit_tail_infos false ap.ap_args; - if !Clflags.annotations then - Stypes.record (Stypes.An_call (ap.ap_loc, call_kind ap.ap_args)) - | Lfunction {body = lam} -> - emit_tail_infos true lam - | Llet (_str, _k, _, lam, body) -> - emit_tail_infos false lam; - emit_tail_infos is_tail body - | Lletrec (bindings, body) -> - List.iter (fun (_, lam) -> emit_tail_infos false lam) bindings; - emit_tail_infos is_tail body - | Lprim (Pidentity, [arg], _) -> - emit_tail_infos is_tail arg - | Lprim ((Pbytes_to_string | Pbytes_of_string), [arg], _) -> - emit_tail_infos is_tail arg - | Lprim (Psequand, [arg1; arg2], _) - | Lprim (Psequor, [arg1; arg2], _) -> - emit_tail_infos false arg1; - emit_tail_infos is_tail arg2 - | Lprim (_, l, _) -> - list_emit_tail_infos false l - | Lswitch (lam, sw, _loc) -> - emit_tail_infos false lam; - list_emit_tail_infos_fun snd is_tail sw.sw_consts; - list_emit_tail_infos_fun snd is_tail sw.sw_blocks; - Misc.may (emit_tail_infos is_tail) sw.sw_failaction - | Lstringswitch (lam, sw, d, _) -> - emit_tail_infos false lam; - List.iter - (fun (_,lam) -> emit_tail_infos is_tail lam) - sw ; - Misc.may (emit_tail_infos is_tail) d - | Lstaticraise (_, l) -> - list_emit_tail_infos false l - | Lstaticcatch (body, _, handler) -> - emit_tail_infos is_tail body; - emit_tail_infos is_tail handler - | Ltrywith (body, _, handler) -> - emit_tail_infos false body; - emit_tail_infos is_tail handler - | Lifthenelse (cond, ifso, ifno) -> - emit_tail_infos false cond; - emit_tail_infos is_tail ifso; - emit_tail_infos is_tail ifno - | Lsequence (lam1, lam2) -> - emit_tail_infos false lam1; - emit_tail_infos is_tail lam2 - | Lwhile (cond, body) -> - emit_tail_infos false cond; - emit_tail_infos false body - | Lfor (_, low, high, _, body) -> - emit_tail_infos false low; - emit_tail_infos false high; - emit_tail_infos false body - | Lassign (_, lam) -> - emit_tail_infos false lam - | Lsend (_, meth, obj, args, loc) -> - emit_tail_infos false meth; - emit_tail_infos false obj; - list_emit_tail_infos false args; - if !Clflags.annotations then - Stypes.record (Stypes.An_call (loc, call_kind (obj :: args))); - | Levent (lam, _) -> - emit_tail_infos is_tail lam - | Lifused (_, lam) -> - emit_tail_infos is_tail lam -and list_emit_tail_infos_fun f is_tail = - List.iter (fun x -> emit_tail_infos is_tail (f x)) -and list_emit_tail_infos is_tail = - List.iter (emit_tail_infos is_tail) - -(* Split a function with default parameters into a wrapper and an - inner function. The wrapper fills in missing optional parameters - with their default value and tail-calls the inner function. The - wrapper can then hopefully be inlined on most call sites to avoid - the overhead associated with boxing an optional argument with a - 'Some' constructor, only to deconstruct it immediately in the - function's body. *) - -let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ~attr ~loc = - let rec aux map = function - | Llet(Strict, k, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when - Ident.name optparam = "*opt*" && List.mem_assoc optparam params - && not (List.mem_assoc optparam map) - -> - let wrapper_body, inner = aux ((optparam, id) :: map) rest in - Llet(Strict, k, id, def, wrapper_body), inner - | _ when map = [] -> raise Exit - | body -> - (* Check that those *opt* identifiers don't appear in the remaining - body. This should not appear, but let's be on the safe side. *) - let fv = Lambda.free_variables body in - List.iter (fun (id, _) -> if Ident.Set.mem id fv then raise Exit) map; - - let inner_id = Ident.create_local (Ident.name fun_id ^ "_inner") in - let map_param p = try List.assoc p map with Not_found -> p in - let args = List.map (fun (p, _) -> Lvar (map_param p)) params in - let wrapper_body = - Lapply { - ap_func = Lvar inner_id; - ap_args = args; - ap_loc = Location.none; - ap_should_be_tailcall = false; - ap_inlined = Default_inline; - ap_specialised = Default_specialise; - } - in - let inner_params = List.map map_param (List.map fst params) in - let new_ids = List.map Ident.rename inner_params in - let subst = - List.fold_left2 (fun s id new_id -> - Ident.Map.add id new_id s - ) Ident.Map.empty inner_params new_ids - in - let body = Lambda.rename subst body in - let inner_fun = - Lfunction { kind = Curried; - params = List.map (fun id -> id, Pgenval) new_ids; - return; body; attr; loc; } - in - (wrapper_body, (inner_id, inner_fun)) - in - try - let body, inner = aux [] body in - let attr = default_stub_attribute in - [(fun_id, Lfunction{kind; params; return; body; attr; loc}); inner] - with Exit -> - [(fun_id, Lfunction{kind; params; return; body; attr; loc})] - -module Hooks = Misc.MakeHooks(struct - type t = lambda - end) - -(* Simplify local let-bound functions: if all occurrences are - fully-applied function calls in the same "tail scope", replace the - function by a staticcatch handler (on that scope). - - This handles as a special case functions used exactly once (in any - scope) for a full application. -*) - -type slot = - { - nargs: int; - mutable scope: lambda option; - } - -module LamTbl = Hashtbl.Make(struct - type t = lambda - let equal = (==) - let hash = Hashtbl.hash - end) - -let simplify_local_functions lam = - let slots = Hashtbl.create 16 in - let static_id = Hashtbl.create 16 in (* function id -> static id *) - let static = LamTbl.create 16 in (* scope -> static function on that scope *) - (* We keep track of the current "tail scope", identified - by the outermost lambda for which the the current lambda - is in tail position. *) - let current_scope = ref lam in - let check_static lf = - if lf.attr.local = Always_local then - Location.prerr_warning lf.loc - (Warnings.Inlining_impossible - "This function cannot be compiled into a static continuation") - in - let enabled = function - | {local = Always_local; _} - | {local = Default_local; inline = (Never_inline | Default_inline); _} - -> true - | {local = Default_local; inline = (Always_inline | Unroll _); _} - | {local = Never_local; _} - -> false - in - let rec tail = function - | Llet (_str, _kind, id, Lfunction lf, cont) - when Lambda.function_is_curried lf && enabled lf.attr -> - let r = {nargs=List.length lf.params; scope=None} in - Hashtbl.add slots id r; - tail cont; - begin match Hashtbl.find_opt slots id with - | Some {scope = Some scope; _} -> - let st = next_raise_count () in - let sc = - (* Do not move higher than current lambda *) - if scope == !current_scope then cont - else scope - in - Hashtbl.add static_id id st; - LamTbl.add static sc (st, lf); - (* The body of the function will become an handler - in that "scope". *) - with_scope ~scope lf.body - | _ -> - check_static lf; - (* note: if scope = None, the function is unused *) - non_tail lf.body - end - | Lapply {ap_func = Lvar id; ap_args; _} -> - begin match Hashtbl.find_opt slots id with - | Some {nargs; _} when nargs <> List.length ap_args -> - (* Wrong arity *) - Hashtbl.remove slots id - | Some {scope = Some scope; _} when scope != !current_scope -> - (* Different "tail scope" *) - Hashtbl.remove slots id - | Some ({scope = None; _} as slot) -> - (* First use of the function: remember the current tail scope *) - slot.scope <- Some !current_scope - | _ -> - () - end; - List.iter non_tail ap_args - | Lvar id -> - Hashtbl.remove slots id - | Lfunction lf as lam -> - check_static lf; - Lambda.shallow_iter ~tail ~non_tail lam - | lam -> - Lambda.shallow_iter ~tail ~non_tail lam - and non_tail lam = - with_scope ~scope:lam lam - and with_scope ~scope lam = - let old_scope = !current_scope in - current_scope := scope; - tail lam; - current_scope := old_scope - in - tail lam; - let rec rewrite lam0 = - let lam = - match lam0 with - | Llet (_, _, id, _, cont) when Hashtbl.mem static_id id -> - rewrite cont - | Lapply {ap_func = Lvar id; ap_args; _} when Hashtbl.mem static_id id -> - Lstaticraise (Hashtbl.find static_id id, List.map rewrite ap_args) - | lam -> - Lambda.shallow_map rewrite lam - in - List.fold_right - (fun (st, lf) lam -> - Lstaticcatch (lam, (st, lf.params), rewrite lf.body) - ) - (LamTbl.find_all static lam0) - lam - in - if LamTbl.length static = 0 then - lam - else - rewrite lam - -(* The entry point: - simplification + emission of tailcall annotations, if needed. *) - -let simplify_lambda sourcefile lam = - let lam = - lam - |> (if !Clflags.native_code || not !Clflags.debug - then simplify_local_functions else Fun.id - ) - |> simplify_exits - |> simplify_lets - |> Hooks.apply_hooks { Misc.sourcefile } - in - if !Clflags.annotations || Warnings.is_active Warnings.Expect_tailcall - then emit_tail_infos true lam; - lam diff --git a/bytecomp/simplif.mli b/bytecomp/simplif.mli deleted file mode 100644 index daa2f708..00000000 --- a/bytecomp/simplif.mli +++ /dev/null @@ -1,46 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Lambda simplification and lambda plugin hooks - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -(* Elimination of useless Llet(Alias) bindings. - Transformation of let-bound references into variables. - Simplification over staticraise/staticcatch constructs. - Generation of tail-call annotations if -annot is set. *) - -open Lambda - -val simplify_lambda: string -> lambda -> lambda - -val split_default_wrapper - : id:Ident.t - -> kind:function_kind - -> params:(Ident.t * Lambda.value_kind) list - -> return:Lambda.value_kind - -> body:lambda - -> attr:function_attribute - -> loc:Location.t - -> (Ident.t * lambda) list - -(* To be filled by asmcomp/selectgen.ml *) -val is_tail_native_heuristic: (int -> bool) ref - (* # arguments -> can tailcall *) - -module Hooks : Misc.HookSig with type t = lambda diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml deleted file mode 100644 index 89bfe83a..00000000 --- a/bytecomp/switch.ml +++ /dev/null @@ -1,877 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - - -type 'a shared = Shared of 'a | Single of 'a - -type ('a, 'ctx) t_store = - {act_get : unit -> 'a array ; - act_get_shared : unit -> 'a shared array ; - act_store : 'ctx -> 'a -> int ; - act_store_shared : 'ctx -> 'a -> int ; } - -exception Not_simple - -module type Stored = sig - type t - type key - val compare_key : key -> key -> int - val make_key : t -> key option -end - -module type CtxStored = sig - include Stored - type context - val make_key : context -> t -> key option -end - -module CtxStore(A:CtxStored) = struct - module AMap = - Map.Make(struct type t = A.key let compare = A.compare_key end) - - type intern = - { mutable map : (bool * int) AMap.t ; - mutable next : int ; - mutable acts : (bool * A.t) list; } - - let mk_store () = - let st = - { map = AMap.empty ; - next = 0 ; - acts = [] ; } in - - let add mustshare act = - let i = st.next in - st.acts <- (mustshare,act) :: st.acts ; - st.next <- i+1 ; - i in - - let store mustshare ctx act = match A.make_key ctx act with - | Some key -> - begin try - let (shared,i) = AMap.find key st.map in - if not shared then st.map <- AMap.add key (true,i) st.map ; - i - with Not_found -> - let i = add mustshare act in - st.map <- AMap.add key (mustshare,i) st.map ; - i - end - | None -> - add mustshare act - - and get () = Array.of_list (List.rev_map (fun (_,act) -> act) st.acts) - - and get_shared () = - let acts = - Array.of_list - (List.rev_map - (fun (shared,act) -> - if shared then Shared act else Single act) - st.acts) in - AMap.iter - (fun _ (shared,i) -> - if shared then match acts.(i) with - | Single act -> acts.(i) <- Shared act - | Shared _ -> ()) - st.map ; - acts in - {act_store = store false ; act_store_shared = store true ; - act_get = get; act_get_shared = get_shared; } -end - -module Store(A:Stored) = struct - module Me = - CtxStore - (struct - include A - type context = unit - let make_key () = A.make_key - end) - - let mk_store = Me.mk_store -end - - - -module type S = -sig - type primitive - val eqint : primitive - val neint : primitive - val leint : primitive - val ltint : primitive - val geint : primitive - val gtint : primitive - type act - - val bind : act -> (act -> act) -> act - val make_const : int -> act - val make_offset : act -> int -> act - val make_prim : primitive -> act list -> act - val make_isout : act -> act -> act - val make_isin : act -> act -> act - val make_if : act -> act -> act -> act - val make_switch : Location.t -> act -> int array -> act array -> act - val make_catch : act -> int * (act -> act) - val make_exit : int -> act -end - -(* The module will ``produce good code for the case statement'' *) -(* - Adaptation of - R.L. Berstein - ``Producing good code for the case statement'' - Software Practice and Experience, 15(10) (1985) - and - D.L. Spuler - ``Two-Way Comparison Search Trees, a Generalisation of Binary Search Trees - and Split Trees'' - ``Compiler Code Generation for Multiway Branch Statement as - a Static Search Problem'' - Technical Reports, James Cook University -*) -(* - Main adaptation is considering interval tests - (implemented as one addition + one unsigned test and branch) - which leads to exhaustive search for finding the optimal - test sequence in small cases and heuristics otherwise. -*) -module Make (Arg : S) = -struct - - type 'a inter = - {cases : (int * int * int) array ; - actions : 'a array} - - type 'a t_ctx = {off : int ; arg : 'a} - - let cut = ref 8 - and more_cut = ref 16 - -(* -let pint chan i = - if i = min_int then Printf.fprintf chan "-oo" - else if i=max_int then Printf.fprintf chan "oo" - else Printf.fprintf chan "%d" i - -let pcases chan cases = - for i =0 to Array.length cases-1 do - let l,h,act = cases.(i) in - if l=h then - Printf.fprintf chan "%d:%d " l act - else - Printf.fprintf chan "%a..%a:%d " pint l pint h act - done - -let prerr_inter i = Printf.fprintf stderr - "cases=%a" pcases i.cases -*) - - let get_act cases i = - let _,_,r = cases.(i) in - r - and get_low cases i = - let r,_,_ = cases.(i) in - r - - type ctests = { - mutable n : int ; - mutable ni : int ; - } - - let too_much = {n=max_int ; ni=max_int} - -(* -let ptests chan {n=n ; ni=ni} = - Printf.fprintf chan "{n=%d ; ni=%d}" n ni - -let pta chan t = - for i =0 to Array.length t-1 do - Printf.fprintf chan "%d: %a\n" i ptests t.(i) - done -*) - - let less_tests c1 c2 = - if c1.n < c2.n then - true - else if c1.n = c2.n then begin - if c1.ni < c2.ni then - true - else - false - end else - false - - and eq_tests c1 c2 = c1.n = c2.n && c1.ni=c2.ni - - let less2tests (c1,d1) (c2,d2) = - if eq_tests c1 c2 then - less_tests d1 d2 - else - less_tests c1 c2 - - let add_test t1 t2 = - t1.n <- t1.n + t2.n ; - t1.ni <- t1.ni + t2.ni ; - - type t_ret = Inter of int * int | Sep of int | No - -(* -let pret chan = function - | Inter (i,j)-> Printf.fprintf chan "Inter %d %d" i j - | Sep i -> Printf.fprintf chan "Sep %d" i - | No -> Printf.fprintf chan "No" -*) - - let coupe cases i = - let l,_,_ = cases.(i) in - l, - Array.sub cases 0 i, - Array.sub cases i (Array.length cases-i) - - - let case_append c1 c2 = - let len1 = Array.length c1 - and len2 = Array.length c2 in - match len1,len2 with - | 0,_ -> c2 - | _,0 -> c1 - | _,_ -> - let l1,h1,act1 = c1.(Array.length c1-1) - and l2,h2,act2 = c2.(0) in - if act1 = act2 then - let r = Array.make (len1+len2-1) c1.(0) in - for i = 0 to len1-2 do - r.(i) <- c1.(i) - done ; - - let l = - if len1-2 >= 0 then begin - let _,h,_ = r.(len1-2) in - if h+1 < l1 then - h+1 - else - l1 - end else - l1 - and h = - if 1 < len2-1 then begin - let l,_,_ = c2.(1) in - if h2+1 < l then - l-1 - else - h2 - end else - h2 in - r.(len1-1) <- (l,h,act1) ; - for i=1 to len2-1 do - r.(len1-1+i) <- c2.(i) - done ; - r - else if h1 > l1 then - let r = Array.make (len1+len2) c1.(0) in - for i = 0 to len1-2 do - r.(i) <- c1.(i) - done ; - r.(len1-1) <- (l1,l2-1,act1) ; - for i=0 to len2-1 do - r.(len1+i) <- c2.(i) - done ; - r - else if h2 > l2 then - let r = Array.make (len1+len2) c1.(0) in - for i = 0 to len1-1 do - r.(i) <- c1.(i) - done ; - r.(len1) <- (h1+1,h2,act2) ; - for i=1 to len2-1 do - r.(len1+i) <- c2.(i) - done ; - r - else - Array.append c1 c2 - - - let coupe_inter i j cases = - let lcases = Array.length cases in - let low,_,_ = cases.(i) - and _,high,_ = cases.(j) in - low,high, - Array.sub cases i (j-i+1), - case_append (Array.sub cases 0 i) (Array.sub cases (j+1) (lcases-(j+1))) - - type kind = Kvalue of int | Kinter of int | Kempty - -(* -let pkind chan = function - | Kvalue i ->Printf.fprintf chan "V%d" i - | Kinter i -> Printf.fprintf chan "I%d" i - | Kempty -> Printf.fprintf chan "E" - -let rec pkey chan = function - | [] -> () - | [k] -> pkind chan k - | k::rem -> - Printf.fprintf chan "%a %a" pkey rem pkind k -*) - - let t = Hashtbl.create 17 - - let make_key cases = - let seen = ref [] - and count = ref 0 in - let rec got_it act = function - | [] -> - seen := (act,!count):: !seen ; - let r = !count in - incr count ; - r - | (act0,index) :: rem -> - if act0 = act then - index - else - got_it act rem in - - let make_one l h act = - if l=h then - Kvalue (got_it act !seen) - else - Kinter (got_it act !seen) in - - let rec make_rec i pl = - if i < 0 then - [] - else - let l,h,act = cases.(i) in - if pl = h+1 then - make_one l h act::make_rec (i-1) l - else - Kempty::make_one l h act::make_rec (i-1) l in - - let l,h,act = cases.(Array.length cases-1) in - make_one l h act::make_rec (Array.length cases-2) l - - - let same_act t = - let len = Array.length t in - let a = get_act t (len-1) in - let rec do_rec i = - if i < 0 then true - else - let b = get_act t i in - b=a && do_rec (i-1) in - do_rec (len-2) - - -(* - Interval test x in [l,h] works by checking x-l in [0,h-l] - * This may be false for arithmetic modulo 2^31 - * Subtracting l may change the relative ordering of values - and invalid the invariant that matched values are given in - increasing order - - To avoid this, interval check is allowed only when the - integers indeed present in the whole case interval are - in [-2^16 ; 2^16] - - This condition is checked by zyva -*) - - let inter_limit = 1 lsl 16 - - let ok_inter = ref false - - let rec opt_count top cases = - let key = make_key cases in - try - Hashtbl.find t key - with - | Not_found -> - let r = - let lcases = Array.length cases in - match lcases with - | 0 -> assert false - | _ when same_act cases -> No, ({n=0; ni=0},{n=0; ni=0}) - | _ -> - if lcases < !cut then - enum top cases - else if lcases < !more_cut then - heuristic cases - else - divide cases in - Hashtbl.add t key r ; - r - - and divide cases = - let lcases = Array.length cases in - let m = lcases/2 in - let _,left,right = coupe cases m in - let ci = {n=1 ; ni=0} - and cm = {n=1 ; ni=0} - and _,(cml,cleft) = opt_count false left - and _,(cmr,cright) = opt_count false right in - add_test ci cleft ; - add_test ci cright ; - if less_tests cml cmr then - add_test cm cmr - else - add_test cm cml ; - Sep m,(cm, ci) - - and heuristic cases = - let lcases = Array.length cases in - - let sep,csep = divide cases - - and inter,cinter = - if !ok_inter then begin - let _,_,act0 = cases.(0) - and _,_,act1 = cases.(lcases-1) in - if act0 = act1 then begin - let low, high, inside, outside = coupe_inter 1 (lcases-2) cases in - let _,(cmi,cinside) = opt_count false inside - and _,(cmo,coutside) = opt_count false outside - and cmij = {n=1 ; ni=(if low=high then 0 else 1)} - and cij = {n=1 ; ni=(if low=high then 0 else 1)} in - add_test cij cinside ; - add_test cij coutside ; - if less_tests cmi cmo then - add_test cmij cmo - else - add_test cmij cmi ; - Inter (1,lcases-2),(cmij,cij) - end else - Inter (-1,-1),(too_much, too_much) - end else - Inter (-1,-1),(too_much, too_much) in - if less2tests csep cinter then - sep,csep - else - inter,cinter - - - and enum top cases = - let lcases = Array.length cases in - let lim, with_sep = - let best = ref (-1) and best_cost = ref (too_much,too_much) in - - for i = 1 to lcases-(1) do - let _,left,right = coupe cases i in - let ci = {n=1 ; ni=0} - and cm = {n=1 ; ni=0} - and _,(cml,cleft) = opt_count false left - and _,(cmr,cright) = opt_count false right in - add_test ci cleft ; - add_test ci cright ; - if less_tests cml cmr then - add_test cm cmr - else - add_test cm cml ; - - if - less2tests (cm,ci) !best_cost - then begin - if top then - Printf.fprintf stderr "Get it: %d\n" i ; - best := i ; - best_cost := (cm,ci) - end - done ; - !best, !best_cost in - - let ilow, ihigh, with_inter = - if not !ok_inter then - let rlow = ref (-1) and rhigh = ref (-1) - and best_cost= ref (too_much,too_much) in - for i=1 to lcases-2 do - let low, high, inside, outside = coupe_inter i i cases in - if low=high then begin - let _,(cmi,cinside) = opt_count false inside - and _,(cmo,coutside) = opt_count false outside - and cmij = {n=1 ; ni=0} - and cij = {n=1 ; ni=0} in - add_test cij cinside ; - add_test cij coutside ; - if less_tests cmi cmo then - add_test cmij cmo - else - add_test cmij cmi ; - if less2tests (cmij,cij) !best_cost then begin - rlow := i ; - rhigh := i ; - best_cost := (cmij,cij) - end - end - done ; - !rlow, !rhigh, !best_cost - else - let rlow = ref (-1) and rhigh = ref (-1) - and best_cost= ref (too_much,too_much) in - for i=1 to lcases-2 do - for j=i to lcases-2 do - let low, high, inside, outside = coupe_inter i j cases in - let _,(cmi,cinside) = opt_count false inside - and _,(cmo,coutside) = opt_count false outside - and cmij = {n=1 ; ni=(if low=high then 0 else 1)} - and cij = {n=1 ; ni=(if low=high then 0 else 1)} in - add_test cij cinside ; - add_test cij coutside ; - if less_tests cmi cmo then - add_test cmij cmo - else - add_test cmij cmi ; - if less2tests (cmij,cij) !best_cost then begin - rlow := i ; - rhigh := j ; - best_cost := (cmij,cij) - end - done - done ; - !rlow, !rhigh, !best_cost in - let r = ref (Inter (ilow,ihigh)) and rc = ref with_inter in - if less2tests with_sep !rc then begin - r := Sep lim ; rc := with_sep - end ; - !r, !rc - - let make_if_test test arg i ifso ifnot = - Arg.make_if - (Arg.make_prim test [arg ; Arg.make_const i]) - ifso ifnot - - let make_if_lt arg i ifso ifnot = match i with - | 1 -> - make_if_test Arg.leint arg 0 ifso ifnot - | _ -> - make_if_test Arg.ltint arg i ifso ifnot - - and make_if_ge arg i ifso ifnot = match i with - | 1 -> - make_if_test Arg.gtint arg 0 ifso ifnot - | _ -> - make_if_test Arg.geint arg i ifso ifnot - - and make_if_eq arg i ifso ifnot = - make_if_test Arg.eqint arg i ifso ifnot - - and make_if_ne arg i ifso ifnot = - make_if_test Arg.neint arg i ifso ifnot - - let do_make_if_out h arg ifso ifno = - Arg.make_if (Arg.make_isout h arg) ifso ifno - - let make_if_out ctx l d mk_ifso mk_ifno = match l with - | 0 -> - do_make_if_out - (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) - | _ -> - Arg.bind - (Arg.make_offset ctx.arg (-l)) - (fun arg -> - let ctx = {off= (-l+ctx.off) ; arg=arg} in - do_make_if_out - (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) - - let do_make_if_in h arg ifso ifno = - Arg.make_if (Arg.make_isin h arg) ifso ifno - - let make_if_in ctx l d mk_ifso mk_ifno = match l with - | 0 -> - do_make_if_in - (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) - | _ -> - Arg.bind - (Arg.make_offset ctx.arg (-l)) - (fun arg -> - let ctx = {off= (-l+ctx.off) ; arg=arg} in - do_make_if_in - (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) - - let rec c_test ctx ({cases=cases ; actions=actions} as s) = - let lcases = Array.length cases in - assert(lcases > 0) ; - if lcases = 1 then - actions.(get_act cases 0) ctx - - else begin - - let w,_c = opt_count false cases in -(* - Printf.fprintf stderr - "off=%d tactic=%a for %a\n" - ctx.off pret w pcases cases ; - *) - match w with - | No -> actions.(get_act cases 0) ctx - | Inter (i,j) -> - let low,high,inside, outside = coupe_inter i j cases in - let _,(cinside,_) = opt_count false inside - and _,(coutside,_) = opt_count false outside in - (* Costs are retrieved to put the code with more remaining tests - in the privileged (positive) branch of ``if'' *) - if low=high then begin - if less_tests coutside cinside then - make_if_eq - ctx.arg - (low+ctx.off) - (c_test ctx {s with cases=inside}) - (c_test ctx {s with cases=outside}) - else - make_if_ne - ctx.arg - (low+ctx.off) - (c_test ctx {s with cases=outside}) - (c_test ctx {s with cases=inside}) - end else begin - if less_tests coutside cinside then - make_if_in - ctx - (low+ctx.off) - (high-low) - (fun ctx -> c_test ctx {s with cases=inside}) - (fun ctx -> c_test ctx {s with cases=outside}) - else - make_if_out - ctx - (low+ctx.off) - (high-low) - (fun ctx -> c_test ctx {s with cases=outside}) - (fun ctx -> c_test ctx {s with cases=inside}) - end - | Sep i -> - let lim,left,right = coupe cases i in - let _,(cleft,_) = opt_count false left - and _,(cright,_) = opt_count false right in - let left = {s with cases=left} - and right = {s with cases=right} in - - if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then - make_if_ne - ctx.arg 0 - (c_test ctx right) (c_test ctx left) - else if less_tests cright cleft then - make_if_lt - ctx.arg (lim+ctx.off) - (c_test ctx left) (c_test ctx right) - else - make_if_ge - ctx.arg (lim+ctx.off) - (c_test ctx right) (c_test ctx left) - - end - - - (* Minimal density of switches *) - let theta = ref 0.33333 - - (* Minimal number of tests to make a switch *) - let switch_min = ref 3 - - (* Particular case 0, 1, 2 *) - let particular_case cases i j = - j-i = 2 && - (let l1,_h1,act1 = cases.(i) - and l2,_h2,_act2 = cases.(i+1) - and l3,h3,act3 = cases.(i+2) in - l1+1=l2 && l2+1=l3 && l3=h3 && - act1 <> act3) - - let approx_count cases i j = - let l = j-i+1 in - if l < !cut then - let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in - ntests - else - l-1 - - (* Sends back a boolean that says whether is switch is worth or not *) - - let dense {cases} i j = - if i=j then true - else - let l,_,_ = cases.(i) - and _,h,_ = cases.(j) in - let ntests = approx_count cases i j in -(* - (ntests+1) >= theta * (h-l+1) -*) - particular_case cases i j || - (ntests >= !switch_min && - float_of_int ntests +. 1.0 >= - !theta *. (float_of_int h -. float_of_int l +. 1.0)) - - (* Compute clusters by dynamic programming - Adaptation of the correction to Bernstein - ``Correction to `Producing Good Code for the Case Statement' '' - S.K. Kannan and T.A. Proebsting - Software Practice and Experience Vol. 24(2) 233 (Feb 1994) - *) - - let comp_clusters s = - let len = Array.length s.cases in - let min_clusters = Array.make len max_int - and k = Array.make len 0 in - let get_min i = if i < 0 then 0 else min_clusters.(i) in - - for i = 0 to len-1 do - for j = 0 to i do - if - dense s j i && - get_min (j-1) + 1 < min_clusters.(i) - then begin - k.(i) <- j ; - min_clusters.(i) <- get_min (j-1) + 1 - end - done ; - done ; - min_clusters.(len-1),k - - (* Assume j > i *) - let make_switch loc {cases=cases ; actions=actions} i j = - let ll,_,_ = cases.(i) - and _,hh,_ = cases.(j) in - let tbl = Array.make (hh-ll+1) 0 - and t = Hashtbl.create 17 - and index = ref 0 in - let get_index act = - try - Hashtbl.find t act - with - | Not_found -> - let i = !index in - incr index ; - Hashtbl.add t act i ; - i in - - for k=i to j do - let l,h,act = cases.(k) in - let index = get_index act in - for kk=l-ll to h-ll do - tbl.(kk) <- index - done - done ; - let acts = Array.make !index actions.(0) in - Hashtbl.iter - (fun act i -> acts.(i) <- actions.(act)) - t ; - (fun ctx -> - match -ll-ctx.off with - | 0 -> Arg.make_switch loc ctx.arg tbl acts - | _ -> - Arg.bind - (Arg.make_offset ctx.arg (-ll-ctx.off)) - (fun arg -> Arg.make_switch loc arg tbl acts)) - - - let make_clusters loc ({cases=cases ; actions=actions} as s) n_clusters k = - let len = Array.length cases in - let r = Array.make n_clusters (0,0,0) - and t = Hashtbl.create 17 - and index = ref 0 - and bidon = ref (Array.length actions) in - let get_index act = - try - let i,_ = Hashtbl.find t act in - i - with - | Not_found -> - let i = !index in - incr index ; - Hashtbl.add - t act - (i,(fun _ -> actions.(act))) ; - i - and add_index act = - let i = !index in - incr index ; - incr bidon ; - Hashtbl.add t !bidon (i,act) ; - i in - - let rec zyva j ir = - let i = k.(j) in - begin if i=j then - let l,h,act = cases.(i) in - r.(ir) <- (l,h,get_index act) - else (* assert i < j *) - let l,_,_ = cases.(i) - and _,h,_ = cases.(j) in - r.(ir) <- (l,h,add_index (make_switch loc s i j)) - end ; - if i > 0 then zyva (i-1) (ir-1) in - - zyva (len-1) (n_clusters-1) ; - let acts = Array.make !index (fun _ -> assert false) in - Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ; - {cases = r ; actions = acts} - ;; - - - let do_zyva loc (low,high) arg cases actions = - let old_ok = !ok_inter in - ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ; - if !ok_inter <> old_ok then Hashtbl.clear t ; - - let s = {cases=cases ; actions=actions} in - -(* - Printf.eprintf "ZYVA: %B [low=%i,high=%i]\n" !ok_inter low high ; - pcases stderr cases ; - prerr_endline "" ; -*) - let n_clusters,k = comp_clusters s in - let clusters = make_clusters loc s n_clusters k in - c_test {arg=arg ; off=0} clusters - - let abstract_shared actions = - let handlers = ref (fun x -> x) in - let actions = - Array.map - (fun act -> match act with - | Single act -> act - | Shared act -> - let i,h = Arg.make_catch act in - let oh = !handlers in - handlers := (fun act -> h (oh act)) ; - Arg.make_exit i) - actions in - !handlers,actions - - let zyva loc lh arg cases actions = - assert (Array.length cases > 0) ; - let actions = actions.act_get_shared () in - let hs,actions = abstract_shared actions in - hs (do_zyva loc lh arg cases actions) - - and test_sequence arg cases actions = - assert (Array.length cases > 0) ; - let actions = actions.act_get_shared () in - let hs,actions = abstract_shared actions in - let old_ok = !ok_inter in - ok_inter := false ; - if !ok_inter <> old_ok then Hashtbl.clear t ; - let s = - {cases=cases ; - actions=Array.map (fun act -> (fun _ -> act)) actions} in -(* - Printf.eprintf "SEQUENCE: %B\n" !ok_inter ; - pcases stderr cases ; - prerr_endline "" ; -*) - hs (c_test {arg=arg ; off=0} s) - ;; - -end diff --git a/bytecomp/switch.mli b/bytecomp/switch.mli deleted file mode 100644 index b4058c17..00000000 --- a/bytecomp/switch.mli +++ /dev/null @@ -1,129 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* - This module transforms generic switches in combinations - of if tests and switches. -*) - -(* For detecting action sharing, object style *) - -(* Store for actions in object style: - act_store : store an action, returns index in table - In case an action with equal key exists, returns index - of the stored action. Otherwise add entry in table. - act_store_shared : This stored action will always be shared. - act_get : retrieve table - act_get_shared : retrieve table, with sharing explicit -*) - -type 'a shared = Shared of 'a | Single of 'a - -type ('a, 'ctx) t_store = - {act_get : unit -> 'a array ; - act_get_shared : unit -> 'a shared array ; - act_store : 'ctx -> 'a -> int ; - act_store_shared : 'ctx -> 'a -> int ; } - -exception Not_simple - -module type Stored = sig - type t - type key - val compare_key : key -> key -> int - val make_key : t -> key option -end - -module type CtxStored = sig - include Stored - type context - val make_key : context -> t -> key option -end - -module CtxStore(A:CtxStored) : - sig - val mk_store : unit -> (A.t, A.context) t_store - end - -module Store(A:Stored) : - sig - val mk_store : unit -> (A.t, unit) t_store - end - -(* Arguments to the Make functor *) -module type S = - sig - (* type of basic tests *) - type primitive - (* basic tests themselves *) - val eqint : primitive - val neint : primitive - val leint : primitive - val ltint : primitive - val geint : primitive - val gtint : primitive - (* type of actions *) - type act - - (* Various constructors, for making a binder, - adding one integer, etc. *) - val bind : act -> (act -> act) -> act - val make_const : int -> act - val make_offset : act -> int -> act - val make_prim : primitive -> act list -> act - val make_isout : act -> act -> act - val make_isin : act -> act -> act - val make_if : act -> act -> act -> act - (* construct an actual switch : - make_switch arg cases acts - NB: cases is in the value form *) - val make_switch : - Location.t -> act -> int array -> act array -> act - (* Build last minute sharing of action stuff *) - val make_catch : act -> int * (act -> act) - val make_exit : int -> act - - end - - -(* - Make.zyva arg low high cases actions where - - arg is the argument of the switch. - - low, high are the interval limits. - - cases is a list of sub-interval and action indices - - actions is an array of actions. - - All these arguments specify a switch construct and zyva - returns an action that performs the switch. -*) -module Make : - functor (Arg : S) -> - sig -(* Standard entry point, sharing is tracked *) - val zyva : - Location.t -> - (int * int) -> - Arg.act -> - (int * int * int) array -> - (Arg.act, _) t_store -> - Arg.act - -(* Output test sequence, sharing tracked *) - val test_sequence : - Arg.act -> - (int * int * int) array -> - (Arg.act, _) t_store -> - Arg.act - end diff --git a/bytecomp/translattribute.ml b/bytecomp/translattribute.ml deleted file mode 100644 index 1520a3b4..00000000 --- a/bytecomp/translattribute.ml +++ /dev/null @@ -1,332 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* *) -(* Copyright 2015 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Typedtree -open Lambda -open Location - -let is_inline_attribute = function - | {txt=("inline"|"ocaml.inline")} -> true - | _ -> false - -let is_inlined_attribute = function - | {txt=("inlined"|"ocaml.inlined")} -> true - | {txt=("unrolled"|"ocaml.unrolled")} when Config.flambda -> true - | _ -> false - -let is_specialise_attribute = function - | {txt=("specialise"|"ocaml.specialise")} when Config.flambda -> true - | _ -> false - -let is_specialised_attribute = function - | {txt=("specialised"|"ocaml.specialised")} when Config.flambda -> true - | _ -> false - -let is_local_attribute = function - | {txt=("local"|"ocaml.local")} -> true - | _ -> false - -let find_attribute p attributes = - let inline_attribute, other_attributes = - List.partition (fun a -> p a.Parsetree.attr_name) attributes - in - let attr = - match inline_attribute with - | [] -> None - | [attr] -> Some attr - | _ :: {Parsetree.attr_name = {txt;loc}; _} :: _ -> - Location.prerr_warning loc (Warnings.Duplicated_attribute txt); - None - in - attr, other_attributes - -let is_unrolled = function - | {txt="unrolled"|"ocaml.unrolled"} -> true - | {txt="inline"|"ocaml.inline"|"inlined"|"ocaml.inlined"} -> false - | _ -> assert false - -let get_id_payload = - let open Parsetree in - function - | PStr [] -> Some "" - | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] -> - begin match pexp_desc with - | Pexp_ident { txt = Longident.Lident id } -> Some id - | _ -> None - end - | _ -> None - -let parse_id_payload txt loc ~default ~empty cases payload = - let[@local] warn () = - let ( %> ) f g x = g (f x) in - let msg = - cases - |> List.map (fst %> Printf.sprintf "'%s'") - |> String.concat ", " - |> Printf.sprintf "It must be either %s or empty" - in - Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg)); - default - in - match get_id_payload payload with - | Some "" -> empty - | None -> warn () - | Some id -> - match List.assoc_opt id cases with - | Some r -> r - | None -> warn () - -let parse_inline_attribute attr = - match attr with - | None -> Default_inline - | Some {Parsetree.attr_name = {txt;loc} as id; attr_payload = payload} -> - let open Parsetree in - if is_unrolled id then begin - (* the 'unrolled' attributes must be used as [@unrolled n]. *) - let warning txt = Warnings.Attribute_payload - (txt, "It must be an integer literal") - in - match payload with - | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] -> begin - match pexp_desc with - | Pexp_constant (Pconst_integer(s, None)) -> begin - try - Unroll (Misc.Int_literal_converter.int s) - with Failure _ -> - Location.prerr_warning loc (warning txt); - Default_inline - end - | _ -> - Location.prerr_warning loc (warning txt); - Default_inline - end - | _ -> - Location.prerr_warning loc (warning txt); - Default_inline - end else - parse_id_payload txt loc - ~default:Default_inline - ~empty:Always_inline - [ - "never", Never_inline; - "always", Always_inline; - ] - payload - -let parse_specialise_attribute attr = - match attr with - | None -> Default_specialise - | Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} -> - parse_id_payload txt loc - ~default:Default_specialise - ~empty:Always_specialise - [ - "never", Never_specialise; - "always", Always_specialise; - ] - payload - -let parse_local_attribute attr = - match attr with - | None -> Default_local - | Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} -> - parse_id_payload txt loc - ~default:Default_local - ~empty:Always_local - [ - "never", Never_local; - "always", Always_local; - "maybe", Default_local; - ] - payload - -let get_inline_attribute l = - let attr, _ = find_attribute is_inline_attribute l in - parse_inline_attribute attr - -let get_specialise_attribute l = - let attr, _ = find_attribute is_specialise_attribute l in - parse_specialise_attribute attr - -let get_local_attribute l = - let attr, _ = find_attribute is_local_attribute l in - parse_local_attribute attr - -let check_local_inline loc attr = - match attr.local, attr.inline with - | Always_local, (Always_inline | Unroll _) -> - Location.prerr_warning loc - (Warnings.Duplicated_attribute "local/inline") - | _ -> - () - -let add_inline_attribute expr loc attributes = - match expr, get_inline_attribute attributes with - | expr, Default_inline -> expr - | Lfunction({ attr = { stub = false } as attr } as funct), inline -> - begin match attr.inline with - | Default_inline -> () - | Always_inline | Never_inline | Unroll _ -> - Location.prerr_warning loc - (Warnings.Duplicated_attribute "inline") - end; - let attr = { attr with inline } in - check_local_inline loc attr; - Lfunction { funct with attr = attr } - | expr, (Always_inline | Never_inline | Unroll _) -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute "inline"); - expr - -let add_specialise_attribute expr loc attributes = - match expr, get_specialise_attribute attributes with - | expr, Default_specialise -> expr - | Lfunction({ attr = { stub = false } as attr } as funct), specialise -> - begin match attr.specialise with - | Default_specialise -> () - | Always_specialise | Never_specialise -> - Location.prerr_warning loc - (Warnings.Duplicated_attribute "specialise") - end; - let attr = { attr with specialise } in - Lfunction { funct with attr } - | expr, (Always_specialise | Never_specialise) -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute "specialise"); - expr - -let add_local_attribute expr loc attributes = - match expr, get_local_attribute attributes with - | expr, Default_local -> expr - | Lfunction({ attr = { stub = false } as attr } as funct), local -> - begin match attr.local with - | Default_local -> () - | Always_local | Never_local -> - Location.prerr_warning loc - (Warnings.Duplicated_attribute "local") - end; - let attr = { attr with local } in - check_local_inline loc attr; - Lfunction { funct with attr } - | expr, (Always_local | Never_local) -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute "local"); - expr - -(* Get the [@inlined] attribute payload (or default if not present). - It also returns the expression without this attribute. This is - used to ensure that this attribute is not misplaced: If it - appears on any expression, it is an error, otherwise it would - have been removed by this function *) -let get_and_remove_inlined_attribute e = - let attr, exp_attributes = - find_attribute is_inlined_attribute e.exp_attributes - in - let inlined = parse_inline_attribute attr in - inlined, { e with exp_attributes } - -let get_and_remove_inlined_attribute_on_module e = - let rec get_and_remove mod_expr = - let attr, mod_attributes = - find_attribute is_inlined_attribute mod_expr.mod_attributes - in - let attr = parse_inline_attribute attr in - let attr, mod_desc = - match mod_expr.Typedtree.mod_desc with - | Tmod_constraint (me, mt, mtc, mc) -> - let inner_attr, me = get_and_remove me in - let attr = - match attr with - | Always_inline | Never_inline | Unroll _ -> attr - | Default_inline -> inner_attr - in - attr, Tmod_constraint (me, mt, mtc, mc) - | md -> attr, md - in - attr, { mod_expr with mod_desc; mod_attributes } - in - get_and_remove e - -let get_and_remove_specialised_attribute e = - let attr, exp_attributes = - find_attribute is_specialised_attribute e.exp_attributes - in - let specialised = parse_specialise_attribute attr in - specialised, { e with exp_attributes } - -(* It also removes the attribute from the expression, like - get_inlined_attribute *) -let get_tailcall_attribute e = - let is_tailcall_attribute = function - | {Parsetree.attr_name = {txt=("tailcall"|"ocaml.tailcall")}; _} -> true - | _ -> false - in - let tailcalls, exp_attributes = - List.partition is_tailcall_attribute e.exp_attributes - in - match tailcalls with - | [] -> false, e - | _ :: r -> - begin match r with - | [] -> () - | {Parsetree.attr_name = {txt;loc}; _} :: _ -> - Location.prerr_warning loc (Warnings.Duplicated_attribute txt) - end; - true, { e with exp_attributes } - -let check_attribute e {Parsetree.attr_name = { txt; loc }; _} = - match txt with - | "inline" | "ocaml.inline" - | "specialise" | "ocaml.specialise" -> begin - match e.exp_desc with - | Texp_function _ -> () - | _ -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute txt) - end - | "inlined" | "ocaml.inlined" - | "specialised" | "ocaml.specialised" - | "tailcall" | "ocaml.tailcall" -> - (* Removed by the Texp_apply cases *) - Location.prerr_warning loc - (Warnings.Misplaced_attribute txt) - | _ -> () - -let check_attribute_on_module e {Parsetree.attr_name = { txt; loc }; _} = - match txt with - | "inline" | "ocaml.inline" -> begin - match e.mod_desc with - | Tmod_functor _ -> () - | _ -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute txt) - end - | "inlined" | "ocaml.inlined" -> - (* Removed by the Texp_apply cases *) - Location.prerr_warning loc - (Warnings.Misplaced_attribute txt) - | _ -> () - -let add_function_attributes lam loc attr = - let lam = - add_inline_attribute lam loc attr - in - let lam = - add_specialise_attribute lam loc attr - in - let lam = - add_local_attribute lam loc attr - in - lam diff --git a/bytecomp/translattribute.mli b/bytecomp/translattribute.mli deleted file mode 100644 index bf22fd1c..00000000 --- a/bytecomp/translattribute.mli +++ /dev/null @@ -1,76 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* *) -(* Copyright 2015 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -val check_attribute - : Typedtree.expression - -> Parsetree.attribute - -> unit - -val check_attribute_on_module - : Typedtree.module_expr - -> Parsetree.attribute - -> unit - -val add_inline_attribute - : Lambda.lambda - -> Location.t - -> Parsetree.attributes - -> Lambda.lambda - -val get_inline_attribute - : Parsetree.attributes - -> Lambda.inline_attribute - -val add_specialise_attribute - : Lambda.lambda - -> Location.t - -> Parsetree.attributes - -> Lambda.lambda - -val get_specialise_attribute - : Parsetree.attributes - -> Lambda.specialise_attribute - -val add_local_attribute - : Lambda.lambda - -> Location.t - -> Parsetree.attributes - -> Lambda.lambda - -val get_local_attribute - : Parsetree.attributes - -> Lambda.local_attribute - -val get_and_remove_inlined_attribute - : Typedtree.expression - -> Lambda.inline_attribute * Typedtree.expression - -val get_and_remove_inlined_attribute_on_module - : Typedtree.module_expr - -> Lambda.inline_attribute * Typedtree.module_expr - -val get_and_remove_specialised_attribute - : Typedtree.expression - -> Lambda.specialise_attribute * Typedtree.expression - -val get_tailcall_attribute - : Typedtree.expression - -> bool * Typedtree.expression - -val add_function_attributes - : Lambda.lambda - -> Location.t - -> Parsetree.attributes - -> Lambda.lambda diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml deleted file mode 100644 index 10b09066..00000000 --- a/bytecomp/translclass.ml +++ /dev/null @@ -1,946 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Asttypes -open Types -open Typedtree -open Lambda -open Translobj -open Translcore - -(* XXX Rajouter des evenements... | Add more events... *) - -type error = Tags of label * label - -exception Error of Location.t * error - -let lfunction params body = - if params = [] then body else - match body with - | Lfunction {kind = Curried; params = params'; body = body'; attr; loc} -> - Lfunction {kind = Curried; params = params @ params'; - return = Pgenval; - body = body'; attr; - loc} - | _ -> - Lfunction {kind = Curried; params; return = Pgenval; - body; - attr = default_function_attribute; - loc = Location.none} - -let lapply ap = - match ap.ap_func with - Lapply ap' -> - Lapply {ap with ap_func = ap'.ap_func; ap_args = ap'.ap_args @ ap.ap_args} - | _ -> - Lapply ap - -let mkappl (func, args) = - Lapply {ap_should_be_tailcall=false; - ap_loc=Location.none; - ap_func=func; - ap_args=args; - ap_inlined=Default_inline; - ap_specialised=Default_specialise};; - -let lsequence l1 l2 = - if l2 = lambda_unit then l1 else Lsequence(l1, l2) - -let lfield v i = Lprim(Pfield i, [Lvar v], Location.none) - -let transl_label l = share (Const_immstring l) - -let transl_meth_list lst = - if lst = [] then Lconst (Const_pointer 0) else - share (Const_block - (0, List.map (fun lab -> Const_immstring lab) lst)) - -let set_inst_var obj id expr = - Lprim(Psetfield_computed (Typeopt.maybe_pointer expr, Assignment), - [Lvar obj; Lvar id; transl_exp expr], Location.none) - -let transl_val tbl create name = - mkappl (oo_prim (if create then "new_variable" else "get_variable"), - [Lvar tbl; transl_label name]) - -let transl_vals tbl create strict vals rem = - List.fold_right - (fun (name, id) rem -> - Llet(strict, Pgenval, id, transl_val tbl create name, rem)) - vals rem - -let meths_super tbl meths inh_meths = - List.fold_right - (fun (nm, id) rem -> - try - (nm, id, - mkappl(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)])) - :: rem - with Not_found -> rem) - inh_meths [] - -let bind_super tbl (vals, meths) cl_init = - transl_vals tbl false StrictOpt vals - (List.fold_right (fun (_nm, id, def) rem -> - Llet(StrictOpt, Pgenval, id, def, rem)) - meths cl_init) - -let create_object cl obj init = - let obj' = Ident.create_local "self" in - let (inh_init, obj_init, has_init) = init obj' in - if obj_init = lambda_unit then - (inh_init, - mkappl (oo_prim (if has_init then "create_object_and_run_initializers" - else"create_object_opt"), - [obj; Lvar cl])) - else begin - (inh_init, - Llet(Strict, Pgenval, obj', - mkappl (oo_prim "create_object_opt", [obj; Lvar cl]), - Lsequence(obj_init, - if not has_init then Lvar obj' else - mkappl (oo_prim "run_initializers_opt", - [obj; Lvar obj'; Lvar cl])))) - end - -let name_pattern default p = - match p.pat_desc with - | Tpat_var (id, _) -> id - | Tpat_alias(_, id, _) -> id - | _ -> Ident.create_local default - -let rec build_object_init cl_table obj params inh_init obj_init cl = - match cl.cl_desc with - Tcl_ident (path, _, _) -> - let obj_init = Ident.create_local "obj_init" in - let envs, inh_init = inh_init in - let env = - match envs with None -> [] - | Some envs -> - [Lprim(Pfield (List.length inh_init + 1), - [Lvar envs], - Location.none)] - in - let path_lam = transl_class_path cl.cl_loc cl.cl_env path in - ((envs, (path, path_lam, obj_init) :: inh_init), - mkappl(Lvar obj_init, env @ [obj])) - | Tcl_structure str -> - create_object cl_table obj (fun obj -> - let (inh_init, obj_init, has_init) = - List.fold_right - (fun field (inh_init, obj_init, has_init) -> - match field.cf_desc with - Tcf_inherit (_, cl, _, _, _) -> - let (inh_init, obj_init') = - build_object_init cl_table (Lvar obj) [] inh_init - (fun _ -> lambda_unit) cl - in - (inh_init, lsequence obj_init' obj_init, true) - | Tcf_val (_, _, id, Tcfk_concrete (_, exp), _) -> - (inh_init, lsequence (set_inst_var obj id exp) obj_init, - has_init) - | Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _-> - (inh_init, obj_init, has_init) - | Tcf_initializer _ -> - (inh_init, obj_init, true) - ) - str.cstr_fields - (inh_init, obj_init obj, false) - in - (inh_init, - List.fold_right - (fun (id, expr) rem -> - lsequence (Lifused (id, set_inst_var obj id expr)) rem) - params obj_init, - has_init)) - | Tcl_fun (_, pat, vals, cl, partial) -> - let (inh_init, obj_init) = - build_object_init cl_table obj (vals @ params) inh_init obj_init cl - in - (inh_init, - let build params rem = - let param = name_pattern "param" pat in - Lfunction {kind = Curried; params = (param, Pgenval)::params; - return = Pgenval; - attr = default_function_attribute; - loc = pat.pat_loc; - body = Matching.for_function - pat.pat_loc None (Lvar param) [pat, rem] partial} - in - begin match obj_init with - Lfunction {kind = Curried; params; body = rem} -> build params rem - | rem -> build [] rem - end) - | Tcl_apply (cl, oexprs) -> - let (inh_init, obj_init) = - build_object_init cl_table obj params inh_init obj_init cl - in - (inh_init, transl_apply obj_init oexprs Location.none) - | Tcl_let (rec_flag, defs, vals, cl) -> - let (inh_init, obj_init) = - build_object_init cl_table obj (vals @ params) inh_init obj_init cl - in - (inh_init, Translcore.transl_let rec_flag defs obj_init) - | Tcl_open (_, cl) - | Tcl_constraint (cl, _, _, _, _) -> - build_object_init cl_table obj params inh_init obj_init cl - -let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = - match cl.cl_desc with - Tcl_let (_rec_flag, _defs, vals, cl) -> - build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids - | _ -> - let self = Ident.create_local "self" in - let env = Ident.create_local "env" in - let obj = if ids = [] then lambda_unit else Lvar self in - let envs = if top then None else Some env in - let ((_,inh_init), obj_init) = - build_object_init cl_table obj params (envs,[]) copy_env cl in - let obj_init = - if ids = [] then obj_init else lfunction [self, Pgenval] obj_init in - (inh_init, lfunction [env, Pgenval] (subst_env env inh_init obj_init)) - - -let bind_method tbl lab id cl_init = - Llet(Strict, Pgenval, id, mkappl (oo_prim "get_method_label", - [Lvar tbl; transl_label lab]), - cl_init) - -let bind_methods tbl meths vals cl_init = - let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in - let len = List.length methl and nvals = List.length vals in - if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else - if len = 0 && nvals < 2 then transl_vals tbl true Strict vals cl_init else - let ids = Ident.create_local "ids" in - let i = ref (len + nvals) in - let getter, names = - if nvals = 0 then "get_method_labels", [] else - "new_methods_variables", [transl_meth_list (List.map fst vals)] - in - Llet(Strict, Pgenval, ids, - mkappl (oo_prim getter, - [Lvar tbl; transl_meth_list (List.map fst methl)] @ names), - List.fold_right - (fun (_lab,id) lam -> decr i; Llet(StrictOpt, Pgenval, id, - lfield ids !i, lam)) - (methl @ vals) cl_init) - -let output_methods tbl methods lam = - match methods with - [] -> lam - | [lab; code] -> - lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam - | _ -> - lsequence (mkappl(oo_prim "set_methods", - [Lvar tbl; Lprim(Pmakeblock(0,Immutable,None), - methods, Location.none)])) - lam - -let rec ignore_cstrs cl = - match cl.cl_desc with - Tcl_constraint (cl, _, _, _, _) -> ignore_cstrs cl - | Tcl_apply (cl, _) -> ignore_cstrs cl - | _ -> cl - -let rec index a = function - [] -> raise Not_found - | b :: l -> - if b = a then 0 else 1 + index a l - -let bind_id_as_val (id, _) = ("", id) - -let rec build_class_init cla cstr super inh_init cl_init msubst top cl = - match cl.cl_desc with - | Tcl_ident _ -> - begin match inh_init with - | (_, path_lam, obj_init)::inh_init -> - (inh_init, - Llet (Strict, Pgenval, obj_init, - mkappl(Lprim(Pfield 1, [path_lam], Location.none), Lvar cla :: - if top then [Lprim(Pfield 3, [path_lam], Location.none)] - else []), - bind_super cla super cl_init)) - | _ -> - assert false - end - | Tcl_structure str -> - let cl_init = bind_super cla super cl_init in - let (inh_init, cl_init, methods, values) = - List.fold_right - (fun field (inh_init, cl_init, methods, values) -> - match field.cf_desc with - Tcf_inherit (_, cl, _, vals, meths) -> - let cl_init = output_methods cla methods cl_init in - let inh_init, cl_init = - build_class_init cla false - (vals, meths_super cla str.cstr_meths meths) - inh_init cl_init msubst top cl in - (inh_init, cl_init, [], values) - | Tcf_val (name, _, id, _, over) -> - let values = - if over then values else (name.txt, id) :: values - in - (inh_init, cl_init, methods, values) - | Tcf_method (_, _, Tcfk_virtual _) - | Tcf_constraint _ - -> - (inh_init, cl_init, methods, values) - | Tcf_method (name, _, Tcfk_concrete (_, exp)) -> - let met_code = msubst true (transl_exp exp) in - let met_code = - if !Clflags.native_code && List.length met_code = 1 then - (* Force correct naming of method for profiles *) - let met = Ident.create_local ("method_" ^ name.txt) in - [Llet(Strict, Pgenval, met, List.hd met_code, Lvar met)] - else met_code - in - (inh_init, cl_init, - Lvar(Meths.find name.txt str.cstr_meths) :: met_code @ methods, - values) - | Tcf_initializer exp -> - (inh_init, - Lsequence(mkappl (oo_prim "add_initializer", - Lvar cla :: msubst false (transl_exp exp)), - cl_init), - methods, values) - | Tcf_attribute _ -> - (inh_init, cl_init, methods, values)) - str.cstr_fields - (inh_init, cl_init, [], []) - in - let cl_init = output_methods cla methods cl_init in - (inh_init, bind_methods cla str.cstr_meths values cl_init) - | Tcl_fun (_, _pat, vals, cl, _) -> - let (inh_init, cl_init) = - build_class_init cla cstr super inh_init cl_init msubst top cl - in - let vals = List.map bind_id_as_val vals in - (inh_init, transl_vals cla true StrictOpt vals cl_init) - | Tcl_apply (cl, _exprs) -> - build_class_init cla cstr super inh_init cl_init msubst top cl - | Tcl_let (_rec_flag, _defs, vals, cl) -> - let (inh_init, cl_init) = - build_class_init cla cstr super inh_init cl_init msubst top cl - in - let vals = List.map bind_id_as_val vals in - (inh_init, transl_vals cla true StrictOpt vals cl_init) - | Tcl_constraint (cl, _, vals, meths, concr_meths) -> - let virt_meths = - List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in - let concr_meths = Concr.elements concr_meths in - let narrow_args = - [Lvar cla; - transl_meth_list vals; - transl_meth_list virt_meths; - transl_meth_list concr_meths] in - let cl = ignore_cstrs cl in - begin match cl.cl_desc, inh_init with - | Tcl_ident (path, _, _), (path', path_lam, obj_init)::inh_init -> - assert (Path.same path path'); - let inh = Ident.create_local "inh" - and ofs = List.length vals + 1 - and valids, methids = super in - let cl_init = - List.fold_left - (fun init (nm, id, _) -> - Llet(StrictOpt, Pgenval, id, - lfield inh (index nm concr_meths + ofs), - init)) - cl_init methids in - let cl_init = - List.fold_left - (fun init (nm, id) -> - Llet(StrictOpt, Pgenval, id, - lfield inh (index nm vals + 1), init)) - cl_init valids in - (inh_init, - Llet (Strict, Pgenval, inh, - mkappl(oo_prim "inherits", narrow_args @ - [path_lam; - Lconst(Const_pointer(if top then 1 else 0))]), - Llet(StrictOpt, Pgenval, obj_init, lfield inh 0, cl_init))) - | _ -> - let core cl_init = - build_class_init cla true super inh_init cl_init msubst top cl - in - if cstr then core cl_init else - let (inh_init, cl_init) = - core (Lsequence (mkappl (oo_prim "widen", [Lvar cla]), cl_init)) - in - (inh_init, - Lsequence(mkappl (oo_prim "narrow", narrow_args), - cl_init)) - end - | Tcl_open (_, cl) -> - build_class_init cla cstr super inh_init cl_init msubst top cl - -let rec build_class_lets cl = - match cl.cl_desc with - Tcl_let (rec_flag, defs, _vals, cl') -> - let env, wrap = build_class_lets cl' in - (env, fun x -> - Translcore.transl_let rec_flag defs (wrap x)) - | _ -> - (cl.cl_env, fun x -> x) - -let rec get_class_meths cl = - match cl.cl_desc with - Tcl_structure cl -> - Meths.fold (fun _ -> Ident.Set.add) cl.cstr_meths Ident.Set.empty - | Tcl_ident _ -> Ident.Set.empty - | Tcl_fun (_, _, _, cl, _) - | Tcl_let (_, _, _, cl) - | Tcl_apply (cl, _) - | Tcl_open (_, cl) - | Tcl_constraint (cl, _, _, _, _) -> get_class_meths cl - -(* - XXX Il devrait etre peu couteux d'ecrire des classes : - | Writing classes should be cheap - class c x y = d e f -*) -let rec transl_class_rebind obj_init cl vf = - match cl.cl_desc with - Tcl_ident (path, _, _) -> - if vf = Concrete then begin - try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit - with Not_found -> raise Exit - end; - let path_lam = transl_class_path cl.cl_loc cl.cl_env path in - (path, path_lam, obj_init) - | Tcl_fun (_, pat, _, cl, partial) -> - let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in - let build params rem = - let param = name_pattern "param" pat in - Lfunction {kind = Curried; params = (param, Pgenval)::params; - return = Pgenval; - attr = default_function_attribute; - loc = pat.pat_loc; - body = Matching.for_function - pat.pat_loc None (Lvar param) [pat, rem] partial} - in - (path, path_lam, - match obj_init with - Lfunction {kind = Curried; params; body} -> build params body - | rem -> build [] rem) - | Tcl_apply (cl, oexprs) -> - let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in - (path, path_lam, transl_apply obj_init oexprs Location.none) - | Tcl_let (rec_flag, defs, _vals, cl) -> - let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in - (path, path_lam, Translcore.transl_let rec_flag defs obj_init) - | Tcl_structure _ -> raise Exit - | Tcl_constraint (cl', _, _, _, _) -> - let path, path_lam, obj_init = transl_class_rebind obj_init cl' vf in - let rec check_constraint = function - Cty_constr(path', _, _) when Path.same path path' -> () - | Cty_arrow (_, _, cty) -> check_constraint cty - | _ -> raise Exit - in - check_constraint cl.cl_type; - (path, path_lam, obj_init) - | Tcl_open (_, cl) -> - transl_class_rebind obj_init cl vf - -let rec transl_class_rebind_0 (self:Ident.t) obj_init cl vf = - match cl.cl_desc with - Tcl_let (rec_flag, defs, _vals, cl) -> - let path, path_lam, obj_init = - transl_class_rebind_0 self obj_init cl vf - in - (path, path_lam, Translcore.transl_let rec_flag defs obj_init) - | _ -> - let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in - (path, path_lam, lfunction [self, Pgenval] obj_init) - -let transl_class_rebind cl vf = - try - let obj_init = Ident.create_local "obj_init" - and self = Ident.create_local "self" in - let obj_init0 = - lapply {ap_should_be_tailcall=false; - ap_loc=Location.none; - ap_func=Lvar obj_init; - ap_args=[Lvar self]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} - in - let _, path_lam, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in - let id = (obj_init' = lfunction [self, Pgenval] obj_init0) in - if id then path_lam else - - let cla = Ident.create_local "class" - and new_init = Ident.create_local "new_init" - and env_init = Ident.create_local "env_init" - and table = Ident.create_local "table" - and envs = Ident.create_local "envs" in - Llet( - Strict, Pgenval, new_init, lfunction [obj_init, Pgenval] obj_init', - Llet( - Alias, Pgenval, cla, path_lam, - Lprim(Pmakeblock(0, Immutable, None), - [mkappl(Lvar new_init, [lfield cla 0]); - lfunction [table, Pgenval] - (Llet(Strict, Pgenval, env_init, - mkappl(lfield cla 1, [Lvar table]), - lfunction [envs, Pgenval] - (mkappl(Lvar new_init, - [mkappl(Lvar env_init, [Lvar envs])])))); - lfield cla 2; - lfield cla 3], - Location.none))) - with Exit -> - lambda_unit - -(* Rewrite a closure using builtins. Improves native code size. *) - -let rec module_path = function - Lvar id -> - let s = Ident.name id in s <> "" && s.[0] >= 'A' && s.[0] <= 'Z' - | Lprim(Pfield _, [p], _) -> module_path p - | Lprim(Pgetglobal _, [], _) -> true - | _ -> false - -let const_path local = function - Lvar id -> not (List.mem id local) - | Lconst _ -> true - | Lfunction {kind = Curried; body} -> - let fv = free_variables body in - List.for_all (fun x -> not (Ident.Set.mem x fv)) local - | p -> module_path p - -let rec builtin_meths self env env2 body = - let const_path = const_path (env::self) in - let conv = function - (* Lvar s when List.mem s self -> "_self", [] *) - | p when const_path p -> "const", [p] - | Lprim(Parrayrefu _, [Lvar s; Lvar n], _) when List.mem s self -> - "var", [Lvar n] - | Lprim(Pfield n, [Lvar e], _) when Ident.same e env -> - "env", [Lvar env2; Lconst(Const_pointer n)] - | Lsend(Self, met, Lvar s, [], _) when List.mem s self -> - "meth", [met] - | _ -> raise Not_found - in - match body with - | Llet(_str, _k, s', Lvar s, body) when List.mem s self -> - builtin_meths (s'::self) env env2 body - | Lapply{ap_func = f; ap_args = [arg]} when const_path f -> - let s, args = conv arg in ("app_"^s, f :: args) - | Lapply{ap_func = f; ap_args = [arg; p]} when const_path f && const_path p -> - let s, args = conv arg in - ("app_"^s^"_const", f :: args @ [p]) - | Lapply{ap_func = f; ap_args = [p; arg]} when const_path f && const_path p -> - let s, args = conv arg in - ("app_const_"^s, f :: p :: args) - | Lsend(Self, Lvar n, Lvar s, [arg], _) when List.mem s self -> - let s, args = conv arg in - ("meth_app_"^s, Lvar n :: args) - | Lsend(Self, met, Lvar s, [], _) when List.mem s self -> - ("get_meth", [met]) - | Lsend(Public, met, arg, [], _) -> - let s, args = conv arg in - ("send_"^s, met :: args) - | Lsend(Cached, met, arg, [_;_], _) -> - let s, args = conv arg in - ("send_"^s, met :: args) - | Lfunction {kind = Curried; params = [x, _]; body} -> - let rec enter self = function - | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'], _) - when Ident.same x x' && List.mem s self -> - ("set_var", [Lvar n]) - | Llet(_str, _k, s', Lvar s, body) when List.mem s self -> - enter (s'::self) body - | _ -> raise Not_found - in enter self body - | Lfunction _ -> raise Not_found - | _ -> - let s, args = conv body in ("get_"^s, args) - -module M = struct - open CamlinternalOO - let builtin_meths self env env2 body = - let builtin, args = builtin_meths self env env2 body in - (* if not arr then [mkappl(oo_prim builtin, args)] else *) - let tag = match builtin with - "get_const" -> GetConst - | "get_var" -> GetVar - | "get_env" -> GetEnv - | "get_meth" -> GetMeth - | "set_var" -> SetVar - | "app_const" -> AppConst - | "app_var" -> AppVar - | "app_env" -> AppEnv - | "app_meth" -> AppMeth - | "app_const_const" -> AppConstConst - | "app_const_var" -> AppConstVar - | "app_const_env" -> AppConstEnv - | "app_const_meth" -> AppConstMeth - | "app_var_const" -> AppVarConst - | "app_env_const" -> AppEnvConst - | "app_meth_const" -> AppMethConst - | "meth_app_const" -> MethAppConst - | "meth_app_var" -> MethAppVar - | "meth_app_env" -> MethAppEnv - | "meth_app_meth" -> MethAppMeth - | "send_const" -> SendConst - | "send_var" -> SendVar - | "send_env" -> SendEnv - | "send_meth" -> SendMeth - | _ -> assert false - in Lconst(Const_pointer(Obj.magic tag)) :: args -end -open M - - -(* - Class translation. - Three subcases: - * reapplication of a known class -> transl_class_rebind - * class without local dependencies -> direct translation - * with local dependencies -> generate a stubs tree, - with a node for every local classes inherited - A class is a 4-tuple: - (obj_init, class_init, env_init, env) - obj_init: creation function (unit -> obj) - class_init: inheritance function (table -> env_init) - (one by source code) - env_init: parameterisation by the local environment - (env -> params -> obj_init) - (one for each combination of inherited class_init ) - env: local environment - If ids=0 (immediate object), then only env_init is conserved. -*) - -(* -let prerr_ids msg ids = - let names = List.map Ident.unique_toplevel_name ids in - prerr_endline (String.concat " " (msg :: names)) -*) - -let free_methods l = - let fv = ref Ident.Set.empty in - let rec free l = - Lambda.iter_head_constructor free l; - match l with - | Lsend(Self, Lvar meth, _, _, _) -> - fv := Ident.Set.add meth !fv - | Lsend _ -> () - | Lfunction{params} -> - List.iter (fun (param, _) -> fv := Ident.Set.remove param !fv) params - | Llet(_str, _k, id, _arg, _body) -> - fv := Ident.Set.remove id !fv - | Lletrec(decl, _body) -> - List.iter (fun (id, _exp) -> fv := Ident.Set.remove id !fv) decl - | Lstaticcatch(_e1, (_,vars), _e2) -> - List.iter (fun (id, _) -> fv := Ident.Set.remove id !fv) vars - | Ltrywith(_e1, exn, _e2) -> - fv := Ident.Set.remove exn !fv - | Lfor(v, _e1, _e2, _dir, _e3) -> - fv := Ident.Set.remove v !fv - | Lassign _ - | Lvar _ | Lconst _ | Lapply _ - | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _ - | Lifthenelse _ | Lsequence _ | Lwhile _ - | Levent _ | Lifused _ -> () - in free l; !fv - -let transl_class ids cl_id pub_meths cl vflag = - (* First check if it is not only a rebind *) - let rebind = transl_class_rebind cl vflag in - if rebind <> lambda_unit then rebind else - - (* Prepare for heavy environment handling *) - let tables = Ident.create_local (Ident.name cl_id ^ "_tables") in - let (top_env, req) = oo_add_class tables in - let top = not req in - let cl_env, llets = build_class_lets cl in - let new_ids = if top then [] else Env.diff top_env cl_env in - let env2 = Ident.create_local "env" in - let meth_ids = get_class_meths cl in - let subst env lam i0 new_ids' = - let fv = free_variables lam in - (* prerr_ids "cl_id =" [cl_id]; prerr_ids "fv =" (Ident.Set.elements fv); *) - let fv = List.fold_right Ident.Set.remove !new_ids' fv in - (* We need to handle method ids specially, as they do not appear - in the typing environment (PR#3576, PR#4560) *) - (* very hacky: we add and remove free method ids on the fly, - depending on the visit order... *) - method_ids := - Ident.Set.diff (Ident.Set.union (free_methods lam) !method_ids) meth_ids; - (* prerr_ids "meth_ids =" (Ident.Set.elements meth_ids); - prerr_ids "method_ids =" (Ident.Set.elements !method_ids); *) - let new_ids = List.fold_right Ident.Set.add new_ids !method_ids in - let fv = Ident.Set.inter fv new_ids in - new_ids' := !new_ids' @ Ident.Set.elements fv; - (* prerr_ids "new_ids' =" !new_ids'; *) - let i = ref (i0-1) in - List.fold_left - (fun subst id -> - incr i; Ident.Map.add id (lfield env !i) subst) - Ident.Map.empty !new_ids' - in - let new_ids_meths = ref [] in - let no_env_update _ _ env = env in - let msubst arr = function - Lfunction {kind = Curried; params = (self, Pgenval) :: args; body} -> - let env = Ident.create_local "env" in - let body' = - if new_ids = [] then body else - Lambda.subst no_env_update (subst env body 0 new_ids_meths) body in - begin try - (* Doesn't seem to improve size for bytecode *) - (* if not !Clflags.native_code then raise Not_found; *) - if not arr || !Clflags.debug then raise Not_found; - builtin_meths [self] env env2 (lfunction args body') - with Not_found -> - [lfunction ((self, Pgenval) :: args) - (if not (Ident.Set.mem env (free_variables body')) then body' else - Llet(Alias, Pgenval, env, - Lprim(Pfield_computed, - [Lvar self; Lvar env2], - Location.none), - body'))] - end - | _ -> assert false - in - let new_ids_init = ref [] in - let env1 = Ident.create_local "env" and env1' = Ident.create_local "env'" in - let copy_env self = - if top then lambda_unit else - Lifused(env2, Lprim(Psetfield_computed (Pointer, Assignment), - [Lvar self; Lvar env2; Lvar env1'], - Location.none)) - and subst_env envs l lam = - if top then lam else - (* must be called only once! *) - let lam = Lambda.subst no_env_update (subst env1 lam 1 new_ids_init) lam in - Llet(Alias, Pgenval, env1, (if l = [] then Lvar envs else lfield envs 0), - Llet(Alias, Pgenval, env1', - (if !new_ids_init = [] then Lvar env1 else lfield env1 0), - lam)) - in - - (* Now we start compiling the class *) - let cla = Ident.create_local "class" in - let (inh_init, obj_init) = - build_object_init_0 cla [] cl copy_env subst_env top ids in - let inh_init' = List.rev inh_init in - let (inh_init', cl_init) = - build_class_init cla true ([],[]) inh_init' obj_init msubst top cl - in - assert (inh_init' = []); - let table = Ident.create_local "table" - and class_init = Ident.create_local (Ident.name cl_id ^ "_init") - and env_init = Ident.create_local "env_init" - and obj_init = Ident.create_local "obj_init" in - let pub_meths = - List.sort - (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s')) - pub_meths in - let tags = List.map Btype.hash_variant pub_meths in - let rev_map = List.combine tags pub_meths in - List.iter2 - (fun tag name -> - let name' = List.assoc tag rev_map in - if name' <> name then raise(Error(cl.cl_loc, Tags(name, name')))) - tags pub_meths; - let ltable table lam = - Llet(Strict, Pgenval, table, - mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam) - and ldirect obj_init = - Llet(Strict, Pgenval, obj_init, cl_init, - Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), - mkappl (Lvar obj_init, [lambda_unit]))) - in - (* Simplest case: an object defined at toplevel (ids=[]) *) - if top && ids = [] then llets (ltable cla (ldirect obj_init)) else - - let concrete = (vflag = Concrete) - and lclass lam = - let cl_init = llets (Lfunction{kind = Curried; - attr = default_function_attribute; - loc = Location.none; - return = Pgenval; - params = [cla, Pgenval]; body = cl_init}) in - Llet(Strict, Pgenval, class_init, cl_init, lam (free_variables cl_init)) - and lbody fv = - if List.for_all (fun id -> not (Ident.Set.mem id fv)) ids then - mkappl (oo_prim "make_class",[transl_meth_list pub_meths; - Lvar class_init]) - else - ltable table ( - Llet( - Strict, Pgenval, env_init, mkappl (Lvar class_init, [Lvar table]), - Lsequence( - mkappl (oo_prim "init_class", [Lvar table]), - Lprim(Pmakeblock(0, Immutable, None), - [mkappl (Lvar env_init, [lambda_unit]); - Lvar class_init; Lvar env_init; lambda_unit], - Location.none)))) - and lbody_virt lenvs = - Lprim(Pmakeblock(0, Immutable, None), - [lambda_unit; Lfunction{kind = Curried; - attr = default_function_attribute; - loc = Location.none; - return = Pgenval; - params = [cla, Pgenval]; body = cl_init}; - lambda_unit; lenvs], - Location.none) - in - (* Still easy: a class defined at toplevel *) - if top && concrete then lclass lbody else - if top then llets (lbody_virt lambda_unit) else - - (* Now for the hard stuff: prepare for table caching *) - let envs = Ident.create_local "envs" - and cached = Ident.create_local "cached" in - let lenvs = - if !new_ids_meths = [] && !new_ids_init = [] && inh_init = [] - then lambda_unit - else Lvar envs in - let lenv = - let menv = - if !new_ids_meths = [] then lambda_unit else - Lprim(Pmakeblock(0, Immutable, None), - List.map (fun id -> Lvar id) !new_ids_meths, - Location.none) in - if !new_ids_init = [] then menv else - Lprim(Pmakeblock(0, Immutable, None), - menv :: List.map (fun id -> Lvar id) !new_ids_init, - Location.none) - and linh_envs = - List.map - (fun (_, path_lam, _) -> Lprim(Pfield 3, [path_lam], Location.none)) - (List.rev inh_init) - in - let make_envs lam = - Llet(StrictOpt, Pgenval, envs, - (if linh_envs = [] then lenv else - Lprim(Pmakeblock(0, Immutable, None), - lenv :: linh_envs, Location.none)), - lam) - and def_ids cla lam = - Llet(StrictOpt, Pgenval, env2, - mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]), - lam) - in - let inh_paths = - List.filter - (fun (path, _, _) -> List.mem (Path.head path) new_ids) inh_init - in - let inh_keys = - List.map - (fun (_, path_lam, _) -> Lprim(Pfield 1, [path_lam], Location.none)) - inh_paths - in - let lclass lam = - Llet(Strict, Pgenval, class_init, - Lfunction{kind = Curried; params = [cla, Pgenval]; - return = Pgenval; - attr = default_function_attribute; - loc = Location.none; - body = def_ids cla cl_init}, lam) - and lcache lam = - if inh_keys = [] then Llet(Alias, Pgenval, cached, Lvar tables, lam) else - Llet(Strict, Pgenval, cached, - mkappl (oo_prim "lookup_tables", - [Lvar tables; Lprim(Pmakeblock(0, Immutable, None), - inh_keys, Location.none)]), - lam) - and lset cached i lam = - Lprim(Psetfield(i, Pointer, Assignment), - [Lvar cached; lam], Location.none) - in - let ldirect () = - ltable cla - (Llet(Strict, Pgenval, env_init, def_ids cla cl_init, - Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), - lset cached 0 (Lvar env_init)))) - and lclass_virt () = - lset cached 0 - (Lfunction - { - kind = Curried; - attr = default_function_attribute; - loc = Location.none; - return = Pgenval; - params = [cla, Pgenval]; - body = def_ids cla cl_init; - } - ) - in - let lupdate_cache = - if ids = [] then ldirect () else - if not concrete then lclass_virt () else - lclass ( - mkappl (oo_prim "make_class_store", - [transl_meth_list pub_meths; - Lvar class_init; Lvar cached])) in - let lcheck_cache = - if !Clflags.native_code && !Clflags.afl_instrument then - (* When afl-fuzz instrumentation is enabled, ignore the cache - so that the program's behaviour does not change between runs *) - lupdate_cache - else - Lifthenelse(lfield cached 0, lambda_unit, lupdate_cache) in - llets ( - lcache ( - Lsequence(lcheck_cache, - make_envs ( - if ids = [] then mkappl (lfield cached 0, [lenvs]) else - Lprim(Pmakeblock(0, Immutable, None), - (if concrete then - [mkappl (lfield cached 0, [lenvs]); - lfield cached 1; - lfield cached 0; - lenvs] - else [lambda_unit; lfield cached 0; lambda_unit; lenvs]), - Location.none - ))))) - -(* Wrapper for class compilation *) -(* - let cl_id = ci.ci_id_class in -(* TODO: cl_id is used somewhere else as typesharp ? *) - let _arity = List.length ci.ci_params in - let pub_meths = m in - let cl = ci.ci_expr in - let vflag = vf in -*) - -let transl_class ids id pub_meths cl vf = - oo_wrap cl.cl_env false (transl_class ids id pub_meths cl) vf - -let () = - transl_object := (fun id meths cl -> transl_class [] id meths cl Concrete) - -(* Error report *) - -open Format - -let report_error ppf = function - | Tags (lab1, lab2) -> - fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s" - lab1 lab2 "Change one of them." - -let () = - Location.register_error_of_exn - (function - | Error (loc, err) -> - Some (Location.error_of_printer ~loc report_error err) - | _ -> - None - ) diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli deleted file mode 100644 index 4c4bed0f..00000000 --- a/bytecomp/translclass.mli +++ /dev/null @@ -1,29 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Typedtree -open Lambda - -val transl_class : - Ident.t list -> Ident.t -> - string list -> class_expr -> Asttypes.virtual_flag -> lambda;; - -type error = Tags of string * string - -exception Error of Location.t * error - -open Format - -val report_error: formatter -> error -> unit diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml deleted file mode 100644 index e9098a2f..00000000 --- a/bytecomp/translcore.ml +++ /dev/null @@ -1,1048 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Translation from typed abstract syntax to lambda terms, - for the core language *) - -open Misc -open Asttypes -open Primitive -open Types -open Typedtree -open Typeopt -open Lambda - -type error = - Free_super_var - | Unreachable_reached - -exception Error of Location.t * error - -let use_dup_for_constant_arrays_bigger_than = 4 - -(* Forward declaration -- to be filled in by Translmod.transl_module *) -let transl_module = - ref((fun _cc _rootpath _modl -> assert false) : - module_coercion -> Path.t option -> module_expr -> lambda) - -let transl_object = - ref (fun _id _s _cl -> assert false : - Ident.t -> string list -> class_expr -> lambda) - -(* Compile an exception/extension definition *) - -let prim_fresh_oo_id = - Pccall (Primitive.simple ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false) - -let transl_extension_constructor env path ext = - let path = - Printtyp.wrap_printing_env env ~error:true (fun () -> - Stdlib.Option.map (Printtyp.rewrite_double_underscore_paths env) path) - in - let name = - match path, !Clflags.for_package with - None, _ -> Ident.name ext.ext_id - | Some p, None -> Path.name p - | Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p) - in - let loc = ext.ext_loc in - match ext.ext_kind with - Text_decl _ -> - Lprim (Pmakeblock (Obj.object_tag, Immutable, None), - [Lconst (Const_base (Const_string (name, None))); - Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)], - loc) - | Text_rebind(path, _lid) -> - transl_extension_path loc env path - -(* To propagate structured constants *) - -exception Not_constant - -let extract_constant = function - Lconst sc -> sc - | _ -> raise Not_constant - -let extract_float = function - Const_base(Const_float f) -> f - | _ -> fatal_error "Translcore.extract_float" - -(* Push the default values under the functional abstractions *) -(* Also push bindings of module patterns, since this sound *) - -type binding = - | Bind_value of value_binding list - | Bind_module of Ident.t * string loc * module_presence * module_expr - -let rec push_defaults loc bindings cases partial = - match cases with - [{c_lhs=pat; c_guard=None; - c_rhs={exp_desc = Texp_function { arg_label; param; cases; partial; } } - as exp}] -> - let cases = push_defaults exp.exp_loc bindings cases partial in - [{c_lhs=pat; c_guard=None; - c_rhs={exp with exp_desc = Texp_function { arg_label; param; cases; - partial; }}}] - | [{c_lhs=pat; c_guard=None; - c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#default"};_}]; - exp_desc = Texp_let - (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] -> - push_defaults loc (Bind_value binds :: bindings) - [{c_lhs=pat;c_guard=None;c_rhs=e2}] - partial - | [{c_lhs=pat; c_guard=None; - c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#modulepat"};_}]; - exp_desc = Texp_letmodule - (id, name, pres, mexpr, - ({exp_desc = Texp_function _} as e2))}}] -> - push_defaults loc (Bind_module (id, name, pres, mexpr) :: bindings) - [{c_lhs=pat;c_guard=None;c_rhs=e2}] - partial - | [case] -> - let exp = - List.fold_left - (fun exp binds -> - {exp with exp_desc = - match binds with - | Bind_value binds -> Texp_let(Nonrecursive, binds, exp) - | Bind_module (id, name, pres, mexpr) -> - Texp_letmodule (id, name, pres, mexpr, exp)}) - case.c_rhs bindings - in - [{case with c_rhs=exp}] - | {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] -> - let param = Typecore.name_cases "param" cases in - let desc = - {val_type = pat.pat_type; val_kind = Val_reg; - val_attributes = []; Types.val_loc = Location.none; } - in - let env = Env.add_value param desc exp.exp_env in - let name = Ident.name param in - let exp = - { exp with exp_loc = loc; exp_env = env; exp_desc = - Texp_match - ({exp with exp_type = pat.pat_type; exp_env = env; exp_desc = - Texp_ident - (Path.Pident param, mknoloc (Longident.Lident name), desc)}, - cases, partial) } - in - push_defaults loc bindings - [{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)}; - c_guard=None; c_rhs=exp}] - Total - | _ -> - cases - -(* Insertion of debugging events *) - -let event_before = Translprim.event_before - -let event_after = Translprim.event_after - -let event_function exp lam = - if !Clflags.debug && not !Clflags.native_code then - let repr = Some (ref 0) in - let (info, body) = lam repr in - (info, - Levent(body, {lev_loc = exp.exp_loc; - lev_kind = Lev_function; - lev_repr = repr; - lev_env = exp.exp_env})) - else - lam None - -(* Assertions *) - -let assert_failed exp = - let slot = - transl_extension_path Location.none - Env.initial_safe_string Predef.path_assert_failure - in - let (fname, line, char) = - Location.get_pos_info exp.exp_loc.Location.loc_start - in - Lprim(Praise Raise_regular, [event_after exp - (Lprim(Pmakeblock(0, Immutable, None), - [slot; - Lconst(Const_block(0, - [Const_base(Const_string (fname, None)); - Const_base(Const_int line); - Const_base(Const_int char)]))], exp.exp_loc))], exp.exp_loc) -;; - -let rec cut n l = - if n = 0 then ([],l) else - match l with [] -> failwith "Translcore.cut" - | a::l -> let (l1,l2) = cut (n-1) l in (a::l1,l2) - -(* Translation of expressions *) - -let rec iter_exn_names f pat = - match pat.pat_desc with - | Tpat_var (id, _) -> f id - | Tpat_alias (p, id, _) -> - f id; - iter_exn_names f p - | _ -> () - -let transl_ident loc env ty path desc = - match desc.val_kind with - | Val_prim p -> - Translprim.transl_primitive loc p env ty (Some path) - | Val_anc _ -> - raise(Error(loc, Free_super_var)) - | Val_reg | Val_self _ -> - transl_value_path loc env path - | _ -> fatal_error "Translcore.transl_exp: bad Texp_ident" - -let rec transl_exp e = - List.iter (Translattribute.check_attribute e) e.exp_attributes; - let eval_once = - (* Whether classes for immediate objects must be cached *) - match e.exp_desc with - Texp_function _ | Texp_for _ | Texp_while _ -> false - | _ -> true - in - if eval_once then transl_exp0 e else - Translobj.oo_wrap e.exp_env true transl_exp0 e - -and transl_exp0 e = - match e.exp_desc with - | Texp_ident(path, _, desc) -> - transl_ident e.exp_loc e.exp_env e.exp_type path desc - | Texp_constant cst -> - Lconst(Const_base cst) - | Texp_let(rec_flag, pat_expr_list, body) -> - transl_let rec_flag pat_expr_list (event_before body (transl_exp body)) - | Texp_function { arg_label = _; param; cases; partial; } -> - let ((kind, params, return), body) = - event_function e - (function repr -> - let pl = push_defaults e.exp_loc [] cases partial in - let return_kind = function_return_value_kind e.exp_env e.exp_type in - transl_function e.exp_loc return_kind !Clflags.native_code repr - partial param pl) - in - let attr = default_function_attribute in - let loc = e.exp_loc in - let lam = Lfunction{kind; params; return; body; attr; loc} in - Translattribute.add_function_attributes lam loc e.exp_attributes - | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p}); - exp_type = prim_type } as funct, oargs) - when List.length oargs >= p.prim_arity - && List.for_all (fun (_, arg) -> arg <> None) oargs -> - let argl, extra_args = cut p.prim_arity oargs in - let arg_exps = - List.map (function _, Some x -> x | _ -> assert false) argl - in - let args = transl_list arg_exps in - let prim_exp = if extra_args = [] then Some e else None in - let lam = - Translprim.transl_primitive_application - e.exp_loc p e.exp_env prim_type path - prim_exp args arg_exps - in - if extra_args = [] then lam - else begin - let should_be_tailcall, funct = - Translattribute.get_tailcall_attribute funct - in - let inlined, funct = - Translattribute.get_and_remove_inlined_attribute funct - in - let specialised, funct = - Translattribute.get_and_remove_specialised_attribute funct - in - let e = { e with exp_desc = Texp_apply(funct, oargs) } in - event_after e - (transl_apply ~should_be_tailcall ~inlined ~specialised - lam extra_args e.exp_loc) - end - | Texp_apply(funct, oargs) -> - let should_be_tailcall, funct = - Translattribute.get_tailcall_attribute funct - in - let inlined, funct = - Translattribute.get_and_remove_inlined_attribute funct - in - let specialised, funct = - Translattribute.get_and_remove_specialised_attribute funct - in - let e = { e with exp_desc = Texp_apply(funct, oargs) } in - event_after e - (transl_apply ~should_be_tailcall ~inlined ~specialised - (transl_exp funct) oargs e.exp_loc) - | Texp_match(arg, pat_expr_list, partial) -> - transl_match e arg pat_expr_list partial - | Texp_try(body, pat_expr_list) -> - let id = Typecore.name_cases "exn" pat_expr_list in - Ltrywith(transl_exp body, id, - Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list)) - | Texp_tuple el -> - let ll, shape = transl_list_with_shape el in - begin try - Lconst(Const_block(0, List.map extract_constant ll)) - with Not_constant -> - Lprim(Pmakeblock(0, Immutable, Some shape), ll, e.exp_loc) - end - | Texp_construct(_, cstr, args) -> - let ll, shape = transl_list_with_shape args in - if cstr.cstr_inlined <> None then begin match ll with - | [x] -> x - | _ -> assert false - end else begin match cstr.cstr_tag with - Cstr_constant n -> - Lconst(Const_pointer n) - | Cstr_unboxed -> - (match ll with [v] -> v | _ -> assert false) - | Cstr_block n -> - begin try - Lconst(Const_block(n, List.map extract_constant ll)) - with Not_constant -> - Lprim(Pmakeblock(n, Immutable, Some shape), ll, e.exp_loc) - end - | Cstr_extension(path, is_const) -> - let lam = transl_extension_path e.exp_loc e.exp_env path in - if is_const then lam - else - Lprim(Pmakeblock(0, Immutable, Some (Pgenval :: shape)), - lam :: ll, e.exp_loc) - end - | Texp_extension_constructor (_, path) -> - transl_extension_path e.exp_loc e.exp_env path - | Texp_variant(l, arg) -> - let tag = Btype.hash_variant l in - begin match arg with - None -> Lconst(Const_pointer tag) - | Some arg -> - let lam = transl_exp arg in - try - Lconst(Const_block(0, [Const_base(Const_int tag); - extract_constant lam])) - with Not_constant -> - Lprim(Pmakeblock(0, Immutable, None), - [Lconst(Const_base(Const_int tag)); lam], e.exp_loc) - end - | Texp_record {fields; representation; extended_expression} -> - transl_record e.exp_loc e.exp_env fields representation - extended_expression - | Texp_field(arg, _, lbl) -> - let targ = transl_exp arg in - begin match lbl.lbl_repres with - Record_regular | Record_inlined _ -> - Lprim (Pfield lbl.lbl_pos, [targ], e.exp_loc) - | Record_unboxed _ -> targ - | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [targ], e.exp_loc) - | Record_extension _ -> - Lprim (Pfield (lbl.lbl_pos + 1), [targ], e.exp_loc) - end - | Texp_setfield(arg, _, lbl, newval) -> - let access = - match lbl.lbl_repres with - Record_regular - | Record_inlined _ -> - Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment) - | Record_unboxed _ -> assert false - | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment) - | Record_extension _ -> - Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment) - in - Lprim(access, [transl_exp arg; transl_exp newval], e.exp_loc) - | Texp_array expr_list -> - let kind = array_kind e in - let ll = transl_list expr_list in - begin try - (* For native code the decision as to which compilation strategy to - use is made later. This enables the Flambda passes to lift certain - kinds of array definitions to symbols. *) - (* Deactivate constant optimization if array is small enough *) - if List.length ll <= use_dup_for_constant_arrays_bigger_than - then begin - raise Not_constant - end; - begin match List.map extract_constant ll with - | exception Not_constant when kind = Pfloatarray -> - (* We cannot currently lift [Pintarray] arrays safely in Flambda - because [caml_modify] might be called upon them (e.g. from - code operating on polymorphic arrays, or functions such as - [caml_array_blit]. - To avoid having different Lambda code for - bytecode/Closure vs. Flambda, we always generate - [Pduparray] here, and deal with it in [Bytegen] (or in - the case of Closure, in [Cmmgen], which already has to - handle [Pduparray Pmakearray Pfloatarray] in the case - where the array turned out to be inconstant). - When not [Pfloatarray], the exception propagates to the handler - below. *) - let imm_array = - Lprim (Pmakearray (kind, Immutable), ll, e.exp_loc) - in - Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc) - | cl -> - let imm_array = - match kind with - | Paddrarray | Pintarray -> - Lconst(Const_block(0, cl)) - | Pfloatarray -> - Lconst(Const_float_array(List.map extract_float cl)) - | Pgenarray -> - raise Not_constant (* can this really happen? *) - in - Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc) - end - with Not_constant -> - Lprim(Pmakearray (kind, Mutable), ll, e.exp_loc) - end - | Texp_ifthenelse(cond, ifso, Some ifnot) -> - Lifthenelse(transl_exp cond, - event_before ifso (transl_exp ifso), - event_before ifnot (transl_exp ifnot)) - | Texp_ifthenelse(cond, ifso, None) -> - Lifthenelse(transl_exp cond, - event_before ifso (transl_exp ifso), - lambda_unit) - | Texp_sequence(expr1, expr2) -> - Lsequence(transl_exp expr1, event_before expr2 (transl_exp expr2)) - | Texp_while(cond, body) -> - Lwhile(transl_exp cond, event_before body (transl_exp body)) - | Texp_for(param, _, low, high, dir, body) -> - Lfor(param, transl_exp low, transl_exp high, dir, - event_before body (transl_exp body)) - | Texp_send(_, _, Some exp) -> transl_exp exp - | Texp_send(expr, met, None) -> - let obj = transl_exp expr in - let lam = - match met with - Tmeth_val id -> Lsend (Self, Lvar id, obj, [], e.exp_loc) - | Tmeth_name nm -> - let (tag, cache) = Translobj.meth obj nm in - let kind = if cache = [] then Public else Cached in - Lsend (kind, tag, obj, cache, e.exp_loc) - in - event_after e lam - | Texp_new (cl, {Location.loc=loc}, _) -> - Lapply{ap_should_be_tailcall=false; - ap_loc=loc; - ap_func= - Lprim(Pfield 0, [transl_class_path loc e.exp_env cl], loc); - ap_args=[lambda_unit]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} - | Texp_instvar(path_self, path, _) -> - let self = transl_value_path e.exp_loc e.exp_env path_self in - let var = transl_value_path e.exp_loc e.exp_env path in - Lprim(Pfield_computed, [self; var], e.exp_loc) - | Texp_setinstvar(path_self, path, _, expr) -> - let self = transl_value_path e.exp_loc e.exp_env path_self in - let var = transl_value_path e.exp_loc e.exp_env path in - transl_setinstvar e.exp_loc self var expr - | Texp_override(path_self, modifs) -> - let self = transl_value_path e.exp_loc e.exp_env path_self in - let cpy = Ident.create_local "copy" in - Llet(Strict, Pgenval, cpy, - Lapply{ap_should_be_tailcall=false; - ap_loc=Location.none; - ap_func=Translobj.oo_prim "copy"; - ap_args=[self]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}, - List.fold_right - (fun (path, _, expr) rem -> - let var = transl_value_path e.exp_loc e.exp_env path in - Lsequence(transl_setinstvar Location.none - (Lvar cpy) var expr, rem)) - modifs - (Lvar cpy)) - | Texp_letmodule(id, loc, Mp_present, modl, body) -> - let defining_expr = - Levent (!transl_module Tcoerce_none None modl, { - lev_loc = loc.loc; - lev_kind = Lev_module_definition id; - lev_repr = None; - lev_env = Env.empty; - }) - in - Llet(Strict, Pgenval, id, defining_expr, transl_exp body) - | Texp_letmodule(_, _, Mp_absent, _, body) -> - transl_exp body - | Texp_letexception(cd, body) -> - Llet(Strict, Pgenval, - cd.ext_id, transl_extension_constructor e.exp_env None cd, - transl_exp body) - | Texp_pack modl -> - !transl_module Tcoerce_none None modl - | Texp_assert {exp_desc=Texp_construct(_, {cstr_name="false"}, _)} -> - assert_failed e - | Texp_assert (cond) -> - if !Clflags.noassert - then lambda_unit - else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e) - | Texp_lazy e -> - (* when e needs no computation (constants, identifiers, ...), we - optimize the translation just as Lazy.lazy_from_val would - do *) - begin match Typeopt.classify_lazy_argument e with - | `Constant_or_function -> - (* A constant expr (of type <> float if [Config.flat_float_array] is - true) gets compiled as itself. *) - transl_exp e - | `Float_that_cannot_be_shortcut -> - (* We don't need to wrap with Popaque: this forward - block will never be shortcutted since it points to a float - and Config.flat_float_array is true. *) - Lprim(Pmakeblock(Obj.forward_tag, Immutable, None), - [transl_exp e], e.exp_loc) - | `Identifier `Forward_value -> - (* CR-someday mshinwell: Consider adding a new primitive - that expresses the construction of forward_tag blocks. - We need to use [Popaque] here to prevent unsound - optimisation in Flambda, but the concept of a mutable - block doesn't really match what is going on here. This - value may subsequently turn into an immediate... *) - Lprim (Popaque, - [Lprim(Pmakeblock(Obj.forward_tag, Immutable, None), - [transl_exp e], e.exp_loc)], - e.exp_loc) - | `Identifier `Other -> - transl_exp e - | `Other -> - (* other cases compile to a lazy block holding a function *) - let fn = Lfunction {kind = Curried; - params= [Ident.create_local "param", Pgenval]; - return = Pgenval; - attr = default_function_attribute; - loc = e.exp_loc; - body = transl_exp e} in - Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [fn], e.exp_loc) - end - | Texp_object (cs, meths) -> - let cty = cs.cstr_type in - let cl = Ident.create_local "class" in - !transl_object cl meths - { cl_desc = Tcl_structure cs; - cl_loc = e.exp_loc; - cl_type = Cty_signature cty; - cl_env = e.exp_env; - cl_attributes = []; - } - | Texp_letop{let_; ands; param; body; partial} -> - event_after e - (transl_letop e.exp_loc e.exp_env let_ ands param body partial) - | Texp_unreachable -> - raise (Error (e.exp_loc, Unreachable_reached)) - | Texp_open (od, e) -> - let pure = pure_module od.open_expr in - (* this optimization shouldn't be needed because Simplif would - actually remove the [Llet] when it's not used. - But since [scan_used_globals] runs before Simplif, we need to - do it. *) - begin match od.open_bound_items with - | [] when pure = Alias -> transl_exp e - | _ -> - let oid = Ident.create_local "open" in - let body, _ = - List.fold_left (fun (body, pos) id -> - Llet(Alias, Pgenval, id, - Lprim(Pfield pos, [Lvar oid], od.open_loc), body), - pos + 1 - ) (transl_exp e, 0) (bound_value_identifiers od.open_bound_items) - in - Llet(pure, Pgenval, oid, - !transl_module Tcoerce_none None od.open_expr, body) - end - -and pure_module m = - match m.mod_desc with - Tmod_ident _ -> Alias - | Tmod_constraint (m,_,_,_) -> pure_module m - | _ -> Strict - -and transl_list expr_list = - List.map transl_exp expr_list - -and transl_list_with_shape expr_list = - let transl_with_shape e = - let shape = Typeopt.value_kind e.exp_env e.exp_type in - transl_exp e, shape - in - List.split (List.map transl_with_shape expr_list) - -and transl_guard guard rhs = - let expr = event_before rhs (transl_exp rhs) in - match guard with - | None -> expr - | Some cond -> - event_before cond (Lifthenelse(transl_exp cond, expr, staticfail)) - -and transl_case {c_lhs; c_guard; c_rhs} = - c_lhs, transl_guard c_guard c_rhs - -and transl_cases cases = - let cases = - List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in - List.map transl_case cases - -and transl_case_try {c_lhs; c_guard; c_rhs} = - iter_exn_names Translprim.add_exception_ident c_lhs; - Misc.try_finally - (fun () -> c_lhs, transl_guard c_guard c_rhs) - ~always:(fun () -> - iter_exn_names Translprim.remove_exception_ident c_lhs) - -and transl_cases_try cases = - let cases = - List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in - List.map transl_case_try cases - -and transl_tupled_cases patl_expr_list = - let patl_expr_list = - List.filter (fun (_,_,e) -> e.exp_desc <> Texp_unreachable) - patl_expr_list in - List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr)) - patl_expr_list - -and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline) - ?(specialised = Default_specialise) lam sargs loc = - let lapply funct args = - match funct with - Lsend(k, lmet, lobj, largs, loc) -> - Lsend(k, lmet, lobj, largs @ args, loc) - | Levent(Lsend(k, lmet, lobj, largs, loc), _) -> - Lsend(k, lmet, lobj, largs @ args, loc) - | Lapply ap -> - Lapply {ap with ap_args = ap.ap_args @ args; ap_loc = loc} - | lexp -> - Lapply {ap_should_be_tailcall=should_be_tailcall; - ap_loc=loc; - ap_func=lexp; - ap_args=args; - ap_inlined=inlined; - ap_specialised=specialised;} - in - let rec build_apply lam args = function - (None, optional) :: l -> - let defs = ref [] in - let protect name lam = - match lam with - Lvar _ | Lconst _ -> lam - | _ -> - let id = Ident.create_local name in - defs := (id, lam) :: !defs; - Lvar id - in - let args, args' = - if List.for_all (fun (_,opt) -> opt) args then [], args - else args, [] in - let lam = - if args = [] then lam else lapply lam (List.rev_map fst args) in - let handle = protect "func" lam - and l = List.map (fun (arg, opt) -> may_map (protect "arg") arg, opt) l - and id_arg = Ident.create_local "param" in - let body = - match build_apply handle ((Lvar id_arg, optional)::args') l with - Lfunction{kind = Curried; params = ids; return; - body = lam; attr; loc} -> - Lfunction{kind = Curried; - params = (id_arg, Pgenval)::ids; - return; - body = lam; attr; - loc} - | Levent(Lfunction{kind = Curried; params = ids; return; - body = lam; attr; loc}, _) -> - Lfunction{kind = Curried; params = (id_arg, Pgenval)::ids; - return; - body = lam; attr; - loc} - | lam -> - Lfunction{kind = Curried; params = [id_arg, Pgenval]; - return = Pgenval; body = lam; - attr = default_stub_attribute; loc = loc} - in - List.fold_left - (fun body (id, lam) -> Llet(Strict, Pgenval, id, lam, body)) - body !defs - | (Some arg, optional) :: l -> - build_apply lam ((arg, optional) :: args) l - | [] -> - lapply lam (List.rev_map fst args) - in - (build_apply lam [] (List.map (fun (l, x) -> - may_map transl_exp x, Btype.is_optional l) - sargs) - : Lambda.lambda) - -and transl_function loc return untuplify_fn repr partial (param:Ident.t) cases = - match cases with - [{c_lhs=pat; c_guard=None; - c_rhs={exp_desc = Texp_function { arg_label = _; param = param'; cases; - partial = partial'; }; exp_env; exp_type} as exp}] - when Parmatch.inactive ~partial pat -> - let kind = value_kind pat.pat_env pat.pat_type in - let return_kind = function_return_value_kind exp_env exp_type in - let ((_, params, return), body) = - transl_function exp.exp_loc return_kind false repr partial' param' cases - in - ((Curried, (param, kind) :: params, return), - Matching.for_function loc None (Lvar param) [pat, body] partial) - | {c_lhs={pat_desc = Tpat_tuple pl}} :: _ when untuplify_fn -> - begin try - let size = List.length pl in - let pats_expr_list = - List.map - (fun {c_lhs; c_guard; c_rhs} -> - (Matching.flatten_pattern size c_lhs, c_guard, c_rhs)) - cases in - let kinds = - (* All the patterns might not share the same types. We must take the - union of the patterns types *) - match pats_expr_list with - | [] -> assert false - | (pats, _, _) :: cases -> - let first_case_kinds = - List.map (fun pat -> value_kind pat.pat_env pat.pat_type) pats - in - List.fold_left - (fun kinds (pats, _, _) -> - List.map2 (fun kind pat -> - value_kind_union kind - (value_kind pat.pat_env pat.pat_type)) - kinds pats) - first_case_kinds cases - in - let tparams = - List.map (fun kind -> Ident.create_local "param", kind) kinds - in - let params = List.map fst tparams in - ((Tupled, tparams, return), - Matching.for_tupled_function loc params - (transl_tupled_cases pats_expr_list) partial) - with Matching.Cannot_flatten -> - ((Curried, [param, Pgenval], return), - Matching.for_function loc repr (Lvar param) - (transl_cases cases) partial) - end - | {c_lhs=pat} :: other_cases -> - let kind = - (* All the patterns might not share the same types. We must take the - union of the patterns types *) - List.fold_left (fun k {c_lhs=pat} -> - Typeopt.value_kind_union k - (value_kind pat.pat_env pat.pat_type)) - (value_kind pat.pat_env pat.pat_type) other_cases - in - ((Curried, [param, kind], return), - Matching.for_function loc repr (Lvar param) - (transl_cases cases) partial) - | [] -> - (* With Camlp4, a pattern matching might be empty *) - ((Curried, [param, Pgenval], return), - Matching.for_function loc repr (Lvar param) - (transl_cases cases) partial) - -(* - Notice: transl_let consumes (ie compiles) its pat_expr_list argument, - and returns a function that will take the body of the lambda-let construct. - This complication allows choosing any compilation order for the - bindings and body of let constructs. -*) -and transl_let rec_flag pat_expr_list = - match rec_flag with - Nonrecursive -> - let rec transl = function - [] -> - fun body -> body - | {vb_pat=pat; vb_expr=expr; vb_attributes=attr; vb_loc} :: rem -> - let lam = transl_exp expr in - let lam = Translattribute.add_function_attributes lam vb_loc attr in - let mk_body = transl rem in - fun body -> Matching.for_let pat.pat_loc lam pat (mk_body body) - in transl pat_expr_list - | Recursive -> - let idlist = - List.map - (fun {vb_pat=pat} -> match pat.pat_desc with - Tpat_var (id,_) -> id - | Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id - | _ -> assert false) - pat_expr_list in - let transl_case {vb_expr=expr; vb_attributes; vb_loc} id = - let lam = transl_exp expr in - let lam = - Translattribute.add_function_attributes lam vb_loc vb_attributes - in - (id, lam) in - let lam_bds = List.map2 transl_case pat_expr_list idlist in - fun body -> Lletrec(lam_bds, body) - -and transl_setinstvar loc self var expr = - Lprim(Psetfield_computed (maybe_pointer expr, Assignment), - [self; var; transl_exp expr], loc) - -and transl_record loc env fields repres opt_init_expr = - let size = Array.length fields in - (* Determine if there are "enough" fields (only relevant if this is a - functional-style record update *) - let no_init = match opt_init_expr with None -> true | _ -> false in - if no_init || size < Config.max_young_wosize - then begin - (* Allocate new record with given fields (and remaining fields - taken from init_expr if any *) - let init_id = Ident.create_local "init" in - let lv = - Array.mapi - (fun i (_, definition) -> - match definition with - | Kept typ -> - let field_kind = value_kind env typ in - let access = - match repres with - Record_regular | Record_inlined _ -> Pfield i - | Record_unboxed _ -> assert false - | Record_extension _ -> Pfield (i + 1) - | Record_float -> Pfloatfield i in - Lprim(access, [Lvar init_id], loc), field_kind - | Overridden (_lid, expr) -> - let field_kind = value_kind expr.exp_env expr.exp_type in - transl_exp expr, field_kind) - fields - in - let ll, shape = List.split (Array.to_list lv) in - let mut = - if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields - then Mutable - else Immutable in - let lam = - try - if mut = Mutable then raise Not_constant; - let cl = List.map extract_constant ll in - match repres with - | Record_regular -> Lconst(Const_block(0, cl)) - | Record_inlined tag -> Lconst(Const_block(tag, cl)) - | Record_unboxed _ -> Lconst(match cl with [v] -> v | _ -> assert false) - | Record_float -> - Lconst(Const_float_array(List.map extract_float cl)) - | Record_extension _ -> - raise Not_constant - with Not_constant -> - match repres with - Record_regular -> - Lprim(Pmakeblock(0, mut, Some shape), ll, loc) - | Record_inlined tag -> - Lprim(Pmakeblock(tag, mut, Some shape), ll, loc) - | Record_unboxed _ -> (match ll with [v] -> v | _ -> assert false) - | Record_float -> - Lprim(Pmakearray (Pfloatarray, mut), ll, loc) - | Record_extension path -> - let slot = transl_extension_path loc env path in - Lprim(Pmakeblock(0, mut, Some (Pgenval :: shape)), slot :: ll, loc) - in - begin match opt_init_expr with - None -> lam - | Some init_expr -> Llet(Strict, Pgenval, init_id, - transl_exp init_expr, lam) - end - end else begin - (* Take a shallow copy of the init record, then mutate the fields - of the copy *) - let copy_id = Ident.create_local "newrecord" in - let update_field cont (lbl, definition) = - match definition with - | Kept _type -> cont - | Overridden (_lid, expr) -> - let upd = - match repres with - Record_regular - | Record_inlined _ -> - Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment) - | Record_unboxed _ -> assert false - | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment) - | Record_extension _ -> - Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment) - in - Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr], loc), cont) - in - begin match opt_init_expr with - None -> assert false - | Some init_expr -> - Llet(Strict, Pgenval, copy_id, - Lprim(Pduprecord (repres, size), [transl_exp init_expr], loc), - Array.fold_left update_field (Lvar copy_id) fields) - end - end - -and transl_match e arg pat_expr_list partial = - let rewrite_case (val_cases, exn_cases, static_handlers as acc) - ({ c_lhs; c_guard; c_rhs } as case) = - if c_rhs.exp_desc = Texp_unreachable then acc else - let val_pat, exn_pat = split_pattern c_lhs in - match val_pat, exn_pat with - | None, None -> assert false - | Some pv, None -> - let val_case = - transl_case { case with c_lhs = pv } - in - val_case :: val_cases, exn_cases, static_handlers - | None, Some pe -> - let exn_case = transl_case_try { case with c_lhs = pe } in - val_cases, exn_case :: exn_cases, static_handlers - | Some pv, Some pe -> - assert (c_guard = None); - let lbl = next_raise_count () in - let static_raise ids = - Lstaticraise (lbl, List.map (fun id -> Lvar id) ids) - in - (* Simplif doesn't like it if binders are not uniq, so we make sure to - use different names in the value and the exception branches. *) - let ids_full = Typedtree.pat_bound_idents_full pv in - let ids = List.map (fun (id, _, _) -> id) ids_full in - let ids_kinds = - List.map (fun (id, _, ty) -> id, Typeopt.value_kind pv.pat_env ty) - ids_full - in - let vids = List.map Ident.rename ids in - let pv = alpha_pat (List.combine ids vids) pv in - (* Also register the names of the exception so Re-raise happens. *) - iter_exn_names Translprim.add_exception_ident pe; - let rhs = - Misc.try_finally - (fun () -> event_before c_rhs (transl_exp c_rhs)) - ~always:(fun () -> - iter_exn_names Translprim.remove_exception_ident pe) - in - (pv, static_raise vids) :: val_cases, - (pe, static_raise ids) :: exn_cases, - (lbl, ids_kinds, rhs) :: static_handlers - in - let val_cases, exn_cases, static_handlers = - let x, y, z = List.fold_left rewrite_case ([], [], []) pat_expr_list in - List.rev x, List.rev y, List.rev z - in - let static_catch body val_ids handler = - let id = Typecore.name_pattern "exn" (List.map fst exn_cases) in - let static_exception_id = next_raise_count () in - Lstaticcatch - (Ltrywith (Lstaticraise (static_exception_id, body), id, - Matching.for_trywith (Lvar id) exn_cases), - (static_exception_id, val_ids), - handler) - in - let classic = - match arg, exn_cases with - | {exp_desc = Texp_tuple argl}, [] -> - assert (static_handlers = []); - Matching.for_multiple_match e.exp_loc (transl_list argl) val_cases partial - | {exp_desc = Texp_tuple argl}, _ :: _ -> - let val_ids = - List.map - (fun arg -> - Typecore.name_pattern "val" [], - Typeopt.value_kind arg.exp_env arg.exp_type - ) - argl - in - let lvars = List.map (fun (id, _) -> Lvar id) val_ids in - static_catch (transl_list argl) val_ids - (Matching.for_multiple_match e.exp_loc lvars val_cases partial) - | arg, [] -> - assert (static_handlers = []); - Matching.for_function e.exp_loc None (transl_exp arg) val_cases partial - | arg, _ :: _ -> - let val_id = Typecore.name_cases "val" pat_expr_list in - let k = Typeopt.value_kind arg.exp_env arg.exp_type in - static_catch [transl_exp arg] [val_id, k] - (Matching.for_function e.exp_loc None (Lvar val_id) val_cases partial) - in - List.fold_left (fun body (static_exception_id, val_ids, handler) -> - Lstaticcatch (body, (static_exception_id, val_ids), handler) - ) classic static_handlers - -and transl_letop loc env let_ ands param case partial = - let rec loop prev_lam = function - | [] -> prev_lam - | and_ :: rest -> - let left_id = Ident.create_local "left" in - let right_id = Ident.create_local "right" in - let op = - transl_ident and_.bop_op_name.loc env - and_.bop_op_type and_.bop_op_path and_.bop_op_val - in - let exp = transl_exp and_.bop_exp in - let lam = - bind Strict right_id exp - (Lapply{ap_should_be_tailcall = false; - ap_loc = and_.bop_loc; - ap_func = op; - ap_args=[Lvar left_id; Lvar right_id]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}) - in - bind Strict left_id prev_lam (loop lam rest) - in - let op = - transl_ident let_.bop_op_name.loc env - let_.bop_op_type let_.bop_op_path let_.bop_op_val - in - let exp = loop (transl_exp let_.bop_exp) ands in - let func = - let return_kind = value_kind case.c_rhs.exp_env case.c_rhs.exp_type in - let (kind, params, return), body = - event_function case.c_rhs - (function repr -> - transl_function case.c_rhs.exp_loc return_kind - !Clflags.native_code repr partial param [case]) - in - let attr = default_function_attribute in - let loc = case.c_rhs.exp_loc in - Lfunction{kind; params; return; body; attr; loc} - in - Lapply{ap_should_be_tailcall = false; - ap_loc = loc; - ap_func = op; - ap_args=[exp; func]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} - -(* Wrapper for class compilation *) - -(* -let transl_exp = transl_exp_wrap - -let transl_let rec_flag pat_expr_list body = - match pat_expr_list with - [] -> body - | (_, expr) :: _ -> - Translobj.oo_wrap expr.exp_env false - (transl_let rec_flag pat_expr_list) body -*) - -(* Error report *) - -open Format - -let report_error ppf = function - | Free_super_var -> - fprintf ppf - "Ancestor names can only be used to select inherited methods" - | Unreachable_reached -> - fprintf ppf "Unreachable expression was reached" - -let () = - Location.register_error_of_exn - (function - | Error (loc, err) -> - Some (Location.error_of_printer ~loc report_error err) - | _ -> - None - ) diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli deleted file mode 100644 index 7a27dbcb..00000000 --- a/bytecomp/translcore.mli +++ /dev/null @@ -1,50 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Translation from typed abstract syntax to lambda terms, - for the core language *) - -open Asttypes -open Typedtree -open Lambda - -val pure_module : module_expr -> let_kind - -val transl_exp: expression -> lambda -val transl_apply: ?should_be_tailcall:bool - -> ?inlined:inline_attribute - -> ?specialised:specialise_attribute - -> lambda -> (arg_label * expression option) list - -> Location.t -> lambda -val transl_let: rec_flag -> value_binding list -> lambda -> lambda - -val transl_extension_constructor: Env.t -> Path.t option -> - extension_constructor -> lambda - -type error = - Free_super_var - | Unreachable_reached - -exception Error of Location.t * error - -open Format - -val report_error: formatter -> error -> unit - -(* Forward declaration -- to be filled in by Translmod.transl_module *) -val transl_module : - (module_coercion -> Path.t option -> module_expr -> lambda) ref -val transl_object : - (Ident.t -> string list -> class_expr -> lambda) ref diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml deleted file mode 100644 index 436344f4..00000000 --- a/bytecomp/translmod.ml +++ /dev/null @@ -1,1559 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Translation from typed abstract syntax to lambda terms, - for the module language *) - -open Misc -open Asttypes -open Path -open Types -open Typedtree -open Lambda -open Translobj -open Translcore -open Translclass - -type unsafe_component = - | Unsafe_module_binding - | Unsafe_functor - | Unsafe_non_function - | Unsafe_typext - -type unsafe_info = { reason:unsafe_component; loc:Location.t; subid:Ident.t } -type error = - Circular_dependency of (Ident.t * unsafe_info) list -| Conflicting_inline_attributes - -exception Error of Location.t * error - -(* Keep track of the root path (from the root of the namespace to the - currently compiled module expression). Useful for naming extensions. *) - -let global_path glob = Some(Pident glob) -let functor_path path param = - match path with - None -> None - | Some p -> Some(Papply(p, Pident param)) -let field_path path field = - match path with - None -> None - | Some p -> Some(Pdot(p, Ident.name field)) - -(* Compile type extensions *) - -let transl_type_extension env rootpath tyext body = - List.fold_right - (fun ext body -> - let lam = - transl_extension_constructor env (field_path rootpath ext.ext_id) ext - in - Llet(Strict, Pgenval, ext.ext_id, lam, body)) - tyext.tyext_constructors - body - -(* Compile a coercion *) - -let rec apply_coercion loc strict restr arg = - match restr with - Tcoerce_none -> - arg - | Tcoerce_structure(pos_cc_list, id_pos_list) -> - name_lambda strict arg (fun id -> - let get_field pos = - if pos < 0 then lambda_unit - else Lprim(Pfield pos,[Lvar id], loc) - in - let lam = - Lprim(Pmakeblock(0, Immutable, None), - List.map (apply_coercion_field loc get_field) pos_cc_list, - loc) - in - wrap_id_pos_list loc id_pos_list get_field lam) - | Tcoerce_functor(cc_arg, cc_res) -> - let param = Ident.create_local "funarg" in - let carg = apply_coercion loc Alias cc_arg (Lvar param) in - apply_coercion_result loc strict arg [param, Pgenval] [carg] cc_res - | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } -> - Translprim.transl_primitive pc_loc pc_desc pc_env pc_type None - | Tcoerce_alias (env, path, cc) -> - let lam = transl_module_path loc env path in - name_lambda strict arg - (fun _ -> apply_coercion loc Alias cc lam) - -and apply_coercion_field loc get_field (pos, cc) = - apply_coercion loc Alias cc (get_field pos) - -and apply_coercion_result loc strict funct params args cc_res = - match cc_res with - | Tcoerce_functor(cc_arg, cc_res) -> - let param = Ident.create_local "funarg" in - let arg = apply_coercion loc Alias cc_arg (Lvar param) in - apply_coercion_result loc strict funct - ((param, Pgenval) :: params) (arg :: args) cc_res - | _ -> - name_lambda strict funct - (fun id -> - Lfunction - { - kind = Curried; - params = List.rev params; - return = Pgenval; - attr = { default_function_attribute with - is_a_functor = true; - stub = true; }; - loc = loc; - body = apply_coercion - loc Strict cc_res - (Lapply{ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=Lvar id; - ap_args=List.rev args; - ap_inlined=Default_inline; - ap_specialised=Default_specialise})}) - -and wrap_id_pos_list loc id_pos_list get_field lam = - let fv = free_variables lam in - (*Format.eprintf "%a@." Printlambda.lambda lam; - Ident.Set.iter (fun id -> Format.eprintf "%a " Ident.print id) fv; - Format.eprintf "@.";*) - let (lam,s) = - List.fold_left (fun (lam, s) (id',pos,c) -> - if Ident.Set.mem id' fv then - let id'' = Ident.create_local (Ident.name id') in - (Llet(Alias, Pgenval, id'', - apply_coercion loc Alias c (get_field pos),lam), - Ident.Map.add id' id'' s) - else (lam, s)) - (lam, Ident.Map.empty) id_pos_list - in - if s == Ident.Map.empty then lam else Lambda.rename s lam - - -(* Compose two coercions - apply_coercion c1 (apply_coercion c2 e) behaves like - apply_coercion (compose_coercions c1 c2) e. *) - -let rec compose_coercions c1 c2 = - match (c1, c2) with - (Tcoerce_none, c2) -> c2 - | (c1, Tcoerce_none) -> c1 - | (Tcoerce_structure (pc1, ids1), Tcoerce_structure (pc2, ids2)) -> - let v2 = Array.of_list pc2 in - let ids1 = - List.map (fun (id,pos1,c1) -> - let (pos2,c2) = v2.(pos1) in (id, pos2, compose_coercions c1 c2)) - ids1 - in - Tcoerce_structure - (List.map - (fun pc -> - match pc with - | _, (Tcoerce_primitive _ | Tcoerce_alias _) -> - (* These cases do not take an argument (the position is -1), - so they do not need adjusting. *) - pc - | (p1, c1) -> - let (p2, c2) = v2.(p1) in - (p2, compose_coercions c1 c2)) - pc1, - ids1 @ ids2) - | (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) -> - Tcoerce_functor(compose_coercions arg2 arg1, - compose_coercions res1 res2) - | (c1, Tcoerce_alias (env, path, c2)) -> - Tcoerce_alias (env, path, compose_coercions c1 c2) - | (_, _) -> - fatal_error "Translmod.compose_coercions" - -(* -let apply_coercion a b c = - Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion b; - apply_coercion a b c - -let compose_coercions c1 c2 = - let c3 = compose_coercions c1 c2 in - let open Includemod in - Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@." - print_coercion c1 print_coercion c2 print_coercion c3; - c3 -*) - -(* Record the primitive declarations occurring in the module compiled *) - -let primitive_declarations = ref ([] : Primitive.description list) -let record_primitive = function - | {val_kind=Val_prim p;val_loc} -> - Translprim.check_primitive_arity val_loc p; - primitive_declarations := p :: !primitive_declarations - | _ -> () - -(* Utilities for compiling "module rec" definitions *) - -let mod_prim = Lambda.transl_prim "CamlinternalMod" - -let undefined_location loc = - let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in - Lconst(Const_block(0, - [Const_base(Const_string (fname, None)); - Const_base(Const_int line); - Const_base(Const_int char)])) - -exception Initialization_failure of unsafe_info - -let init_shape id modl = - let rec init_shape_mod subid loc env mty = - match Mtype.scrape env mty with - Mty_ident _ - | Mty_alias _ -> - raise (Initialization_failure {reason=Unsafe_module_binding;loc;subid}) - | Mty_signature sg -> - Const_block(0, [Const_block(0, init_shape_struct env sg)]) - | Mty_functor _ -> - (* can we do better? *) - raise (Initialization_failure {reason=Unsafe_functor;loc;subid}) - and init_shape_struct env sg = - match sg with - [] -> [] - | Sig_value(subid, {val_kind=Val_reg; val_type=ty; val_loc=loc},_) :: rem -> - let init_v = - match Ctype.expand_head env ty with - {desc = Tarrow(_,_,_,_)} -> - Const_pointer 0 (* camlinternalMod.Function *) - | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t -> - Const_pointer 1 (* camlinternalMod.Lazy *) - | _ -> - let not_a_function = {reason=Unsafe_non_function; loc; subid } in - raise (Initialization_failure not_a_function) in - init_v :: init_shape_struct env rem - | Sig_value(_, {val_kind=Val_prim _}, _) :: rem -> - init_shape_struct env rem - | Sig_value _ :: _rem -> - assert false - | Sig_type(id, tdecl, _, _) :: rem -> - init_shape_struct (Env.add_type ~check:false id tdecl env) rem - | Sig_typext (subid, {ext_loc=loc},_,_) :: _ -> - raise (Initialization_failure {reason=Unsafe_typext; loc; subid}) - | Sig_module(id, Mp_present, md, _, _) :: rem -> - init_shape_mod id md.md_loc env md.md_type :: - init_shape_struct (Env.add_module_declaration ~check:false - id Mp_present md env) rem - | Sig_module(id, Mp_absent, md, _, _) :: rem -> - init_shape_struct - (Env.add_module_declaration ~check:false - id Mp_absent md env) rem - | Sig_modtype(id, minfo, _) :: rem -> - init_shape_struct (Env.add_modtype id minfo env) rem - | Sig_class _ :: rem -> - Const_pointer 2 (* camlinternalMod.Class *) - :: init_shape_struct env rem - | Sig_class_type _ :: rem -> - init_shape_struct env rem - in - try - Ok(undefined_location modl.mod_loc, - Lconst(init_shape_mod id modl.mod_loc modl.mod_env modl.mod_type)) - with Initialization_failure reason -> Result.Error(reason) - -(* Reorder bindings to honor dependencies. *) - -type binding_status = - | Undefined - | Inprogress of int option (** parent node *) - | Defined - -let extract_unsafe_cycle id status init cycle_start = - let info i = match init.(i) with - | Result.Error r -> id.(i), r - | Ok _ -> assert false in - let rec collect stop l i = match status.(i) with - | Inprogress None | Undefined | Defined -> assert false - | Inprogress Some i when i = stop -> info i :: l - | Inprogress Some i -> collect stop (info i::l) i in - collect cycle_start [] cycle_start - -let reorder_rec_bindings bindings = - let id = Array.of_list (List.map (fun (id,_,_,_) -> id) bindings) - and loc = Array.of_list (List.map (fun (_,loc,_,_) -> loc) bindings) - and init = Array.of_list (List.map (fun (_,_,init,_) -> init) bindings) - and rhs = Array.of_list (List.map (fun (_,_,_,rhs) -> rhs) bindings) in - let fv = Array.map Lambda.free_variables rhs in - let num_bindings = Array.length id in - let status = Array.make num_bindings Undefined in - let res = ref [] in - let is_unsafe i = match init.(i) with - | Ok _ -> false - | Result.Error _ -> true in - let init_res i = match init.(i) with - | Result.Error _ -> None - | Ok(a,b) -> Some(a,b) in - let rec emit_binding parent i = - match status.(i) with - Defined -> () - | Inprogress _ -> - status.(i) <- Inprogress parent; - let cycle = extract_unsafe_cycle id status init i in - raise(Error(loc.(i), Circular_dependency cycle)) - | Undefined -> - if is_unsafe i then begin - status.(i) <- Inprogress parent; - for j = 0 to num_bindings - 1 do - if Ident.Set.mem id.(j) fv.(i) then emit_binding (Some i) j - done - end; - res := (id.(i), init_res i, rhs.(i)) :: !res; - status.(i) <- Defined in - for i = 0 to num_bindings - 1 do - match status.(i) with - Undefined -> emit_binding None i - | Inprogress _ -> assert false - | Defined -> () - done; - List.rev !res - -(* Generate lambda-code for a reordered list of bindings *) - -let eval_rec_bindings bindings cont = - let rec bind_inits = function - [] -> - bind_strict bindings - | (_id, None, _rhs) :: rem -> - bind_inits rem - | (id, Some(loc, shape), _rhs) :: rem -> - Llet(Strict, Pgenval, id, - Lapply{ap_should_be_tailcall=false; - ap_loc=Location.none; - ap_func=mod_prim "init_mod"; - ap_args=[loc; shape]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}, - bind_inits rem) - and bind_strict = function - [] -> - patch_forwards bindings - | (id, None, rhs) :: rem -> - Llet(Strict, Pgenval, id, rhs, bind_strict rem) - | (_id, Some _, _rhs) :: rem -> - bind_strict rem - and patch_forwards = function - [] -> - cont - | (_id, None, _rhs) :: rem -> - patch_forwards rem - | (id, Some(_loc, shape), rhs) :: rem -> - Lsequence(Lapply{ap_should_be_tailcall=false; - ap_loc=Location.none; - ap_func=mod_prim "update_mod"; - ap_args=[shape; Lvar id; rhs]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}, - patch_forwards rem) - in - bind_inits bindings - -let compile_recmodule compile_rhs bindings cont = - eval_rec_bindings - (reorder_rec_bindings - (List.map - (fun {mb_id=id; mb_expr=modl; mb_loc=loc; _} -> - (id, modl.mod_loc, init_shape id modl, compile_rhs id modl loc)) - bindings)) - cont - -(* Code to translate class entries in a structure *) - -let transl_class_bindings cl_list = - let ids = List.map (fun (ci, _) -> ci.ci_id_class) cl_list in - (ids, - List.map - (fun ({ci_id_class=id; ci_expr=cl; ci_virt=vf}, meths) -> - (id, transl_class ids id meths cl vf)) - cl_list) - -(* Compile one or more functors, merging curried functors to produce - multi-argument functors. Any [@inline] attribute on a functor that is - merged must be consistent with any other [@inline] attribute(s) on the - functor(s) being merged with. Such an attribute will be placed on the - resulting merged functor. *) - -let merge_inline_attributes attr1 attr2 loc = - match Lambda.merge_inline_attributes attr1 attr2 with - | Some attr -> attr - | None -> raise (Error (loc, Conflicting_inline_attributes)) - -let merge_functors mexp coercion root_path = - let rec merge mexp coercion path acc inline_attribute = - let finished = acc, mexp, path, coercion, inline_attribute in - match mexp.mod_desc with - | Tmod_functor (param, _, _, body) -> - let inline_attribute' = - Translattribute.get_inline_attribute mexp.mod_attributes - in - let arg_coercion, res_coercion = - match coercion with - | Tcoerce_none -> Tcoerce_none, Tcoerce_none - | Tcoerce_functor (arg_coercion, res_coercion) -> - arg_coercion, res_coercion - | _ -> fatal_error "Translmod.merge_functors: bad coercion" - in - let loc = mexp.mod_loc in - let path = functor_path path param in - let inline_attribute = - merge_inline_attributes inline_attribute inline_attribute' loc - in - merge body res_coercion path ((param, loc, arg_coercion) :: acc) - inline_attribute - | _ -> finished - in - merge mexp coercion root_path [] Default_inline - -let rec compile_functor mexp coercion root_path loc = - let functor_params_rev, body, body_path, res_coercion, inline_attribute = - merge_functors mexp coercion root_path - in - assert (List.length functor_params_rev >= 1); (* cf. [transl_module] *) - let params, body = - List.fold_left (fun (params, body) (param, loc, arg_coercion) -> - let param' = Ident.rename param in - let arg = apply_coercion loc Alias arg_coercion (Lvar param') in - let params = (param', Pgenval) :: params in - let body = Llet (Alias, Pgenval, param, arg, body) in - params, body) - ([], transl_module res_coercion body_path body) - functor_params_rev - in - Lfunction { - kind = Curried; - params; - return = Pgenval; - attr = { - inline = inline_attribute; - specialise = Default_specialise; - local = Default_local; - is_a_functor = true; - stub = false; - }; - loc; - body; - } - -(* Compile a module expression *) - -and transl_module cc rootpath mexp = - List.iter (Translattribute.check_attribute_on_module mexp) - mexp.mod_attributes; - let loc = mexp.mod_loc in - match mexp.mod_desc with - | Tmod_ident (path,_) -> - apply_coercion loc Strict cc - (transl_module_path loc mexp.mod_env path) - | Tmod_structure str -> - fst (transl_struct loc [] cc rootpath str) - | Tmod_functor _ -> - oo_wrap mexp.mod_env true (fun () -> - compile_functor mexp cc rootpath loc) () - | Tmod_apply(funct, arg, ccarg) -> - let inlined_attribute, funct = - Translattribute.get_and_remove_inlined_attribute_on_module funct - in - oo_wrap mexp.mod_env true - (apply_coercion loc Strict cc) - (Lapply{ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=transl_module Tcoerce_none None funct; - ap_args=[transl_module ccarg None arg]; - ap_inlined=inlined_attribute; - ap_specialised=Default_specialise}) - | Tmod_constraint(arg, _, _, ccarg) -> - transl_module (compose_coercions cc ccarg) rootpath arg - | Tmod_unpack(arg, _) -> - apply_coercion loc Strict cc (Translcore.transl_exp arg) - -and transl_struct loc fields cc rootpath str = - transl_structure loc fields cc rootpath str.str_final_env str.str_items - -(* The function transl_structure is called by the bytecode compiler. - Some effort is made to compile in top to bottom order, in order to display - warning by increasing locations. *) -and transl_structure loc fields cc rootpath final_env = function - [] -> - let body, size = - match cc with - Tcoerce_none -> - Lprim(Pmakeblock(0, Immutable, None), - List.map (fun id -> Lvar id) (List.rev fields), loc), - List.length fields - | Tcoerce_structure(pos_cc_list, id_pos_list) -> - (* Do not ignore id_pos_list ! *) - (*Format.eprintf "%a@.@[" Includemod.print_coercion cc; - List.iter (fun l -> Format.eprintf "%a@ " Ident.print l) - fields; - Format.eprintf "@]@.";*) - let v = Array.of_list (List.rev fields) in - let get_field pos = - if pos < 0 then lambda_unit - else Lvar v.(pos) - in - let ids = List.fold_right Ident.Set.add fields Ident.Set.empty in - let lam = - Lprim(Pmakeblock(0, Immutable, None), - List.map - (fun (pos, cc) -> - match cc with - Tcoerce_primitive p -> - Translprim.transl_primitive p.pc_loc - p.pc_desc p.pc_env p.pc_type None - | _ -> apply_coercion loc Strict cc (get_field pos)) - pos_cc_list, loc) - and id_pos_list = - List.filter (fun (id,_,_) -> not (Ident.Set.mem id ids)) - id_pos_list - in - wrap_id_pos_list loc id_pos_list get_field lam, - List.length pos_cc_list - | _ -> - fatal_error "Translmod.transl_structure" - in - (* This debugging event provides information regarding the structure - items. It is ignored by the OCaml debugger but is used by - Js_of_ocaml to preserve variable names. *) - (if !Clflags.debug && not !Clflags.native_code then - Levent(body, - {lev_loc = loc; - lev_kind = Lev_pseudo; - lev_repr = None; - lev_env = final_env}) - else - body), - size - | item :: rem -> - match item.str_desc with - | Tstr_eval (expr, _) -> - let body, size = - transl_structure loc fields cc rootpath final_env rem - in - Lsequence(transl_exp expr, body), size - | Tstr_value(rec_flag, pat_expr_list) -> - (* Translate bindings first *) - let mk_lam_let = transl_let rec_flag pat_expr_list in - let ext_fields = rev_let_bound_idents pat_expr_list @ fields in - (* Then, translate remainder of struct *) - let body, size = - transl_structure loc ext_fields cc rootpath final_env rem - in - mk_lam_let body, size - | Tstr_primitive descr -> - record_primitive descr.val_val; - transl_structure loc fields cc rootpath final_env rem - | Tstr_type _ -> - transl_structure loc fields cc rootpath final_env rem - | Tstr_typext(tyext) -> - let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in - let body, size = - transl_structure loc (List.rev_append ids fields) - cc rootpath final_env rem - in - transl_type_extension item.str_env rootpath tyext body, size - | Tstr_exception ext -> - let id = ext.tyexn_constructor.ext_id in - let path = field_path rootpath id in - let body, size = - transl_structure loc (id :: fields) cc rootpath final_env rem - in - Llet(Strict, Pgenval, id, - transl_extension_constructor item.str_env - path - ext.tyexn_constructor, body), - size - | Tstr_module ({mb_presence=Mp_present} as mb) -> - let id = mb.mb_id in - (* Translate module first *) - let module_body = - transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr - in - let module_body = - Translattribute.add_inline_attribute module_body mb.mb_loc - mb.mb_attributes - in - (* Translate remainder second *) - let body, size = - transl_structure loc (id :: fields) cc rootpath final_env rem - in - let module_body = - Levent (module_body, { - lev_loc = mb.mb_loc; - lev_kind = Lev_module_definition id; - lev_repr = None; - lev_env = Env.empty; - }) - in - Llet(pure_module mb.mb_expr, Pgenval, id, - module_body, - body), size - | Tstr_module {mb_presence=Mp_absent} -> - transl_structure loc fields cc rootpath final_env rem - | Tstr_recmodule bindings -> - let ext_fields = - List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields - in - let body, size = - transl_structure loc ext_fields cc rootpath final_env rem - in - let lam = - compile_recmodule - (fun id modl loc -> - let module_body = - transl_module Tcoerce_none (field_path rootpath id) modl - in - Levent (module_body, { - lev_loc = loc; - lev_kind = Lev_module_definition id; - lev_repr = None; - lev_env = Env.empty; - })) - bindings - body - in - lam, size - | Tstr_class cl_list -> - let (ids, class_bindings) = transl_class_bindings cl_list in - let body, size = - transl_structure loc (List.rev_append ids fields) - cc rootpath final_env rem - in - Lletrec(class_bindings, body), size - | Tstr_include incl -> - let ids = bound_value_identifiers incl.incl_type in - let modl = incl.incl_mod in - let mid = Ident.create_local "include" in - let rec rebind_idents pos newfields = function - [] -> - transl_structure loc newfields cc rootpath final_env rem - | id :: ids -> - let body, size = - rebind_idents (pos + 1) (id :: newfields) ids - in - Llet(Alias, Pgenval, id, - Lprim(Pfield pos, [Lvar mid], incl.incl_loc), body), - size - in - let body, size = rebind_idents 0 fields ids in - Llet(pure_module modl, Pgenval, mid, - transl_module Tcoerce_none None modl, body), - size - - | Tstr_open od -> - let pure = pure_module od.open_expr in - (* this optimization shouldn't be needed because Simplif would - actually remove the [Llet] when it's not used. - But since [scan_used_globals] runs before Simplif, we need to do - it. *) - begin match od.open_bound_items with - | [] when pure = Alias -> - transl_structure loc fields cc rootpath final_env rem - | _ -> - let ids = bound_value_identifiers od.open_bound_items in - let mid = Ident.create_local "open" in - let rec rebind_idents pos newfields = function - [] -> - transl_structure loc newfields cc rootpath final_env rem - | id :: ids -> - let body, size = - rebind_idents (pos + 1) (id :: newfields) ids - in - Llet(Alias, Pgenval, id, - Lprim(Pfield pos, [Lvar mid], od.open_loc), body), - size - in - let body, size = rebind_idents 0 fields ids in - Llet(pure, Pgenval, mid, - transl_module Tcoerce_none None od.open_expr, body), size - end - | Tstr_modtype _ - | Tstr_class_type _ - | Tstr_attribute _ -> - transl_structure loc fields cc rootpath final_env rem - -(* Update forward declaration in Translcore *) -let _ = - Translcore.transl_module := transl_module - -(* Introduce dependencies on modules referenced only by "external". *) - -let scan_used_globals lam = - let globals = ref Ident.Set.empty in - let rec scan lam = - Lambda.iter_head_constructor scan lam; - match lam with - Lprim ((Pgetglobal id | Psetglobal id), _, _) -> - globals := Ident.Set.add id !globals - | _ -> () - in - scan lam; !globals - -let required_globals ~flambda body = - let globals = scan_used_globals body in - let add_global id req = - if not flambda && Ident.Set.mem id globals then - req - else - Ident.Set.add id req - in - let required = - List.fold_left - (fun acc path -> add_global (Path.head path) acc) - (if flambda then globals else Ident.Set.empty) - (Translprim.get_used_primitives ()) - in - let required = - List.fold_right add_global (Env.get_required_globals ()) required - in - Env.reset_required_globals (); - Translprim.clear_used_primitives (); - required - -(* Compile an implementation *) - -let transl_implementation_flambda module_name (str, cc) = - reset_labels (); - primitive_declarations := []; - Translprim.clear_used_primitives (); - let module_id = Ident.create_persistent module_name in - let body, size = - Translobj.transl_label_init - (fun () -> transl_struct Location.none [] cc - (global_path module_id) str) - in - { module_ident = module_id; - main_module_block_size = size; - required_globals = required_globals ~flambda:true body; - code = body } - -let transl_implementation module_name (str, cc) = - let implementation = - transl_implementation_flambda module_name (str, cc) - in - let code = - Lprim (Psetglobal implementation.module_ident, [implementation.code], - Location.none) - in - { implementation with code } - -(* Build the list of value identifiers defined by a toplevel structure - (excluding primitive declarations). *) - -let rec defined_idents = function - [] -> [] - | item :: rem -> - match item.str_desc with - | Tstr_eval _ -> defined_idents rem - | Tstr_value(_rec_flag, pat_expr_list) -> - let_bound_idents pat_expr_list @ defined_idents rem - | Tstr_primitive _ -> defined_idents rem - | Tstr_type _ -> defined_idents rem - | Tstr_typext tyext -> - List.map (fun ext -> ext.ext_id) tyext.tyext_constructors - @ defined_idents rem - | Tstr_exception ext -> ext.tyexn_constructor.ext_id :: defined_idents rem - | Tstr_module {mb_id; mb_presence=Mp_present} -> mb_id :: defined_idents rem - | Tstr_module {mb_presence=Mp_absent} -> defined_idents rem - | Tstr_recmodule decls -> - List.map (fun mb -> mb.mb_id) decls @ defined_idents rem - | Tstr_modtype _ -> defined_idents rem - | Tstr_open od -> - bound_value_identifiers od.open_bound_items @ defined_idents rem - | Tstr_class cl_list -> - List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ defined_idents rem - | Tstr_class_type _ -> defined_idents rem - | Tstr_include incl -> - bound_value_identifiers incl.incl_type @ defined_idents rem - | Tstr_attribute _ -> defined_idents rem - -(* second level idents (module M = struct ... let id = ... end), - and all sub-levels idents *) -let rec more_idents = function - [] -> [] - | item :: rem -> - match item.str_desc with - | Tstr_eval _ -> more_idents rem - | Tstr_value _ -> more_idents rem - | Tstr_primitive _ -> more_idents rem - | Tstr_type _ -> more_idents rem - | Tstr_typext _ -> more_idents rem - | Tstr_exception _ -> more_idents rem - | Tstr_recmodule _ -> more_idents rem - | Tstr_modtype _ -> more_idents rem - | Tstr_open od -> - let rest = more_idents rem in - begin match od.open_expr.mod_desc with - | Tmod_structure str -> all_idents str.str_items @ rest - | _ -> rest - end - | Tstr_class _ -> more_idents rem - | Tstr_class_type _ -> more_idents rem - | Tstr_include{incl_mod={mod_desc = - Tmod_constraint ({mod_desc = Tmod_structure str}, - _, _, _)}} -> - all_idents str.str_items @ more_idents rem - | Tstr_include _ -> more_idents rem - | Tstr_module - {mb_presence=Mp_present; mb_expr={mod_desc = Tmod_structure str}} - | Tstr_module - {mb_presence=Mp_present; - mb_expr={mod_desc= - Tmod_constraint ({mod_desc = Tmod_structure str}, _, _, _)}} -> - all_idents str.str_items @ more_idents rem - | Tstr_module _ -> more_idents rem - | Tstr_attribute _ -> more_idents rem - -and all_idents = function - [] -> [] - | item :: rem -> - match item.str_desc with - | Tstr_eval _ -> all_idents rem - | Tstr_value(_rec_flag, pat_expr_list) -> - let_bound_idents pat_expr_list @ all_idents rem - | Tstr_primitive _ -> all_idents rem - | Tstr_type _ -> all_idents rem - | Tstr_typext tyext -> - List.map (fun ext -> ext.ext_id) tyext.tyext_constructors - @ all_idents rem - | Tstr_exception ext -> ext.tyexn_constructor.ext_id :: all_idents rem - | Tstr_recmodule decls -> - List.map (fun mb -> mb.mb_id) decls @ all_idents rem - | Tstr_modtype _ -> all_idents rem - | Tstr_open od -> - let rest = all_idents rem in - begin match od.open_expr.mod_desc with - | Tmod_structure str -> - bound_value_identifiers od.open_bound_items - @ all_idents str.str_items - @ rest - | _ -> bound_value_identifiers od.open_bound_items @ rest - end - | Tstr_class cl_list -> - List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ all_idents rem - | Tstr_class_type _ -> all_idents rem - - | Tstr_include{incl_type; incl_mod={mod_desc = - Tmod_constraint ({mod_desc = Tmod_structure str}, - _, _, _)}} -> - bound_value_identifiers incl_type - @ all_idents str.str_items - @ all_idents rem - | Tstr_include incl -> - bound_value_identifiers incl.incl_type @ all_idents rem - - | Tstr_module - {mb_id;mb_presence=Mp_present;mb_expr={mod_desc = Tmod_structure str}} - | Tstr_module - {mb_id;mb_presence=Mp_present; - mb_expr= - {mod_desc = - Tmod_constraint ({mod_desc = Tmod_structure str}, _, _, _)}} -> - mb_id :: all_idents str.str_items @ all_idents rem - | Tstr_module {mb_id;mb_presence=Mp_present} -> mb_id :: all_idents rem - | Tstr_module {mb_presence=Mp_absent} -> all_idents rem - | Tstr_attribute _ -> all_idents rem - - -(* A variant of transl_structure used to compile toplevel structure definitions - for the native-code compiler. Store the defined values in the fields - of the global as soon as they are defined, in order to reduce register - pressure. Also rewrites the defining expressions so that they - refer to earlier fields of the structure through the fields of - the global, not by their names. - "map" is a table from defined idents to (pos in global block, coercion). - "prim" is a list of (pos in global block, primitive declaration). *) - -let transl_store_subst = ref Ident.Map.empty - (** In the native toplevel, this reference is threaded through successive - calls of transl_store_structure *) - -let nat_toplevel_name id = - try match Ident.Map.find id !transl_store_subst with - | Lprim(Pfield pos, [Lprim(Pgetglobal glob, [], _)], _) -> (glob,pos) - | _ -> raise Not_found - with Not_found -> - fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id) - -let field_of_str loc str = - let ids = Array.of_list (defined_idents str.str_items) in - fun (pos, cc) -> - match cc with - | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } -> - Translprim.transl_primitive pc_loc pc_desc pc_env pc_type None - | Tcoerce_alias (env, path, cc) -> - let lam = transl_module_path loc env path in - apply_coercion loc Alias cc lam - | _ -> apply_coercion loc Strict cc (Lvar ids.(pos)) - - -let transl_store_structure glob map prims aliases str = - let no_env_update _ _ env = env in - let rec transl_store rootpath subst cont = function - [] -> - transl_store_subst := subst; - Lambda.subst no_env_update subst cont - | item :: rem -> - match item.str_desc with - | Tstr_eval (expr, _attrs) -> - Lsequence(Lambda.subst no_env_update subst (transl_exp expr), - transl_store rootpath subst cont rem) - | Tstr_value(rec_flag, pat_expr_list) -> - let ids = let_bound_idents pat_expr_list in - let lam = - transl_let rec_flag pat_expr_list - (store_idents Location.none ids) - in - Lsequence(Lambda.subst no_env_update subst lam, - transl_store rootpath - (add_idents false ids subst) cont rem) - | Tstr_primitive descr -> - record_primitive descr.val_val; - transl_store rootpath subst cont rem - | Tstr_type _ -> - transl_store rootpath subst cont rem - | Tstr_typext(tyext) -> - let ids = - List.map (fun ext -> ext.ext_id) tyext.tyext_constructors - in - let lam = - transl_type_extension item.str_env rootpath tyext - (store_idents Location.none ids) - in - Lsequence(Lambda.subst no_env_update subst lam, - transl_store rootpath - (add_idents false ids subst) cont rem) - | Tstr_exception ext -> - let id = ext.tyexn_constructor.ext_id in - let path = field_path rootpath id in - let lam = - transl_extension_constructor item.str_env - path - ext.tyexn_constructor - in - Lsequence(Llet(Strict, Pgenval, id, - Lambda.subst no_env_update subst lam, - store_ident ext.tyexn_constructor.ext_loc id), - transl_store rootpath - (add_ident false id subst) cont rem) - | Tstr_module{mb_id=id;mb_loc=loc;mb_presence=Mp_present; - mb_expr={mod_desc = Tmod_structure str} as mexp; - mb_attributes} -> - List.iter (Translattribute.check_attribute_on_module mexp) - mb_attributes; - let lam = - transl_store (field_path rootpath id) subst - lambda_unit str.str_items - in - (* Careful: see next case *) - let subst = !transl_store_subst in - Lsequence(lam, - Llet(Strict, Pgenval, id, - Lambda.subst no_env_update subst - (Lprim(Pmakeblock(0, Immutable, None), - List.map (fun id -> Lvar id) - (defined_idents str.str_items), loc)), - Lsequence(store_ident loc id, - transl_store rootpath - (add_ident true id subst) - cont rem))) - | Tstr_module{ - mb_id=id;mb_loc=loc;mb_presence=Mp_present; - mb_expr= { - mod_desc = Tmod_constraint ( - {mod_desc = Tmod_structure str} as mexp, _, _, - (Tcoerce_structure (map, _) as _cc))}; - mb_attributes - } -> - (* Format.printf "coerc id %s: %a@." (Ident.unique_name id) - Includemod.print_coercion cc; *) - List.iter (Translattribute.check_attribute_on_module mexp) - mb_attributes; - let lam = - transl_store (field_path rootpath id) subst - lambda_unit str.str_items - in - (* Careful: see next case *) - let subst = !transl_store_subst in - let field = field_of_str loc str in - Lsequence(lam, - Llet(Strict, Pgenval, id, - Lambda.subst no_env_update subst - (Lprim(Pmakeblock(0, Immutable, None), - List.map field map, loc)), - Lsequence(store_ident loc id, - transl_store rootpath - (add_ident true id subst) - cont rem))) - | Tstr_module - {mb_id=id; mb_presence=Mp_present; mb_expr=modl; - mb_loc=loc; mb_attributes} -> - let lam = - Translattribute.add_inline_attribute - (transl_module Tcoerce_none (field_path rootpath id) modl) - loc mb_attributes - in - (* Careful: the module value stored in the global may be different - from the local module value, in case a coercion is applied. - If so, keep using the local module value (id) in the remainder of - the compilation unit (add_ident true returns subst unchanged). - If not, we can use the value from the global - (add_ident true adds id -> Pgetglobal... to subst). *) - Llet(Strict, Pgenval, id, Lambda.subst no_env_update subst lam, - Lsequence(store_ident loc id, - transl_store rootpath (add_ident true id subst) - cont rem)) - | Tstr_module {mb_presence=Mp_absent} -> - transl_store rootpath subst cont rem - | Tstr_recmodule bindings -> - let ids = List.map (fun mb -> mb.mb_id) bindings in - compile_recmodule - (fun id modl _loc -> - Lambda.subst no_env_update subst - (transl_module Tcoerce_none - (field_path rootpath id) modl)) - bindings - (Lsequence(store_idents Location.none ids, - transl_store rootpath (add_idents true ids subst) - cont rem)) - | Tstr_class cl_list -> - let (ids, class_bindings) = transl_class_bindings cl_list in - let lam = - Lletrec(class_bindings, store_idents Location.none ids) - in - Lsequence(Lambda.subst no_env_update subst lam, - transl_store rootpath (add_idents false ids subst) - cont rem) - - | Tstr_include{ - incl_loc=loc; - incl_mod= { - mod_desc = Tmod_constraint ( - ({mod_desc = Tmod_structure str} as mexp), _, _, - (Tcoerce_structure (map, _)))}; - incl_attributes; - incl_type; - } -> - List.iter (Translattribute.check_attribute_on_module mexp) - incl_attributes; - (* Shouldn't we use mod_attributes instead of incl_attributes? - Same question for the Tstr_module cases above, btw. *) - let lam = - transl_store None subst lambda_unit str.str_items - (* It is tempting to pass rootpath instead of None - in order to give a more precise name to exceptions - in the included structured, but this would introduce - a difference of behavior compared to bytecode. *) - in - let subst = !transl_store_subst in - let field = field_of_str loc str in - let ids0 = bound_value_identifiers incl_type in - let rec loop ids args = - match ids, args with - | [], [] -> - transl_store rootpath (add_idents true ids0 subst) - cont rem - | id :: ids, arg :: args -> - Llet(Alias, Pgenval, id, - Lambda.subst no_env_update subst (field arg), - Lsequence(store_ident loc id, - loop ids args)) - | _ -> assert false - in - Lsequence(lam, loop ids0 map) - - - | Tstr_include incl -> - let ids = bound_value_identifiers incl.incl_type in - let modl = incl.incl_mod in - let mid = Ident.create_local "include" in - let loc = incl.incl_loc in - let rec store_idents pos = function - | [] -> - transl_store rootpath (add_idents true ids subst) cont rem - | id :: idl -> - Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid], loc), - Lsequence(store_ident loc id, - store_idents (pos + 1) idl)) - in - Llet(Strict, Pgenval, mid, - Lambda.subst no_env_update subst - (transl_module Tcoerce_none None modl), - store_idents 0 ids) - | Tstr_open od -> - begin match od.open_expr.mod_desc with - | Tmod_structure str -> - let lam = - transl_store rootpath subst lambda_unit str.str_items - in - let ids = Array.of_list (defined_idents str.str_items) in - let ids0 = bound_value_identifiers od.open_bound_items in - let subst = !transl_store_subst in - let rec store_idents pos = function - | [] -> transl_store rootpath subst cont rem - | id :: idl -> - Llet(Alias, Pgenval, id, Lvar ids.(pos), - Lsequence(store_ident od.open_loc id, - store_idents (pos + 1) idl)) - in - Lsequence(lam, Lambda.subst no_env_update subst - (store_idents 0 ids0)) - | _ -> - let pure = pure_module od.open_expr in - (* this optimization shouldn't be needed because Simplif would - actually remove the [Llet] when it's not used. - But since [scan_used_globals] runs before Simplif, we need to - do it. *) - match od.open_bound_items with - | [] when pure = Alias -> transl_store rootpath subst cont rem - | _ -> - let ids = bound_value_identifiers od.open_bound_items in - let mid = Ident.create_local "open" in - let loc = od.open_loc in - let rec store_idents pos = function - [] -> - transl_store rootpath (add_idents true ids subst) cont - rem - | id :: idl -> - Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid], - loc), - Lsequence(store_ident loc id, - store_idents (pos + 1) idl)) - in - Llet(pure, Pgenval, mid, - Lambda.subst no_env_update subst - (transl_module Tcoerce_none None od.open_expr), - store_idents 0 ids) - end - | Tstr_modtype _ - | Tstr_class_type _ - | Tstr_attribute _ -> - transl_store rootpath subst cont rem - - and store_ident loc id = - try - let (pos, cc) = Ident.find_same id map in - let init_val = apply_coercion loc Alias cc (Lvar id) in - Lprim(Psetfield(pos, Pointer, Root_initialization), - [Lprim(Pgetglobal glob, [], loc); init_val], - loc) - with Not_found -> - fatal_error("Translmod.store_ident: " ^ Ident.unique_name id) - - and store_idents loc idlist = - make_sequence (store_ident loc) idlist - - and add_ident may_coerce id subst = - try - let (pos, cc) = Ident.find_same id map in - match cc with - Tcoerce_none -> - Ident.Map.add id - (Lprim(Pfield pos, - [Lprim(Pgetglobal glob, [], Location.none)], - Location.none)) - subst - | _ -> - if may_coerce then subst else assert false - with Not_found -> - assert false - - and add_idents may_coerce idlist subst = - List.fold_right (add_ident may_coerce) idlist subst - - and store_primitive (pos, prim) cont = - Lsequence(Lprim(Psetfield(pos, Pointer, Root_initialization), - [Lprim(Pgetglobal glob, [], Location.none); - Translprim.transl_primitive Location.none - prim.pc_desc prim.pc_env prim.pc_type None], - Location.none), - cont) - - and store_alias (pos, env, path, cc) = - let path_lam = transl_module_path Location.none env path in - let init_val = apply_coercion Location.none Strict cc path_lam in - Lprim(Psetfield(pos, Pointer, Root_initialization), - [Lprim(Pgetglobal glob, [], Location.none); - init_val], - Location.none) - in - let aliases = make_sequence store_alias aliases in - List.fold_right store_primitive prims - (transl_store (global_path glob) !transl_store_subst aliases str) - -(* Transform a coercion and the list of value identifiers defined by - a toplevel structure into a table [id -> (pos, coercion)], - with [pos] being the position in the global block where the value of - [id] must be stored, and [coercion] the coercion to be applied to it. - A given identifier may appear several times - in the coercion (if it occurs several times in the signature); remember - to assign it the position of its last occurrence. - Identifiers that are not exported are assigned positions at the - end of the block (beyond the positions of all exported idents). - Also compute the total size of the global block, - and the list of all primitives exported as values. *) - -let build_ident_map restr idlist more_ids = - let rec natural_map pos map prims aliases = function - | [] -> - (map, prims, aliases, pos) - | id :: rem -> - natural_map (pos+1) - (Ident.add id (pos, Tcoerce_none) map) prims aliases rem - in - let (map, prims, aliases, pos) = - match restr with - | Tcoerce_none -> - natural_map 0 Ident.empty [] [] idlist - | Tcoerce_structure (pos_cc_list, _id_pos_list) -> - (* ignore _id_pos_list as the ids are already bound *) - let idarray = Array.of_list idlist in - let rec export_map pos map prims aliases undef = function - | [] -> - natural_map pos map prims aliases undef - | (_source_pos, Tcoerce_primitive p) :: rem -> - export_map (pos + 1) map - ((pos, p) :: prims) aliases undef rem - | (_source_pos, Tcoerce_alias(env, path, cc)) :: rem -> - export_map (pos + 1) map prims - ((pos, env, path, cc) :: aliases) undef rem - | (source_pos, cc) :: rem -> - let id = idarray.(source_pos) in - export_map (pos + 1) (Ident.add id (pos, cc) map) - prims aliases (list_remove id undef) rem - in - export_map 0 Ident.empty [] [] idlist pos_cc_list - | _ -> - fatal_error "Translmod.build_ident_map" - in - natural_map pos map prims aliases more_ids - -(* Compile an implementation using transl_store_structure - (for the native-code compiler). *) - -let transl_store_gen module_name ({ str_items = str }, restr) topl = - reset_labels (); - primitive_declarations := []; - Translprim.clear_used_primitives (); - let module_id = Ident.create_persistent module_name in - let (map, prims, aliases, size) = - build_ident_map restr (defined_idents str) (more_idents str) in - let f = function - | [ { str_desc = Tstr_eval (expr, _attrs) } ] when topl -> - assert (size = 0); - Lambda.subst (fun _ _ env -> env) !transl_store_subst (transl_exp expr) - | str -> transl_store_structure module_id map prims aliases str - in - transl_store_label_init module_id size f str - (*size, transl_label_init (transl_store_structure module_id map prims str)*) - -let transl_store_phrases module_name str = - transl_store_gen module_name (str,Tcoerce_none) true - -let transl_store_implementation module_name (str, restr) = - let s = !transl_store_subst in - transl_store_subst := Ident.Map.empty; - let (i, code) = transl_store_gen module_name (str, restr) false in - transl_store_subst := s; - { Lambda.main_module_block_size = i; - code; - (* module_ident is not used by closure, but this allow to share - the type with the flambda version *) - module_ident = Ident.create_persistent module_name; - required_globals = required_globals ~flambda:true code } - -(* Compile a toplevel phrase *) - -let toploop_ident = Ident.create_persistent "Toploop" -let toploop_getvalue_pos = 0 (* position of getvalue in module Toploop *) -let toploop_setvalue_pos = 1 (* position of setvalue in module Toploop *) - -let aliased_idents = ref Ident.empty - -let set_toplevel_unique_name id = - aliased_idents := - Ident.add id (Ident.unique_toplevel_name id) !aliased_idents - -let toplevel_name id = - try Ident.find_same id !aliased_idents - with Not_found -> Ident.name id - -let toploop_getvalue id = - Lapply{ap_should_be_tailcall=false; - ap_loc=Location.none; - ap_func=Lprim(Pfield toploop_getvalue_pos, - [Lprim(Pgetglobal toploop_ident, [], Location.none)], - Location.none); - ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)))]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} - -let toploop_setvalue id lam = - Lapply{ap_should_be_tailcall=false; - ap_loc=Location.none; - ap_func=Lprim(Pfield toploop_setvalue_pos, - [Lprim(Pgetglobal toploop_ident, [], Location.none)], - Location.none); - ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None))); - lam]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} - -let toploop_setvalue_id id = toploop_setvalue id (Lvar id) - -let close_toplevel_term (lam, ()) = - Ident.Set.fold (fun id l -> Llet(Strict, Pgenval, id, - toploop_getvalue id, l)) - (free_variables lam) lam - -let transl_toplevel_item item = - match item.str_desc with - Tstr_eval (expr, _) - | Tstr_value(Nonrecursive, - [{vb_pat = {pat_desc=Tpat_any};vb_expr = expr}]) -> - (* special compilation for toplevel "let _ = expr", so - that Toploop can display the result of the expression. - Otherwise, the normal compilation would result - in a Lsequence returning unit. *) - transl_exp expr - | Tstr_value(rec_flag, pat_expr_list) -> - let idents = let_bound_idents pat_expr_list in - transl_let rec_flag pat_expr_list - (make_sequence toploop_setvalue_id idents) - | Tstr_typext(tyext) -> - let idents = - List.map (fun ext -> ext.ext_id) tyext.tyext_constructors - in - (* we need to use unique name in case of multiple - definitions of the same extension constructor in the toplevel *) - List.iter set_toplevel_unique_name idents; - transl_type_extension item.str_env None tyext - (make_sequence toploop_setvalue_id idents) - | Tstr_exception ext -> - set_toplevel_unique_name ext.tyexn_constructor.ext_id; - toploop_setvalue ext.tyexn_constructor.ext_id - (transl_extension_constructor item.str_env None ext.tyexn_constructor) - | Tstr_module {mb_id=id; mb_presence=Mp_present; mb_expr=modl} -> - (* we need to use the unique name for the module because of issues - with "open" (PR#1672) *) - set_toplevel_unique_name id; - let lam = transl_module Tcoerce_none (Some(Pident id)) modl in - toploop_setvalue id lam - | Tstr_recmodule bindings -> - let idents = List.map (fun mb -> mb.mb_id) bindings in - compile_recmodule - (fun id modl _loc -> transl_module Tcoerce_none (Some(Pident id)) modl) - bindings - (make_sequence toploop_setvalue_id idents) - | Tstr_class cl_list -> - (* we need to use unique names for the classes because there might - be a value named identically *) - let (ids, class_bindings) = transl_class_bindings cl_list in - List.iter set_toplevel_unique_name ids; - Lletrec(class_bindings, make_sequence toploop_setvalue_id ids) - | Tstr_include incl -> - let ids = bound_value_identifiers incl.incl_type in - let modl = incl.incl_mod in - let mid = Ident.create_local "include" in - let rec set_idents pos = function - [] -> - lambda_unit - | id :: ids -> - Lsequence(toploop_setvalue id - (Lprim(Pfield pos, [Lvar mid], Location.none)), - set_idents (pos + 1) ids) in - Llet(Strict, Pgenval, mid, - transl_module Tcoerce_none None modl, set_idents 0 ids) - | Tstr_primitive descr -> - record_primitive descr.val_val; - lambda_unit - | Tstr_open od -> - let pure = pure_module od.open_expr in - (* this optimization shouldn't be needed because Simplif would - actually remove the [Llet] when it's not used. - But since [scan_used_globals] runs before Simplif, we need to do - it. *) - begin match od.open_bound_items with - | [] when pure = Alias -> lambda_unit - | _ -> - let ids = bound_value_identifiers od.open_bound_items in - let mid = Ident.create_local "open" in - let rec set_idents pos = function - [] -> - lambda_unit - | id :: ids -> - Lsequence(toploop_setvalue id - (Lprim(Pfield pos, [Lvar mid], Location.none)), - set_idents (pos + 1) ids) - in - Llet(pure, Pgenval, mid, - transl_module Tcoerce_none None od.open_expr, set_idents 0 ids) - end - | Tstr_modtype _ - | Tstr_module {mb_presence=Mp_absent} - | Tstr_type _ - | Tstr_class_type _ - | Tstr_attribute _ -> - lambda_unit - -let transl_toplevel_item_and_close itm = - close_toplevel_term - (transl_label_init (fun () -> transl_toplevel_item itm, ())) - -let transl_toplevel_definition str = - reset_labels (); - Translprim.clear_used_primitives (); - make_sequence transl_toplevel_item_and_close str.str_items - -(* Compile the initialization code for a packed library *) - -let get_component = function - None -> Lconst const_unit - | Some id -> Lprim(Pgetglobal id, [], Location.none) - -let transl_package_flambda component_names coercion = - let size = - match coercion with - | Tcoerce_none -> List.length component_names - | Tcoerce_structure (l, _) -> List.length l - | Tcoerce_functor _ - | Tcoerce_primitive _ - | Tcoerce_alias _ -> assert false - in - size, - apply_coercion Location.none Strict coercion - (Lprim(Pmakeblock(0, Immutable, None), - List.map get_component component_names, - Location.none)) - -let transl_package component_names target_name coercion = - let components = - Lprim(Pmakeblock(0, Immutable, None), - List.map get_component component_names, Location.none) in - Lprim(Psetglobal target_name, - [apply_coercion Location.none Strict coercion components], - Location.none) - (* - let components = - match coercion with - Tcoerce_none -> - List.map get_component component_names - | Tcoerce_structure (pos_cc_list, id_pos_list) -> - (* ignore id_pos_list as the ids are already bound *) - let g = Array.of_list component_names in - List.map - (fun (pos, cc) -> apply_coercion Strict cc (get_component g.(pos))) - pos_cc_list - | _ -> - assert false in - Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)]) - *) - -let transl_store_package component_names target_name coercion = - let rec make_sequence fn pos arg = - match arg with - [] -> lambda_unit - | hd :: tl -> Lsequence(fn pos hd, make_sequence fn (pos + 1) tl) in - match coercion with - Tcoerce_none -> - (List.length component_names, - make_sequence - (fun pos id -> - Lprim(Psetfield(pos, Pointer, Root_initialization), - [Lprim(Pgetglobal target_name, [], Location.none); - get_component id], - Location.none)) - 0 component_names) - | Tcoerce_structure (pos_cc_list, _id_pos_list) -> - let components = - Lprim(Pmakeblock(0, Immutable, None), - List.map get_component component_names, - Location.none) - in - let blk = Ident.create_local "block" in - (List.length pos_cc_list, - Llet (Strict, Pgenval, blk, - apply_coercion Location.none Strict coercion components, - make_sequence - (fun pos _id -> - Lprim(Psetfield(pos, Pointer, Root_initialization), - [Lprim(Pgetglobal target_name, [], Location.none); - Lprim(Pfield pos, [Lvar blk], Location.none)], - Location.none)) - 0 pos_cc_list)) - (* - (* ignore id_pos_list as the ids are already bound *) - let id = Array.of_list component_names in - (List.length pos_cc_list, - make_sequence - (fun dst (src, cc) -> - Lprim(Psetfield(dst, false), - [Lprim(Pgetglobal target_name, []); - apply_coercion Strict cc (get_component id.(src))])) - 0 pos_cc_list) - *) - | _ -> assert false - -(* Error report *) - -open Format - -let print_cycle ppf cycle = - let print_ident ppf (x,_) = Format.pp_print_string ppf (Ident.name x) in - let pp_sep ppf () = fprintf ppf "@ -> " in - Format.fprintf ppf "%a%a%s" - (Format.pp_print_list ~pp_sep print_ident) cycle - pp_sep () - (Ident.name @@ fst @@ List.hd cycle) -(* we repeat the first element to make the cycle more apparent *) - -let explanation_submsg (id, {reason;loc;subid}) = - let print fmt = - let printer = Format.dprintf fmt (Ident.name id) (Ident.name subid) in - Location.mkloc printer loc in - match reason with - | Unsafe_module_binding -> print "Module %s defines an unsafe module, %s ." - | Unsafe_functor -> print "Module %s defines an unsafe functor, %s ." - | Unsafe_typext -> - print "Module %s defines an unsafe extension constructor, %s ." - | Unsafe_non_function -> print "Module %s defines an unsafe value, %s ." - -let report_error loc = function - | Circular_dependency cycle -> - let[@manual.ref "s-recursive-modules"] chapter, section = 8, 2 in - Location.errorf ~loc ~sub:(List.map explanation_submsg cycle) - "Cannot safely evaluate the definition of the following cycle@ \ - of recursively-defined modules:@ %a.@ \ - There are no safe modules in this cycle@ (see manual section %d.%d)." - print_cycle cycle chapter section - | Conflicting_inline_attributes -> - Location.errorf "@[Conflicting 'inline' attributes@]" - -let () = - Location.register_error_of_exn - (function - | Error (loc, err) -> Some (report_error loc err) - | _ -> - None - ) - -let reset () = - primitive_declarations := []; - transl_store_subst := Ident.Map.empty; - aliased_idents := Ident.empty; - Env.reset_required_globals (); - Translprim.clear_used_primitives () diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli deleted file mode 100644 index d0898c76..00000000 --- a/bytecomp/translmod.mli +++ /dev/null @@ -1,61 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Translation from typed abstract syntax to lambda terms, - for the module language *) - -open Typedtree -open Lambda - -val transl_implementation: - string -> structure * module_coercion -> Lambda.program -val transl_store_phrases: string -> structure -> int * lambda -val transl_store_implementation: - string -> structure * module_coercion -> Lambda.program - -val transl_implementation_flambda: - string -> structure * module_coercion -> Lambda.program - -val transl_toplevel_definition: structure -> lambda -val transl_package: - Ident.t option list -> Ident.t -> module_coercion -> lambda -val transl_store_package: - Ident.t option list -> Ident.t -> module_coercion -> int * lambda - -val transl_package_flambda: - Ident.t option list -> module_coercion -> int * lambda - -val toplevel_name: Ident.t -> string -val nat_toplevel_name: Ident.t -> Ident.t * int - -val primitive_declarations: Primitive.description list ref - -type unsafe_component = - | Unsafe_module_binding - | Unsafe_functor - | Unsafe_non_function - | Unsafe_typext - -type unsafe_info = { reason:unsafe_component; loc:Location.t; subid:Ident.t } - -type error = - Circular_dependency of (Ident.t * unsafe_info) list -| Conflicting_inline_attributes - -exception Error of Location.t * error - -val report_error: Location.t -> error -> Location.error - -val reset: unit -> unit diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml deleted file mode 100644 index ce063538..00000000 --- a/bytecomp/translobj.ml +++ /dev/null @@ -1,199 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Asttypes -open Lambda - -(* Get oo primitives identifiers *) - -let oo_prim = Lambda.transl_prim "CamlinternalOO" - -(* Share blocks *) - -let consts : (structured_constant, Ident.t) Hashtbl.t = Hashtbl.create 17 - -let share c = - match c with - Const_block (_n, l) when l <> [] -> - begin try - Lvar (Hashtbl.find consts c) - with Not_found -> - let id = Ident.create_local "shared" in - Hashtbl.add consts c id; - Lvar id - end - | _ -> Lconst c - -(* Collect labels *) - -let cache_required = ref false -let method_cache = ref lambda_unit -let method_count = ref 0 -let method_table = ref [] - -let meth_tag s = Lconst(Const_base(Const_int(Btype.hash_variant s))) - -let next_cache tag = - let n = !method_count in - incr method_count; - (tag, [!method_cache; Lconst(Const_base(Const_int n))]) - -let rec is_path = function - Lvar _ | Lprim (Pgetglobal _, [], _) | Lconst _ -> true - | Lprim (Pfield _, [lam], _) -> is_path lam - | Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2], _) -> - is_path lam1 && is_path lam2 - | _ -> false - -let meth obj lab = - let tag = meth_tag lab in - if not (!cache_required && !Clflags.native_code) then (tag, []) else - if not (is_path obj) then next_cache tag else - try - let r = List.assoc obj !method_table in - try - (tag, List.assoc tag !r) - with Not_found -> - let p = next_cache tag in - r := p :: !r; - p - with Not_found -> - let p = next_cache tag in - method_table := (obj, ref [p]) :: !method_table; - p - -let reset_labels () = - Hashtbl.clear consts; - method_count := 0; - method_table := [] - -(* Insert labels *) - -let int n = Lconst (Const_base (Const_int n)) - -let prim_makearray = - Primitive.simple ~name:"caml_make_vect" ~arity:2 ~alloc:true - -(* Also use it for required globals *) -let transl_label_init_general f = - let expr, size = f () in - let expr = - Hashtbl.fold - (fun c id expr -> Llet(Alias, Pgenval, id, Lconst c, expr)) - consts expr - in - (*let expr = - List.fold_right - (fun id expr -> Lsequence(Lprim(Pgetglobal id, [], Location.none), expr)) - (Env.get_required_globals ()) expr - in - Env.reset_required_globals ();*) - reset_labels (); - expr, size - -let transl_label_init_flambda f = - assert(Config.flambda); - let method_cache_id = Ident.create_local "method_cache" in - method_cache := Lvar method_cache_id; - (* Calling f (usually Translmod.transl_struct) requires the - method_cache variable to be initialised to be able to generate - method accesses. *) - let expr, size = f () in - let expr = - if !method_count = 0 then expr - else - Llet (Strict, Pgenval, method_cache_id, - Lprim (Pccall prim_makearray, - [int !method_count; int 0], - Location.none), - expr) - in - transl_label_init_general (fun () -> expr, size) - -let transl_store_label_init glob size f arg = - assert(not Config.flambda); - assert(!Clflags.native_code); - method_cache := Lprim(Pfield size, - [Lprim(Pgetglobal glob, [], Location.none)], - Location.none); - let expr = f arg in - let (size, expr) = - if !method_count = 0 then (size, expr) else - (size+1, - Lsequence( - Lprim(Psetfield(size, Pointer, Root_initialization), - [Lprim(Pgetglobal glob, [], Location.none); - Lprim (Pccall prim_makearray, - [int !method_count; int 0], - Location.none)], - Location.none), - expr)) - in - let lam, size = transl_label_init_general (fun () -> (expr, size)) in - size, lam - -let transl_label_init f = - if !Clflags.native_code then - transl_label_init_flambda f - else - transl_label_init_general f - -(* Share classes *) - -let wrapping = ref false -let top_env = ref Env.empty -let classes = ref [] -let method_ids = ref Ident.Set.empty - -let oo_add_class id = - classes := id :: !classes; - (!top_env, !cache_required) - -let oo_wrap env req f x = - if !wrapping then - if !cache_required then f x else - Misc.protect_refs [Misc.R (cache_required, true)] (fun () -> - f x - ) - else - Misc.protect_refs [Misc.R (wrapping, true); Misc.R (top_env, env)] - (fun () -> - cache_required := req; - classes := []; - method_ids := Ident.Set.empty; - let lambda = f x in - let lambda = - List.fold_left - (fun lambda id -> - Llet(StrictOpt, Pgenval, id, - Lprim(Pmakeblock(0, Mutable, None), - [lambda_unit; lambda_unit; lambda_unit], - Location.none), - lambda)) - lambda !classes - in - lambda - ) - -let reset () = - Hashtbl.clear consts; - cache_required := false; - method_cache := lambda_unit; - method_count := 0; - method_table := []; - wrapping := false; - top_env := Env.empty; - classes := []; - method_ids := Ident.Set.empty diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli deleted file mode 100644 index c27053e9..00000000 --- a/bytecomp/translobj.mli +++ /dev/null @@ -1,33 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Lambda - -val oo_prim: string -> lambda - -val share: structured_constant -> lambda -val meth: lambda -> string -> lambda * lambda list - -val reset_labels: unit -> unit -val transl_label_init: (unit -> lambda * 'a) -> lambda * 'a -val transl_store_label_init: - Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda - -val method_ids: Ident.Set.t ref (* reset when starting a new wrapper *) - -val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda -val oo_add_class: Ident.t -> Env.t * bool - -val reset: unit -> unit diff --git a/bytecomp/translprim.ml b/bytecomp/translprim.ml deleted file mode 100644 index 448a2ac8..00000000 --- a/bytecomp/translprim.ml +++ /dev/null @@ -1,805 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Translation of primitives *) - -open Misc -open Asttypes -open Primitive -open Types -open Typedtree -open Typeopt -open Lambda - -type error = - | Unknown_builtin_primitive of string - | Wrong_arity_builtin_primitive of string - -exception Error of Location.t * error - -(* Insertion of debugging events *) - -let event_before exp lam = match lam with -| Lstaticraise (_,_) -> lam -| _ -> - if !Clflags.debug && not !Clflags.native_code - then Levent(lam, {lev_loc = exp.exp_loc; - lev_kind = Lev_before; - lev_repr = None; - lev_env = exp.exp_env}) - else lam - -let event_after exp lam = - if !Clflags.debug && not !Clflags.native_code - then Levent(lam, {lev_loc = exp.exp_loc; - lev_kind = Lev_after exp.exp_type; - lev_repr = None; - lev_env = exp.exp_env}) - else lam - -type comparison = - | Equal - | Not_equal - | Less_equal - | Less_than - | Greater_equal - | Greater_than - | Compare - -type comparison_kind = - | Compare_generic - | Compare_ints - | Compare_floats - | Compare_strings - | Compare_bytes - | Compare_nativeints - | Compare_int32s - | Compare_int64s - -type loc_kind = - | Loc_FILE - | Loc_LINE - | Loc_MODULE - | Loc_LOC - | Loc_POS - -type prim = - | Primitive of Lambda.primitive * int - | External of Primitive.description - | Comparison of comparison * comparison_kind - | Raise of Lambda.raise_kind - | Raise_with_backtrace - | Lazy_force - | Loc of loc_kind - | Send - | Send_self - | Send_cache - -let used_primitives = Hashtbl.create 7 -let add_used_primitive loc env path = - match path with - Some (Path.Pdot _ as path) -> - let path = Env.normalize_path_prefix (Some loc) env path in - let unit = Path.head path in - if Ident.global unit && not (Hashtbl.mem used_primitives path) - then Hashtbl.add used_primitives path loc - | _ -> () - -let clear_used_primitives () = Hashtbl.clear used_primitives -let get_used_primitives () = - Hashtbl.fold (fun path _ acc -> path :: acc) used_primitives [] - -let gen_array_kind = - if Config.flat_float_array then Pgenarray else Paddrarray - -let primitives_table = - create_hashtable 57 [ - "%identity", Primitive (Pidentity, 1); - "%bytes_to_string", Primitive (Pbytes_to_string, 1); - "%bytes_of_string", Primitive (Pbytes_of_string, 1); - "%ignore", Primitive (Pignore, 1); - "%revapply", Primitive (Prevapply, 2); - "%apply", Primitive (Pdirapply, 2); - "%loc_LOC", Loc Loc_LOC; - "%loc_FILE", Loc Loc_FILE; - "%loc_LINE", Loc Loc_LINE; - "%loc_POS", Loc Loc_POS; - "%loc_MODULE", Loc Loc_MODULE; - "%field0", Primitive ((Pfield 0), 1); - "%field1", Primitive ((Pfield 1), 1); - "%setfield0", Primitive ((Psetfield(0, Pointer, Assignment)), 2); - "%makeblock", Primitive ((Pmakeblock(0, Immutable, None)), 1); - "%makemutable", Primitive ((Pmakeblock(0, Mutable, None)), 1); - "%raise", Raise Raise_regular; - "%reraise", Raise Raise_reraise; - "%raise_notrace", Raise Raise_notrace; - "%raise_with_backtrace", Raise_with_backtrace; - "%sequand", Primitive (Psequand, 2); - "%sequor", Primitive (Psequor, 2); - "%boolnot", Primitive (Pnot, 1); - "%big_endian", Primitive ((Pctconst Big_endian), 1); - "%backend_type", Primitive ((Pctconst Backend_type), 1); - "%word_size", Primitive ((Pctconst Word_size), 1); - "%int_size", Primitive ((Pctconst Int_size), 1); - "%max_wosize", Primitive ((Pctconst Max_wosize), 1); - "%ostype_unix", Primitive ((Pctconst Ostype_unix), 1); - "%ostype_win32", Primitive ((Pctconst Ostype_win32), 1); - "%ostype_cygwin", Primitive ((Pctconst Ostype_cygwin), 1); - "%negint", Primitive (Pnegint, 1); - "%succint", Primitive ((Poffsetint 1), 1); - "%predint", Primitive ((Poffsetint(-1)), 1); - "%addint", Primitive (Paddint, 2); - "%subint", Primitive (Psubint, 2); - "%mulint", Primitive (Pmulint, 2); - "%divint", Primitive ((Pdivint Safe), 2); - "%modint", Primitive ((Pmodint Safe), 2); - "%andint", Primitive (Pandint, 2); - "%orint", Primitive (Porint, 2); - "%xorint", Primitive (Pxorint, 2); - "%lslint", Primitive (Plslint, 2); - "%lsrint", Primitive (Plsrint, 2); - "%asrint", Primitive (Pasrint, 2); - "%eq", Primitive ((Pintcomp Ceq), 2); - "%noteq", Primitive ((Pintcomp Cne), 2); - "%ltint", Primitive ((Pintcomp Clt), 2); - "%leint", Primitive ((Pintcomp Cle), 2); - "%gtint", Primitive ((Pintcomp Cgt), 2); - "%geint", Primitive ((Pintcomp Cge), 2); - "%incr", Primitive ((Poffsetref(1)), 1); - "%decr", Primitive ((Poffsetref(-1)), 1); - "%intoffloat", Primitive (Pintoffloat, 1); - "%floatofint", Primitive (Pfloatofint, 1); - "%negfloat", Primitive (Pnegfloat, 1); - "%absfloat", Primitive (Pabsfloat, 1); - "%addfloat", Primitive (Paddfloat, 2); - "%subfloat", Primitive (Psubfloat, 2); - "%mulfloat", Primitive (Pmulfloat, 2); - "%divfloat", Primitive (Pdivfloat, 2); - "%eqfloat", Primitive ((Pfloatcomp CFeq), 2); - "%noteqfloat", Primitive ((Pfloatcomp CFneq), 2); - "%ltfloat", Primitive ((Pfloatcomp CFlt), 2); - "%lefloat", Primitive ((Pfloatcomp CFle), 2); - "%gtfloat", Primitive ((Pfloatcomp CFgt), 2); - "%gefloat", Primitive ((Pfloatcomp CFge), 2); - "%string_length", Primitive (Pstringlength, 1); - "%string_safe_get", Primitive (Pstringrefs, 2); - "%string_safe_set", Primitive (Pbytessets, 3); - "%string_unsafe_get", Primitive (Pstringrefu, 2); - "%string_unsafe_set", Primitive (Pbytessetu, 3); - "%bytes_length", Primitive (Pbyteslength, 1); - "%bytes_safe_get", Primitive (Pbytesrefs, 2); - "%bytes_safe_set", Primitive (Pbytessets, 3); - "%bytes_unsafe_get", Primitive (Pbytesrefu, 2); - "%bytes_unsafe_set", Primitive (Pbytessetu, 3); - "%array_length", Primitive ((Parraylength gen_array_kind), 1); - "%array_safe_get", Primitive ((Parrayrefs gen_array_kind), 2); - "%array_safe_set", Primitive ((Parraysets gen_array_kind), 3); - "%array_unsafe_get", Primitive ((Parrayrefu gen_array_kind), 2); - "%array_unsafe_set", Primitive ((Parraysetu gen_array_kind), 3); - "%obj_size", Primitive ((Parraylength gen_array_kind), 1); - "%obj_field", Primitive ((Parrayrefu gen_array_kind), 2); - "%obj_set_field", Primitive ((Parraysetu gen_array_kind), 3); - "%floatarray_length", Primitive ((Parraylength Pfloatarray), 1); - "%floatarray_safe_get", Primitive ((Parrayrefs Pfloatarray), 2); - "%floatarray_safe_set", Primitive ((Parraysets Pfloatarray), 3); - "%floatarray_unsafe_get", Primitive ((Parrayrefu Pfloatarray), 2); - "%floatarray_unsafe_set", Primitive ((Parraysetu Pfloatarray), 3); - "%obj_is_int", Primitive (Pisint, 1); - "%lazy_force", Lazy_force; - "%nativeint_of_int", Primitive ((Pbintofint Pnativeint), 1); - "%nativeint_to_int", Primitive ((Pintofbint Pnativeint), 1); - "%nativeint_neg", Primitive ((Pnegbint Pnativeint), 1); - "%nativeint_add", Primitive ((Paddbint Pnativeint), 2); - "%nativeint_sub", Primitive ((Psubbint Pnativeint), 2); - "%nativeint_mul", Primitive ((Pmulbint Pnativeint), 2); - "%nativeint_div", - Primitive ((Pdivbint { size = Pnativeint; is_safe = Safe }), 2); - "%nativeint_mod", - Primitive ((Pmodbint { size = Pnativeint; is_safe = Safe }), 2); - "%nativeint_and", Primitive ((Pandbint Pnativeint), 2); - "%nativeint_or", Primitive ( (Porbint Pnativeint), 2); - "%nativeint_xor", Primitive ((Pxorbint Pnativeint), 2); - "%nativeint_lsl", Primitive ((Plslbint Pnativeint), 2); - "%nativeint_lsr", Primitive ((Plsrbint Pnativeint), 2); - "%nativeint_asr", Primitive ((Pasrbint Pnativeint), 2); - "%int32_of_int", Primitive ((Pbintofint Pint32), 1); - "%int32_to_int", Primitive ((Pintofbint Pint32), 1); - "%int32_neg", Primitive ((Pnegbint Pint32), 1); - "%int32_add", Primitive ((Paddbint Pint32), 2); - "%int32_sub", Primitive ((Psubbint Pint32), 2); - "%int32_mul", Primitive ((Pmulbint Pint32), 2); - "%int32_div", Primitive ((Pdivbint { size = Pint32; is_safe = Safe }), 2); - "%int32_mod", Primitive ((Pmodbint { size = Pint32; is_safe = Safe }), 2); - "%int32_and", Primitive ((Pandbint Pint32), 2); - "%int32_or", Primitive ( (Porbint Pint32), 2); - "%int32_xor", Primitive ((Pxorbint Pint32), 2); - "%int32_lsl", Primitive ((Plslbint Pint32), 2); - "%int32_lsr", Primitive ((Plsrbint Pint32), 2); - "%int32_asr", Primitive ((Pasrbint Pint32), 2); - "%int64_of_int", Primitive ((Pbintofint Pint64), 1); - "%int64_to_int", Primitive ((Pintofbint Pint64), 1); - "%int64_neg", Primitive ((Pnegbint Pint64), 1); - "%int64_add", Primitive ((Paddbint Pint64), 2); - "%int64_sub", Primitive ((Psubbint Pint64), 2); - "%int64_mul", Primitive ((Pmulbint Pint64), 2); - "%int64_div", Primitive ((Pdivbint { size = Pint64; is_safe = Safe }), 2); - "%int64_mod", Primitive ((Pmodbint { size = Pint64; is_safe = Safe }), 2); - "%int64_and", Primitive ((Pandbint Pint64), 2); - "%int64_or", Primitive ( (Porbint Pint64), 2); - "%int64_xor", Primitive ((Pxorbint Pint64), 2); - "%int64_lsl", Primitive ((Plslbint Pint64), 2); - "%int64_lsr", Primitive ((Plsrbint Pint64), 2); - "%int64_asr", Primitive ((Pasrbint Pint64), 2); - "%nativeint_of_int32", Primitive ((Pcvtbint(Pint32, Pnativeint)), 1); - "%nativeint_to_int32", Primitive ((Pcvtbint(Pnativeint, Pint32)), 1); - "%int64_of_int32", Primitive ((Pcvtbint(Pint32, Pint64)), 1); - "%int64_to_int32", Primitive ((Pcvtbint(Pint64, Pint32)), 1); - "%int64_of_nativeint", Primitive ((Pcvtbint(Pnativeint, Pint64)), 1); - "%int64_to_nativeint", Primitive ((Pcvtbint(Pint64, Pnativeint)), 1); - "%caml_ba_ref_1", - Primitive - ((Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), - 2); - "%caml_ba_ref_2", - Primitive - ((Pbigarrayref(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), - 3); - "%caml_ba_ref_3", - Primitive - ((Pbigarrayref(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), - 4); - "%caml_ba_set_1", - Primitive - ((Pbigarrayset(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), - 3); - "%caml_ba_set_2", - Primitive - ((Pbigarrayset(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), - 4); - "%caml_ba_set_3", - Primitive - ((Pbigarrayset(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), - 5); - "%caml_ba_unsafe_ref_1", - Primitive - ((Pbigarrayref(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), - 2); - "%caml_ba_unsafe_ref_2", - Primitive - ((Pbigarrayref(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), - 3); - "%caml_ba_unsafe_ref_3", - Primitive - ((Pbigarrayref(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), - 4); - "%caml_ba_unsafe_set_1", - Primitive - ((Pbigarrayset(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), - 3); - "%caml_ba_unsafe_set_2", - Primitive - ((Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), - 4); - "%caml_ba_unsafe_set_3", - Primitive - ((Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), - 5); - "%caml_ba_dim_1", Primitive ((Pbigarraydim(1)), 1); - "%caml_ba_dim_2", Primitive ((Pbigarraydim(2)), 1); - "%caml_ba_dim_3", Primitive ((Pbigarraydim(3)), 1); - "%caml_string_get16", Primitive ((Pstring_load_16(false)), 2); - "%caml_string_get16u", Primitive ((Pstring_load_16(true)), 2); - "%caml_string_get32", Primitive ((Pstring_load_32(false)), 2); - "%caml_string_get32u", Primitive ((Pstring_load_32(true)), 2); - "%caml_string_get64", Primitive ((Pstring_load_64(false)), 2); - "%caml_string_get64u", Primitive ((Pstring_load_64(true)), 2); - "%caml_string_set16", Primitive ((Pbytes_set_16(false)), 3); - "%caml_string_set16u", Primitive ((Pbytes_set_16(true)), 3); - "%caml_string_set32", Primitive ((Pbytes_set_32(false)), 3); - "%caml_string_set32u", Primitive ((Pbytes_set_32(true)), 3); - "%caml_string_set64", Primitive ((Pbytes_set_64(false)), 3); - "%caml_string_set64u", Primitive ((Pbytes_set_64(true)), 3); - "%caml_bytes_get16", Primitive ((Pbytes_load_16(false)), 2); - "%caml_bytes_get16u", Primitive ((Pbytes_load_16(true)), 2); - "%caml_bytes_get32", Primitive ((Pbytes_load_32(false)), 2); - "%caml_bytes_get32u", Primitive ((Pbytes_load_32(true)), 2); - "%caml_bytes_get64", Primitive ((Pbytes_load_64(false)), 2); - "%caml_bytes_get64u", Primitive ((Pbytes_load_64(true)), 2); - "%caml_bytes_set16", Primitive ((Pbytes_set_16(false)), 3); - "%caml_bytes_set16u", Primitive ((Pbytes_set_16(true)), 3); - "%caml_bytes_set32", Primitive ((Pbytes_set_32(false)), 3); - "%caml_bytes_set32u", Primitive ((Pbytes_set_32(true)), 3); - "%caml_bytes_set64", Primitive ((Pbytes_set_64(false)), 3); - "%caml_bytes_set64u", Primitive ((Pbytes_set_64(true)), 3); - "%caml_bigstring_get16", Primitive ((Pbigstring_load_16(false)), 2); - "%caml_bigstring_get16u", Primitive ((Pbigstring_load_16(true)), 2); - "%caml_bigstring_get32", Primitive ((Pbigstring_load_32(false)), 2); - "%caml_bigstring_get32u", Primitive ((Pbigstring_load_32(true)), 2); - "%caml_bigstring_get64", Primitive ((Pbigstring_load_64(false)), 2); - "%caml_bigstring_get64u", Primitive ((Pbigstring_load_64(true)), 2); - "%caml_bigstring_set16", Primitive ((Pbigstring_set_16(false)), 3); - "%caml_bigstring_set16u", Primitive ((Pbigstring_set_16(true)), 3); - "%caml_bigstring_set32", Primitive ((Pbigstring_set_32(false)), 3); - "%caml_bigstring_set32u", Primitive ((Pbigstring_set_32(true)), 3); - "%caml_bigstring_set64", Primitive ((Pbigstring_set_64(false)), 3); - "%caml_bigstring_set64u", Primitive ((Pbigstring_set_64(true)), 3); - "%bswap16", Primitive (Pbswap16, 1); - "%bswap_int32", Primitive ((Pbbswap(Pint32)), 1); - "%bswap_int64", Primitive ((Pbbswap(Pint64)), 1); - "%bswap_native", Primitive ((Pbbswap(Pnativeint)), 1); - "%int_as_pointer", Primitive (Pint_as_pointer, 1); - "%opaque", Primitive (Popaque, 1); - "%send", Send; - "%sendself", Send_self; - "%sendcache", Send_cache; - "%equal", Comparison(Equal, Compare_generic); - "%notequal", Comparison(Not_equal, Compare_generic); - "%lessequal", Comparison(Less_equal, Compare_generic); - "%lessthan", Comparison(Less_than, Compare_generic); - "%greaterequal", Comparison(Greater_equal, Compare_generic); - "%greaterthan", Comparison(Greater_than, Compare_generic); - "%compare", Comparison(Compare, Compare_generic); - ] - - -let lookup_primitive loc p = - match Hashtbl.find primitives_table p.prim_name with - | prim -> prim - | exception Not_found -> - if String.length p.prim_name > 0 && p.prim_name.[0] = '%' then - raise(Error(loc, Unknown_builtin_primitive p.prim_name)); - External p - -let lookup_primitive_and_mark_used loc p env path = - match lookup_primitive loc p with - | External _ as e -> add_used_primitive loc env path; e - | x -> x - -let simplify_constant_constructor = function - | Equal -> true - | Not_equal -> true - | Less_equal -> false - | Less_than -> false - | Greater_equal -> false - | Greater_than -> false - | Compare -> false - -(* The following function computes the greatest lower bound in the - semilattice of array kinds: - gen - / \ - addr float - | - int - Note that the GLB is not guaranteed to exist, in which case we return - our first argument instead of raising a fatal error because, although - it cannot happen in a well-typed program, (ab)use of Obj.magic can - probably trigger it. -*) -let glb_array_type t1 t2 = - match t1, t2 with - | Pfloatarray, (Paddrarray | Pintarray) - | (Paddrarray | Pintarray), Pfloatarray -> t1 - - | Pgenarray, x | x, Pgenarray -> x - | Paddrarray, x | x, Paddrarray -> x - | Pintarray, Pintarray -> Pintarray - | Pfloatarray, Pfloatarray -> Pfloatarray - -(* Specialize a primitive from available type information. *) - -let specialize_primitive env ty ~has_constant_constructor prim = - let param_tys = - match is_function_type env ty with - | None -> [] - | Some (p1, rhs) -> - match is_function_type env rhs with - | None -> [p1] - | Some (p2, _) -> [p1;p2] - in - match prim, param_tys with - | Primitive (Psetfield(n, Pointer, init), arity), [_; p2] -> begin - match maybe_pointer_type env p2 with - | Pointer -> None - | Immediate -> Some (Primitive (Psetfield(n, Immediate, init), arity)) - end - | Primitive (Parraylength t, arity), [p] -> begin - let array_type = glb_array_type t (array_type_kind env p) in - if t = array_type then None - else Some (Primitive (Parraylength array_type, arity)) - end - | Primitive (Parrayrefu t, arity), p1 :: _ -> begin - let array_type = glb_array_type t (array_type_kind env p1) in - if t = array_type then None - else Some (Primitive (Parrayrefu array_type, arity)) - end - | Primitive (Parraysetu t, arity), p1 :: _ -> begin - let array_type = glb_array_type t (array_type_kind env p1) in - if t = array_type then None - else Some (Primitive (Parraysetu array_type, arity)) - end - | Primitive (Parrayrefs t, arity), p1 :: _ -> begin - let array_type = glb_array_type t (array_type_kind env p1) in - if t = array_type then None - else Some (Primitive (Parrayrefs array_type, arity)) - end - | Primitive (Parraysets t, arity), p1 :: _ -> begin - let array_type = glb_array_type t (array_type_kind env p1) in - if t = array_type then None - else Some (Primitive (Parraysets array_type, arity)) - end - | Primitive (Pbigarrayref(unsafe, n, Pbigarray_unknown, - Pbigarray_unknown_layout), arity), p1 :: _ -> begin - let (k, l) = bigarray_type_kind_and_layout env p1 in - match k, l with - | Pbigarray_unknown, Pbigarray_unknown_layout -> None - | _, _ -> Some (Primitive (Pbigarrayref(unsafe, n, k, l), arity)) - end - | Primitive (Pbigarrayset(unsafe, n, Pbigarray_unknown, - Pbigarray_unknown_layout), arity), p1 :: _ -> begin - let (k, l) = bigarray_type_kind_and_layout env p1 in - match k, l with - | Pbigarray_unknown, Pbigarray_unknown_layout -> None - | _, _ -> Some (Primitive (Pbigarrayset(unsafe, n, k, l), arity)) - end - | Primitive (Pmakeblock(tag, mut, None), arity), fields -> begin - let shape = List.map (Typeopt.value_kind env) fields in - let useful = List.exists (fun knd -> knd <> Pgenval) shape in - if useful then Some (Primitive (Pmakeblock(tag, mut, Some shape), arity)) - else None - end - | Comparison(comp, Compare_generic), p1 :: _ -> - if (has_constant_constructor - && simplify_constant_constructor comp) then begin - Some (Comparison(comp, Compare_ints)) - end else if (is_base_type env p1 Predef.path_int - || is_base_type env p1 Predef.path_char - || (maybe_pointer_type env p1 = Immediate)) then begin - Some (Comparison(comp, Compare_ints)) - end else if is_base_type env p1 Predef.path_float then begin - Some (Comparison(comp, Compare_floats)) - end else if is_base_type env p1 Predef.path_string then begin - Some (Comparison(comp, Compare_strings)) - end else if is_base_type env p1 Predef.path_bytes then begin - Some (Comparison(comp, Compare_bytes)) - end else if is_base_type env p1 Predef.path_nativeint then begin - Some (Comparison(comp, Compare_nativeints)) - end else if is_base_type env p1 Predef.path_int32 then begin - Some (Comparison(comp, Compare_int32s)) - end else if is_base_type env p1 Predef.path_int64 then begin - Some (Comparison(comp, Compare_int64s)) - end else begin - None - end - | _ -> None - -let unboxed_compare name native_repr = - Primitive.make ~name ~alloc:false ~native_name:(name^"_unboxed") - ~native_repr_args:[native_repr;native_repr] ~native_repr_res:Untagged_int - -let caml_equal = - Primitive.simple ~name:"caml_equal" ~arity:2 ~alloc:true -let caml_string_equal = - Primitive.simple ~name:"caml_string_equal" ~arity:2 ~alloc:false -let caml_bytes_equal = - Primitive.simple ~name:"caml_bytes_equal" ~arity:2 ~alloc:false -let caml_notequal = - Primitive.simple ~name:"caml_notequal" ~arity:2 ~alloc:true -let caml_string_notequal = - Primitive.simple ~name:"caml_string_notequal" ~arity:2 ~alloc:false -let caml_bytes_notequal = - Primitive.simple ~name:"caml_bytes_notequal" ~arity:2 ~alloc:false -let caml_lessequal = - Primitive.simple ~name:"caml_lessequal" ~arity:2 ~alloc:true -let caml_string_lessequal = - Primitive.simple ~name:"caml_string_lessequal" ~arity:2 ~alloc:false -let caml_bytes_lessequal = - Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2 ~alloc:false -let caml_lessthan = - Primitive.simple ~name:"caml_lessthan" ~arity:2 ~alloc:true -let caml_string_lessthan = - Primitive.simple ~name:"caml_string_lessthan" ~arity:2 ~alloc:false -let caml_bytes_lessthan = - Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2 ~alloc:false -let caml_greaterequal = - Primitive.simple ~name:"caml_greaterequal" ~arity:2 ~alloc:true -let caml_string_greaterequal = - Primitive.simple ~name:"caml_string_greaterequal" ~arity:2 ~alloc:false -let caml_bytes_greaterequal = - Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2 ~alloc:false -let caml_greaterthan = - Primitive.simple ~name:"caml_greaterthan" ~arity:2 ~alloc:true -let caml_string_greaterthan = - Primitive.simple ~name:"caml_string_greaterthan" ~arity:2 ~alloc: false -let caml_bytes_greaterthan = - Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2 ~alloc: false -let caml_compare = - Primitive.simple ~name:"caml_compare" ~arity:2 ~alloc:true -let caml_int_compare = - (* Not unboxed since the comparison is done directly on tagged int *) - Primitive.simple ~name:"caml_int_compare" ~arity:2 ~alloc:false -let caml_float_compare = - unboxed_compare "caml_float_compare" Unboxed_float -let caml_string_compare = - Primitive.simple ~name:"caml_string_compare" ~arity:2 ~alloc:false -let caml_bytes_compare = - Primitive.simple ~name:"caml_bytes_compare" ~arity:2 ~alloc:false -let caml_nativeint_compare = - unboxed_compare "caml_nativeint_compare" (Unboxed_integer Pnativeint) -let caml_int32_compare = - unboxed_compare "caml_int32_compare" (Unboxed_integer Pint32) -let caml_int64_compare = - unboxed_compare "caml_int64_compare" (Unboxed_integer Pint64) - -let comparison_primitive comparison comparison_kind = - match comparison, comparison_kind with - | Equal, Compare_generic -> Pccall caml_equal - | Equal, Compare_ints -> Pintcomp Ceq - | Equal, Compare_floats -> Pfloatcomp CFeq - | Equal, Compare_strings -> Pccall caml_string_equal - | Equal, Compare_bytes -> Pccall caml_bytes_equal - | Equal, Compare_nativeints -> Pbintcomp(Pnativeint, Ceq) - | Equal, Compare_int32s -> Pbintcomp(Pint32, Ceq) - | Equal, Compare_int64s -> Pbintcomp(Pint64, Ceq) - | Not_equal, Compare_generic -> Pccall caml_notequal - | Not_equal, Compare_ints -> Pintcomp Cne - | Not_equal, Compare_floats -> Pfloatcomp CFneq - | Not_equal, Compare_strings -> Pccall caml_string_notequal - | Not_equal, Compare_bytes -> Pccall caml_bytes_notequal - | Not_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cne) - | Not_equal, Compare_int32s -> Pbintcomp(Pint32, Cne) - | Not_equal, Compare_int64s -> Pbintcomp(Pint64, Cne) - | Less_equal, Compare_generic -> Pccall caml_lessequal - | Less_equal, Compare_ints -> Pintcomp Cle - | Less_equal, Compare_floats -> Pfloatcomp CFle - | Less_equal, Compare_strings -> Pccall caml_string_lessequal - | Less_equal, Compare_bytes -> Pccall caml_bytes_lessequal - | Less_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cle) - | Less_equal, Compare_int32s -> Pbintcomp(Pint32, Cle) - | Less_equal, Compare_int64s -> Pbintcomp(Pint64, Cle) - | Less_than, Compare_generic -> Pccall caml_lessthan - | Less_than, Compare_ints -> Pintcomp Clt - | Less_than, Compare_floats -> Pfloatcomp CFlt - | Less_than, Compare_strings -> Pccall caml_string_lessthan - | Less_than, Compare_bytes -> Pccall caml_bytes_lessthan - | Less_than, Compare_nativeints -> Pbintcomp(Pnativeint, Clt) - | Less_than, Compare_int32s -> Pbintcomp(Pint32, Clt) - | Less_than, Compare_int64s -> Pbintcomp(Pint64, Clt) - | Greater_equal, Compare_generic -> Pccall caml_greaterequal - | Greater_equal, Compare_ints -> Pintcomp Cge - | Greater_equal, Compare_floats -> Pfloatcomp CFge - | Greater_equal, Compare_strings -> Pccall caml_string_greaterequal - | Greater_equal, Compare_bytes -> Pccall caml_bytes_greaterequal - | Greater_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cge) - | Greater_equal, Compare_int32s -> Pbintcomp(Pint32, Cge) - | Greater_equal, Compare_int64s -> Pbintcomp(Pint64, Cge) - | Greater_than, Compare_generic -> Pccall caml_greaterthan - | Greater_than, Compare_ints -> Pintcomp Cgt - | Greater_than, Compare_floats -> Pfloatcomp CFgt - | Greater_than, Compare_strings -> Pccall caml_string_greaterthan - | Greater_than, Compare_bytes -> Pccall caml_bytes_greaterthan - | Greater_than, Compare_nativeints -> Pbintcomp(Pnativeint, Cgt) - | Greater_than, Compare_int32s -> Pbintcomp(Pint32, Cgt) - | Greater_than, Compare_int64s -> Pbintcomp(Pint64, Cgt) - | Compare, Compare_generic -> Pccall caml_compare - | Compare, Compare_ints -> Pccall caml_int_compare - | Compare, Compare_floats -> Pccall caml_float_compare - | Compare, Compare_strings -> Pccall caml_string_compare - | Compare, Compare_bytes -> Pccall caml_bytes_compare - | Compare, Compare_nativeints -> Pccall caml_nativeint_compare - | Compare, Compare_int32s -> Pccall caml_int32_compare - | Compare, Compare_int64s -> Pccall caml_int64_compare - -let lambda_of_loc kind loc = - let loc_start = loc.Location.loc_start in - let (file, lnum, cnum) = Location.get_pos_info loc_start in - let file = - if Filename.is_relative file then - file - else - Location.rewrite_absolute_path file in - let enum = loc.Location.loc_end.Lexing.pos_cnum - - loc_start.Lexing.pos_cnum + cnum in - match kind with - | Loc_POS -> - Lconst (Const_block (0, [ - Const_immstring file; - Const_base (Const_int lnum); - Const_base (Const_int cnum); - Const_base (Const_int enum); - ])) - | Loc_FILE -> Lconst (Const_immstring file) - | Loc_MODULE -> - let filename = Filename.basename file in - let name = Env.get_unit_name () in - let module_name = if name = "" then "//"^filename^"//" else name in - Lconst (Const_immstring module_name) - | Loc_LOC -> - let loc = Printf.sprintf "File %S, line %d, characters %d-%d" - file lnum cnum enum in - Lconst (Const_immstring loc) - | Loc_LINE -> Lconst (Const_base (Const_int lnum)) - -let caml_restore_raw_backtrace = - Primitive.simple ~name:"caml_restore_raw_backtrace" ~arity:2 ~alloc:false - -let try_ids = Hashtbl.create 8 - -let add_exception_ident id = - Hashtbl.replace try_ids id () - -let remove_exception_ident id = - Hashtbl.remove try_ids id - -let lambda_of_prim prim_name prim loc args arg_exps = - match prim, args with - | Primitive (prim, arity), args when arity = List.length args -> - Lprim(prim, args, loc) - | External prim, args -> - Lprim(Pccall prim, args, loc) - | Comparison(comp, knd), ([_;_] as args) -> - let prim = comparison_primitive comp knd in - Lprim(prim, args, loc) - | Raise kind, [arg] -> - let kind = - match kind, arg with - | Raise_regular, Lvar argv when Hashtbl.mem try_ids argv -> - Raise_reraise - | _, _ -> - kind - in - let arg = - match arg_exps with - | None -> arg - | Some [arg_exp] -> event_after arg_exp arg - | Some _ -> assert false - in - Lprim(Praise kind, [arg], loc) - | Raise_with_backtrace, [exn; bt] -> - let vexn = Ident.create_local "exn" in - let raise_arg = - match arg_exps with - | None -> Lvar vexn - | Some [exn_exp; _] -> event_after exn_exp (Lvar vexn) - | Some _ -> assert false - in - Llet(Strict, Pgenval, vexn, exn, - Lsequence(Lprim(Pccall caml_restore_raw_backtrace, - [Lvar vexn; bt], - loc), - Lprim(Praise Raise_reraise, [raise_arg], loc))) - | Lazy_force, [arg] -> - Matching.inline_lazy_force arg Location.none - | Loc kind, [] -> - lambda_of_loc kind loc - | Loc kind, [arg] -> - let lam = lambda_of_loc kind loc in - Lprim(Pmakeblock(0, Immutable, None), [lam; arg], loc) - | Send, [obj; meth] -> - Lsend(Public, meth, obj, [], loc) - | Send_self, [obj; meth] -> - Lsend(Self, meth, obj, [], loc) - | Send_cache, [obj; meth; cache; pos] -> - Lsend(Cached, meth, obj, [cache; pos], loc) - | (Raise _ | Raise_with_backtrace - | Lazy_force | Loc _ | Primitive _ | Comparison _ - | Send | Send_self | Send_cache), _ -> - raise(Error(loc, Wrong_arity_builtin_primitive prim_name)) - -let check_primitive_arity loc p = - let prim = lookup_primitive loc p in - let ok = - match prim with - | Primitive (_,arity) -> arity = p.prim_arity - | External _ -> true - | Comparison _ -> p.prim_arity = 2 - | Raise _ -> p.prim_arity = 1 - | Raise_with_backtrace -> p.prim_arity = 2 - | Lazy_force -> p.prim_arity = 1 - | Loc _ -> p.prim_arity = 1 || p.prim_arity = 0 - | Send | Send_self -> p.prim_arity = 2 - | Send_cache -> p.prim_arity = 4 - in - if not ok then raise(Error(loc, Wrong_arity_builtin_primitive p.prim_name)) - -(* Eta-expand a primitive *) - -let transl_primitive loc p env ty path = - let prim = lookup_primitive_and_mark_used loc p env path in - let has_constant_constructor = false in - let prim = - match specialize_primitive env ty ~has_constant_constructor prim with - | None -> prim - | Some prim -> prim - in - let rec make_params n = - if n <= 0 then [] - else (Ident.create_local "prim", Pgenval) :: make_params (n-1) - in - let params = make_params p.prim_arity in - let args = List.map (fun (id, _) -> Lvar id) params in - let body = lambda_of_prim p.prim_name prim loc args None in - match params with - | [] -> body - | _ -> - Lfunction{ kind = Curried; - params; - return = Pgenval; - attr = default_stub_attribute; - loc = loc; - body = body; } - -(* Determine if a primitive is a Pccall or will be turned later into - a C function call that may raise an exception *) -let primitive_is_ccall = function - | Pccall _ | Pstringrefs | Pbytesrefs | Pbytessets | Parrayrefs _ | - Parraysets _ | Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply | - Prevapply -> true - | _ -> false - -(* Determine if a primitive should be surrounded by an "after" debug event *) -let primitive_needs_event_after = function - | Primitive (prim,_) -> primitive_is_ccall prim - | External _ -> true - | Comparison(comp, knd) -> - primitive_is_ccall (comparison_primitive comp knd) - | Lazy_force | Send | Send_self | Send_cache -> true - | Raise _ | Raise_with_backtrace | Loc _ -> false - -let transl_primitive_application loc p env ty path exp args arg_exps = - let prim = lookup_primitive_and_mark_used loc p env (Some path) in - let has_constant_constructor = - match arg_exps with - | [_; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}] - | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}; _] - | [_; {exp_desc = Texp_variant(_, None)}] - | [{exp_desc = Texp_variant(_, None)}; _] -> true - | _ -> false - in - let prim = - match specialize_primitive env ty ~has_constant_constructor prim with - | None -> prim - | Some prim -> prim - in - let lam = lambda_of_prim p.prim_name prim loc args (Some arg_exps) in - let lam = - if primitive_needs_event_after prim then begin - match exp with - | None -> lam - | Some exp -> event_after exp lam - end else begin - lam - end - in - lam - -(* Error report *) - -open Format - -let report_error ppf = function - | Unknown_builtin_primitive prim_name -> - fprintf ppf "Unknown builtin primitive \"%s\"" prim_name - | Wrong_arity_builtin_primitive prim_name -> - fprintf ppf "Wrong arity for builtin primitive \"%s\"" prim_name - -let () = - Location.register_error_of_exn - (function - | Error (loc, err) -> - Some (Location.error_of_printer ~loc report_error err) - | _ -> - None - ) diff --git a/bytecomp/translprim.mli b/bytecomp/translprim.mli deleted file mode 100644 index abf0f7d5..00000000 --- a/bytecomp/translprim.mli +++ /dev/null @@ -1,51 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Insertion of debugging events *) - -val event_before : Typedtree.expression -> Lambda.lambda -> Lambda.lambda - -val event_after : Typedtree.expression -> Lambda.lambda -> Lambda.lambda - -(* Translation of primitives *) - -val add_exception_ident : Ident.t -> unit -val remove_exception_ident : Ident.t -> unit - -val clear_used_primitives : unit -> unit -val get_used_primitives: unit -> Path.t list - -val check_primitive_arity : Location.t -> Primitive.description -> unit - -val transl_primitive : - Location.t -> Primitive.description -> Env.t -> - Types.type_expr -> Path.t option -> Lambda.lambda - -val transl_primitive_application : - Location.t -> Primitive.description -> Env.t -> - Types.type_expr -> Path.t -> Typedtree.expression option -> - Lambda.lambda list -> Typedtree.expression list -> Lambda.lambda - -(* Errors *) - -type error = - | Unknown_builtin_primitive of string - | Wrong_arity_builtin_primitive of string - -exception Error of Location.t * error - -open Format - -val report_error : formatter -> error -> unit diff --git a/config/Makefile.mingw b/config/Makefile.mingw deleted file mode 100644 index c5a78f7b..00000000 --- a/config/Makefile.mingw +++ /dev/null @@ -1,201 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -#* * -#* Copyright 1999 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -# Configuration for Windows, Mingw compiler - -######### General configuration - -PREFIX=C:/ocamlmgw - -### Remove this to disable compiling ocamldebug -WITH_DEBUGGER=ocamldebugger - -### Remove this to disable compiling ocamldoc -WITH_OCAMLDOC=ocamldoc - -### Where to install the binaries -BINDIR=$(PREFIX)/bin - -### Where to install the standard library -LIBDIR=$(PREFIX)/lib/ocaml - -### Where to install the stub DLLs -STUBLIBDIR=$(LIBDIR)/stublibs - -### Where to install the info files -DISTRIB=$(PREFIX) - -### Where to install the man pages -MANDIR=$(PREFIX)/man - -########## Toolchain and OS dependencies - -TOOLCHAIN=mingw - -### Toolchain prefix -TARGET=i686-w64-mingw32 -HOST=i686-w64-mingw32 - -TOOLPREF=$(TARGET)- - -CCOMPTYPE=cc -O=o -A=a -S=s -SO=s.o -EXE=.exe -EMPTY= -OUTPUTEXE=-o $(EMPTY) -EXT_DLL=.dll -EXT_OBJ=.$(O) -OUTPUTOBJ=-o $(EMPTY) -EXT_LIB=.$(A) -EXT_ASM=.$(S) -PROGRAMS_MAN_SECTION=1 -LIBRARIES_MAN_SECTION=3 -HASHBANGSCRIPTS=false -PTHREAD_LINK= -PTHREAD_CAML_LINK= -X11_INCLUDES= -X11_LINK= -RPATH= -SUPPORTS_SHARED_LIBRARIES=true -SHAREDLIB_CFLAGS= -MKSHAREDLIBRPATH= -ASM=$(TOOLPREF)as -ASPP=$(TOOLPREF)gcc -c -ASPPPROFFLAGS= -PROFILING=false -DYNLINKOPTS= -CC_PROFILE= -SYSTHREAD_SUPPORT=true -EXTRALIBS= -NATDYNLINK=true -NATDYNLINKOPTS= -CMXS=cmxs -RUNTIMED=false -ASM_CFI_SUPPORTED=false -WITH_FRAME_POINTERS=false -UNIX_OR_WIN32=win32 -UNIXLIB=win32unix -GRAPHLIB=win32graph -FLAMBDA=false -WITH_FLAMBDA_INVARIANTS=false -WITH_SPACETIME=false -ENABLE_CALL_COUNTS=false -WITH_PROFINFO=false -LIBUNWIND_AVAILABLE=false -LIBUNWIND_LINK_FLAGS= -PROFINFO_WIDTH=0 -FORCE_SAFE_STRING=false -DEFAULT_SAFE_STRING=true -WINDOWS_UNICODE=1 -AFL_INSTRUMENT=false -AWK=gawk -CC_HAS_DEBUG_PREFIX_MAP=false -AS_HAS_DEBUG_PREFIX_MAP=false - -########## Configuration for the bytecode compiler - -### Which C compiler to use for the bytecode interpreter. -CC=$(TOOLPREF)gcc -OC_CFLAGS=-O -mms-bitfields -Wall -Wno-unused -fno-tree-vrp -# -fno-tree-vrp is here to try to work around the Skylake/Kaby lake bug, -# and only works on GCC 4.2 and later. -OC_CPPFLAGS=-DCAML_NAME_SPACE -DUNICODE -D_UNICODE \ - -DWINDOWS_UNICODE=$(WINDOWS_UNICODE) -OCAMLC_CFLAGS=-O -mms-bitfields - -OC_LDFLAGS=-municode - -### Libraries needed -BYTECCLIBS=-lws2_32 -lversion -NATIVECCLIBS=-lws2_32 -lversion - -### How to invoke the C preprocessor -CPP=cpp - -### Flexlink -FLEXLINK_CMD=flexlink -FLEXDLL_CHAIN=mingw -# FLEXLINK_FLAGS must be safe to insert in an OCaml string -# (see ocamlmklibconfig.ml in tools/Makefile) -FLEXLINK_FLAGS=-chain $(FLEXDLL_CHAIN) -stack 16777216 -FLEXLINK=$(FLEXLINK_CMD) $(FLEXLINK_FLAGS) -FLEXDIR:=$(shell $(FLEXLINK) -where 2>/dev/null) -ifeq ($(FLEXDIR),) -IFLEXDIR=-I"../flexdll" -else -IFLEXDIR=-I"$(FLEXDIR)" -endif -# MKDLL, MKEXE and MKMAINDLL must ultimately be equivalent to -# $(FLEXLINK_CMD) $(FLEXLINK_FLAGS) [-exe|-maindll] -# or OCAML_FLEXLINK overriding will not work (see utils/config.mlp) -MKDLL=$(FLEXLINK) -MKEXE=$(MKEXE_ANSI) $(if $(OC_LDFLAGS),-link "$(OC_LDFLAGS)") -MKEXEDEBUGFLAG=-g -MKMAINDLL=$(FLEXLINK) -maindll - -### Native command to build ocamlrun.exe without flexlink -MKEXE_BOOT=$(CC) $(OC_CFLAGS) $(OC_LDFLAGS) $(OUTPUTEXE)$(1) $(2) - -### Native command to build an ANSI executable -MKEXE_ANSI=$(FLEXLINK) -exe - -### How to build a static library -MKLIB=rm -f $(1) && $(TOOLPREF)ar rcs $(1) $(2) - -### Canonicalize the name of a system library -SYSLIB=-l$(1) - -### The ranlib command -RANLIB=$(TOOLPREF)ranlib -RANLIBCMD=$(TOOLPREF)ranlib - -### The ar command -ARCMD=$(TOOLPREF)ar - -############# Configuration for the native-code compiler - -### Name of architecture for the native-code compiler -ARCH=i386 -ARCH64=false - -### Name of architecture model for the native-code compiler. -MODEL=default - -### Name of operating system family for the native-code compiler. -SYSTEM=mingw - -OCAMLOPT_CFLAGS=-O -mms-bitfields - -### Build partially-linked object file -PACKLD=$(TOOLPREF)ld -r -o # must have a space after '-o' - -### Set to "true" to install ".byte" executables (ocamlc.byte, etc.) -INSTALL_BYTECODE_PROGRAMS=true - -############# Configuration for the contributed libraries - -OTHERLIBRARIES=win32unix str win32graph dynlink bigarray systhreads - -############# for the testsuite makefiles -OTOPDIR=$(WINTOPDIR) -CTOPDIR=$(TOPDIR) -CYGPATH=cygpath -m -DIFF=/usr/bin/diff -q --strip-trailing-cr -SET_LD_PATH=PATH="$(PATH):$(LD_PATH)" -MAX_TESTSUITE_DIR_RETRIES=1 -FLAT_FLOAT_ARRAY=true diff --git a/config/Makefile.mingw64 b/config/Makefile.mingw64 deleted file mode 100644 index 4c50467c..00000000 --- a/config/Makefile.mingw64 +++ /dev/null @@ -1,201 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -#* * -#* Copyright 1999 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -# Configuration for Windows, Mingw compiler - -######### General configuration - -PREFIX=C:/ocamlmgw64 - -### Remove this to disable compiling ocamldebug -WITH_DEBUGGER=ocamldebugger - -### Remove this to disable compiling ocamldoc -WITH_OCAMLDOC=ocamldoc - -### Where to install the binaries -BINDIR=$(PREFIX)/bin - -### Where to install the standard library -LIBDIR=$(PREFIX)/lib/ocaml - -### Where to install the stub DLLs -STUBLIBDIR=$(LIBDIR)/stublibs - -### Where to install the info files -DISTRIB=$(PREFIX) - -### Where to install the man pages -MANDIR=$(PREFIX)/man - -########## Toolchain and OS dependencies - -TOOLCHAIN=mingw - -### Toolchain prefix -TARGET=x86_64-w64-mingw32 -HOST=$(TARGET) - -TOOLPREF=$(TARGET)- - -CCOMPTYPE=cc -O=o -A=a -S=s -SO=s.o -EXE=.exe -EMPTY= -OUTPUTEXE=-o $(EMPTY) -EXT_DLL=.dll -EXT_OBJ=.$(O) -OUTPUTOBJ=-o $(EMPTY) -EXT_LIB=.$(A) -EXT_ASM=.$(S) -PROGRAMS_MAN_SECTION=1 -LIBRARIES_MAN_SECTION=3 -HASHBANGSCRIPTS=false -PTHREAD_LINK= -PTHREAD_CAML_LINK= -X11_INCLUDES= -X11_LINK= -RPATH= -SUPPORTS_SHARED_LIBRARIES=true -SHAREDLIB_CFLAGS= -MKSHAREDLIBRPATH= -ASM=$(TOOLPREF)as -ASPP=$(TOOLPREF)gcc -c -ASPPPROFFLAGS= -PROFILING=false -DYNLINKOPTS= -CC_PROFILE= -SYSTHREAD_SUPPORT=true -EXTRALIBS= -NATDYNLINK=true -NATDYNLINKOPTS= -CMXS=cmxs -RUNTIMED=false -ASM_CFI_SUPPORTED=false -WITH_FRAME_POINTERS=false -UNIX_OR_WIN32=win32 -UNIXLIB=win32unix -GRAPHLIB=win32graph -FLAMBDA=false -WITH_FLAMBDA_INVARIANTS=false -WITH_PROFINFO=false -WITH_SPACETIME=false -ENABLE_CALL_COUNTS=false -LIBUNWIND_AVAILABLE=false -LIBUNWIND_LINK_FLAGS= -PROFINFO_WIDTH=0 -FORCE_SAFE_STRING=false -DEFAULT_SAFE_STRING=true -WINDOWS_UNICODE=1 -AFL_INSTRUMENT=false -AWK=gawk -CC_HAS_DEBUG_PREFIX_MAP=false -AS_HAS_DEBUG_PREFIX_MAP=false - -########## Configuration for the bytecode compiler - -### Which C compiler to use for the bytecode interpreter. -CC=$(TOOLPREF)gcc -OC_CFLAGS=-O -mms-bitfields -Wall -Wno-unused -fno-tree-vrp -# -fno-tree-vrp is here to try to work around the Skylake/Kaby lake bug, -# and only works on GCC 4.2 and later. -OC_CPPFLAGS=-DCAML_NAME_SPACE -DUNICODE -D_UNICODE \ - -DWINDOWS_UNICODE=$(WINDOWS_UNICODE) -OCAMLC_CFLAGS=-O -mms-bitfields - -OC_LDFLAGS=-municode - -### Libraries needed -BYTECCLIBS=-lws2_32 -lversion -NATIVECCLIBS=-lws2_32 -lversion - -### How to invoke the C preprocessor -CPP=cpp - -### Flexlink -FLEXLINK_CMD=flexlink -FLEXDLL_CHAIN=mingw64 -# FLEXLINK_FLAGS must be safe to insert in an OCaml string -# (see ocamlmklibconfig.ml in tools/Makefile) -FLEXLINK_FLAGS=-chain $(FLEXDLL_CHAIN) -stack 33554432 -FLEXLINK=$(FLEXLINK_CMD) $(FLEXLINK_FLAGS) -FLEXDIR:=$(shell $(FLEXLINK) -where 2>/dev/null) -ifeq ($(FLEXDIR),) -IFLEXDIR=-I"../flexdll" -else -IFLEXDIR=-I"$(FLEXDIR)" -endif -# MKDLL, MKEXE and MKMAINDLL must ultimately be equivalent to -# $(FLEXLINK_CMD) $(FLEXLINK_FLAGS) [-exe|-maindll] -# or OCAML_FLEXLINK overriding will not work (see utils/config.mlp) -MKDLL=$(FLEXLINK) -MKEXE=$(MKEXE_ANSI) $(if $(OC_LDFLAGS),-link "$(OC_LDFLAGS)") -MKEXEDEBUGFLAG=-g -MKMAINDLL=$(FLEXLINK) -maindll - -### Native command to build ocamlrun.exe without flexlink -MKEXE_BOOT=$(CC) $(OC_CFLAGS) $(OC_LDFLAGS) $(OUTPUTEXE)$(1) $(2) - -### Native command to build an ANSI executable -MKEXE_ANSI=$(FLEXLINK) -exe - -### How to build a static library -MKLIB=rm -f $(1) && $(TOOLPREF)ar rcs $(1) $(2) - -### Canonicalize the name of a system library -SYSLIB=-l$(1) - -### The ranlib command -RANLIB=$(TOOLPREF)ranlib -RANLIBCMD=$(TOOLPREF)ranlib - -### The ar command -ARCMD=$(TOOLPREF)ar - -############# Configuration for the native-code compiler - -### Name of architecture for the native-code compiler -ARCH=amd64 -ARCH64=true - -### Name of architecture model for the native-code compiler. -MODEL=default - -### Name of operating system family for the native-code compiler. -SYSTEM=mingw64 - -OCAMLOPT_CFLAGS=-O -mms-bitfields - -### Build partially-linked object file -PACKLD=$(TOOLPREF)ld -r -o # must have a space after '-o' - -### Set to "true" to install ".byte" executables (ocamlc.byte, etc.) -INSTALL_BYTECODE_PROGRAMS=true - -############# Configuration for the contributed libraries - -OTHERLIBRARIES=win32unix str win32graph dynlink bigarray systhreads - -############# for the testsuite makefiles -OTOPDIR=$(WINTOPDIR) -CTOPDIR=$(TOPDIR) -CYGPATH=cygpath -m -DIFF=/usr/bin/diff -q --strip-trailing-cr -SET_LD_PATH=PATH="$(PATH):$(LD_PATH)" -MAX_TESTSUITE_DIR_RETRIES=1 -FLAT_FLOAT_ARRAY=true diff --git a/config/Makefile.msvc b/config/Makefile.msvc deleted file mode 100644 index 827e61e4..00000000 --- a/config/Makefile.msvc +++ /dev/null @@ -1,207 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -#* * -#* Copyright 1999 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -# Configuration for Windows, Visual C++ compiler - -######### General configuration - -PREFIX=C:/ocamlms - -### Where to install the binaries. -BINDIR=$(PREFIX)/bin - -### Where to install the standard library -LIBDIR=$(PREFIX)/lib/ocaml - -### Where to install the stub DLLs -STUBLIBDIR=$(LIBDIR)/stublibs - -### Where to install the info files -DISTRIB=$(PREFIX) - -### Where to install the man pages -MANDIR=$(PREFIX)/man - -########## Toolchain and OS dependencies - -TOOLCHAIN=msvc - -# It doesn't make much sense to set "TARGET" and "HOST" for msvc but it's needed -# for the myocamlbuild config. -# The only case these will be used currently is to check whether we're -# cross-compiling or not so setting them to the same value is what matters. -HOST=msvc -TARGET=$(HOST) - -CCOMPTYPE=msvc -O=obj -A=lib -S=asm -SO=s.obj -EXE=.exe -OUTPUTEXE=-Fe -EXT_DLL=.dll -EXT_OBJ=.$(O) -OUTPUTOBJ=-Fo -EXT_LIB=.$(A) -EXT_ASM=.$(S) -PROGRAMS_MAN_SECTION=1 -LIBRARIES_MAN_SECTION=3 -HASHBANGSCRIPTS=false -PTHREAD_LINK= -PTHREAD_CAML_LINK= -X11_INCLUDES= -X11_LINK= -RPATH= -SUPPORTS_SHARED_LIBRARIES=true -SHAREDLIB_CFLAGS= -ASM=ml -nologo -coff -Cp -c -Fo -ASPP= -ASPPPROFFLAGS= -PROFILING=false -DYNLINKOPTS= -CC_PROFILE= -SYSTHREAD_SUPPORT=true -EXTRALIBS= -CMXS=cmxs -NATDYNLINK=true -NATDYNLINKOPTS= -RUNTIMED=false -ASM_CFI_SUPPORTED=false -WITH_FRAME_POINTERS=false -UNIX_OR_WIN32=win32 -UNIXLIB=win32unix -GRAPHLIB=win32graph -FLAMBDA=false -WITH_FLAMBDA_INVARIANTS=false -WITH_PROFINFO=false -WITH_SPACETIME=false -ENABLE_CALL_COUNTS=false -LIBUNWIND_AVAILABLE=false -LIBUNWIND_LINK_FLAGS= -PROFINFO_WIDTH=0 -FORCE_SAFE_STRING=false -DEFAULT_SAFE_STRING=true -WINDOWS_UNICODE=1 -AFL_INSTRUMENT=false -AWK=gawk -CC_HAS_DEBUG_PREFIX_MAP=false -AS_HAS_DEBUG_PREFIX_MAP=false - -########## Configuration for the bytecode compiler - -### Which C compiler to use for the bytecode interpreter. -CC=cl -OC_CFLAGS=-nologo -O2 -Gy- -MD -OC_CPPFLAGS=-D_CRT_SECURE_NO_DEPRECATE -DCAML_NAME_SPACE -DUNICODE -D_UNICODE \ - -DWINDOWS_UNICODE=$(WINDOWS_UNICODE) -OCAMLC_CFLAGS=-nologo -O2 -Gy- -MD -OCAMLC_CPPFLAGS=-D_CRT_SECURE_NO_DEPRECATE - -OC_LDFLAGS=/ENTRY:wmainCRTStartup - -### Libraries needed -BYTECCLIBS=advapi32.lib ws2_32.lib version.lib -NATIVECCLIBS=advapi32.lib ws2_32.lib version.lib - -### How to invoke the C preprocessor -CPP=cl -nologo -EP - -### Flexlink -FLEXLINK_CMD=flexlink -FLEXDLL_CHAIN=msvc -# FLEXLINK_FLAGS must be safe to insert in an OCaml string -# (see ocamlmklibconfig.ml in tools/Makefile) -FLEXLINK_FLAGS=-merge-manifest -stack 16777216 -FLEXLINK=$(FLEXLINK_CMD) $(FLEXLINK_FLAGS) -FLEXDIR:=$(shell $(FLEXLINK) -where 2>/dev/null) -ifeq ($(FLEXDIR),) -IFLEXDIR=-I"../flexdll" -else -IFLEXDIR=-I"$(FLEXDIR)" -endif -# MKDLL, MKEXE and MKMAINDLL must ultimately be equivalent to -# $(FLEXLINK_CMD) $(FLEXLINK_FLAGS) [-exe|-maindll] -# or OCAML_FLEXLINK overriding will not work (see utils/config.mlp) -MKDLL=$(FLEXLINK) -MKEXE=$(MKEXE_ANSI) $(if $(OC_LDFLAGS),-link "$(OC_LDFLAGS)") -MKEXEDEBUGFLAG= -MKMAINDLL=$(FLEXLINK) -maindll - -### Native command to build ocamlrun.exe without flexlink -MERGEMANIFESTEXE=test ! -f $(1).manifest \ - || mt -nologo -outputresource:$(1) -manifest $(1).manifest \ - && rm -f $(1).manifest -MKEXE_BOOT=$(CC) $(OC_CFLAGS) $(OUTPUTEXE)$(1) $(2) \ - /link /subsystem:console $(OC_LDFLAGS) && ($(MERGEMANIFESTEXE)) - -### Native command to build an ANSI executable -MKEXE_ANSI=$(FLEXLINK) -exe - -### How to build a static library -MKLIB=link -lib -nologo -out:$(1) $(2) -MKSHAREDLIBRPATH= - -### Canonicalize the name of a system library -SYSLIB=$(1).lib - -### The ranlib command -RANLIB=echo -RANLIBCMD= - -### The ar command -ARCMD= - -############# Configuration for the native-code compiler - -### Name of architecture for the native-code compiler -ARCH=i386 -ARCH64=false - -### Name of architecture model for the native-code compiler. -MODEL=default - -### Name of operating system family for the native-code compiler. -SYSTEM=win32 - -OCAMLOPT_CFLAGS=-nologo -O2 -Gy- -MD -OCAMLOPT_CPPFLAGS=-D_CRT_SECURE_NO_DEPRECATE - -### Build partially-linked object file -PACKLD=link -lib -nologo -out:# there must be no space after this '-out:' - -### Set to "true" to install ".byte" executables (ocamlc.byte, etc.) -INSTALL_BYTECODE_PROGRAMS=true - -### Clear this to disable compiling ocamldebug -WITH_DEBUGGER=ocamldebugger - -### Clear this to disable compiling ocamldoc -WITH_OCAMLDOC=ocamldoc - -############# Configuration for the contributed libraries - -OTHERLIBRARIES=win32unix systhreads str win32graph dynlink bigarray - -############# for the testsuite makefiles -OTOPDIR=$(WINTOPDIR) -CTOPDIR=$(WINTOPDIR) -CYGPATH=cygpath -m -DIFF=/usr/bin/diff -q --strip-trailing-cr -FIND=/usr/bin/find -SORT=/usr/bin/sort -SET_LD_PATH=PATH="$(PATH):$(LD_PATH)" -MAX_TESTSUITE_DIR_RETRIES=1 -FLAT_FLOAT_ARRAY=true diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64 deleted file mode 100644 index b992a525..00000000 --- a/config/Makefile.msvc64 +++ /dev/null @@ -1,208 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -#* * -#* Copyright 1999 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -# Configuration for Windows, Visual C++ compiler - -######### General configuration - -PREFIX=C:/ocamlms64 - -### Where to install the binaries. -BINDIR=$(PREFIX)/bin - -### Where to install the standard library -LIBDIR=$(PREFIX)/lib/ocaml - -### Where to install the stub DLLs -STUBLIBDIR=$(LIBDIR)/stublibs - -### Where to install the info files -DISTRIB=$(PREFIX) - -### Where to install the man pages -MANDIR=$(PREFIX)/man - -########## Toolchain and OS dependencies - -TOOLCHAIN=msvc - -# It doesn't make much sense to set "TARGET" and "HOST" for msvc but it's needed -# for the myocamlbuild config. -# The only case these will be used currently is to check whether we're -# cross-compiling or not so setting them to the same value is what matters. -HOST=msvc64 -TARGET=$(HOST) - -CCOMPTYPE=msvc -O=obj -A=lib -S=asm -SO=s.obj -EXE=.exe -OUTPUTEXE=-Fe -EXT_DLL=.dll -EXT_OBJ=.$(O) -OUTPUTOBJ=-Fo -EXT_LIB=.$(A) -EXT_ASM=.$(S) -PROGRAMS_MAN_SECTION=1 -LIBRARIES_MAN_SECTION=3 -HASHBANGSCRIPTS=false -PTHREAD_LINK= -PTHREAD_CAML_LINK= -X11_INCLUDES= -X11_LINK= -RPATH= -SUPPORTS_SHARED_LIBRARIES=true -SHAREDLIB_CFLAGS= -ASM=ml64 -nologo -Cp -c -Fo -ASPP= -ASPPPROFFLAGS= -PROFILING=false -DYNLINKOPTS= -CC_PROFILE= -SYSTHREAD_SUPPORT=true -CMXS=cmxs -NATDYNLINK=true -NATDYNLINKOPTS= -RUNTIMED=false -ASM_CFI_SUPPORTED=false -WITH_FRAME_POINTERS=false -UNIX_OR_WIN32=win32 -UNIXLIB=win32unix -GRAPHLIB=win32graph -FLAMBDA=false -WITH_FLAMBDA_INVARIANTS=false -WITH_PROFINFO=false -WITH_SPACETIME=false -ENABLE_CALL_COUNTS=false -LIBUNWIND_AVAILABLE=false -LIBUNWIND_LINK_FLAGS= -PROFINFO_WIDTH=0 -FORCE_SAFE_STRING=false -DEFAULT_SAFE_STRING=true -WINDOWS_UNICODE=1 -AFL_INSTRUMENT=false -AWK=gawk -CC_HAS_DEBUG_PREFIX_MAP=false -AS_HAS_DEBUG_PREFIX_MAP=false - -########## Configuration for the bytecode compiler - -### Which C compiler to use for the bytecode interpreter. -CC=cl -OC_CFLAGS=-nologo -O2 -Gy- -MD -OC_CPPFLAGS=-D_CRT_SECURE_NO_DEPRECATE -DCAML_NAME_SPACE -DUNICODE -D_UNICODE \ - -DWINDOWS_UNICODE=$(WINDOWS_UNICODE) -OCAMLC_CFLAGS=-nologo -O2 -Gy- -MD -OCAMLC_CPPFLAGS=-D_CRT_SECURE_NO_DEPRECATE - -OC_LDFLAGS=/ENTRY:wmainCRTStartup - -### Libraries needed -#EXTRALIBS=bufferoverflowu.lib # for the old PSDK compiler only -EXTRALIBS= -BYTECCLIBS=advapi32.lib ws2_32.lib version.lib -NATIVECCLIBS=advapi32.lib ws2_32.lib version.lib - -### How to invoke the C preprocessor -CPP=$(CC) -nologo -EP - -### Flexlink -FLEXLINK_CMD=flexlink -FLEXDLL_CHAIN=msvc64 -# FLEXLINK_FLAGS must be safe to insert in an OCaml string -# (see ocamlmklibconfig.ml in tools/Makefile) -FLEXLINK_FLAGS=-x64 -merge-manifest -stack 33554432 -FLEXLINK=$(FLEXLINK_CMD) $(FLEXLINK_FLAGS) -FLEXDIR:=$(shell $(FLEXLINK) -where 2>/dev/null) -ifeq ($(FLEXDIR),) -IFLEXDIR=-I"../flexdll" -else -IFLEXDIR=-I"$(FLEXDIR)" -endif -# MKDLL, MKEXE and MKMAINDLL must ultimately be equivalent to -# $(FLEXLINK_CMD) $(FLEXLINK_FLAGS) [-exe|-maindll] -# or OCAML_FLEXLINK overriding will not work (see utils/config.mlp) -MKDLL=$(FLEXLINK) -MKEXE=$(MKEXE_ANSI) $(if $(OC_LDFLAGS),-link "$(OC_LDFLAGS)") -MKEXEDEBUGFLAG= -MKMAINDLL=$(FLEXLINK) -maindll - -### Native command to build ocamlrun.exe without flexlink -MERGEMANIFESTEXE=test ! -f $(1).manifest \ - || mt -nologo -outputresource:$(1) -manifest $(1).manifest \ - && rm -f $(1).manifest -MKEXE_BOOT=$(CC) $(OC_CFLAGS) $(OUTPUTEXE)$(1) $(2) \ - /link /subsystem:console $(OC_LDFLAGS) && ($(MERGEMANIFESTEXE)) - -### Native command to build an ANSI executable -MKEXE_ANSI=$(FLEXLINK) -exe - -### How to build a static library -MKLIB=link -lib -nologo -machine:AMD64 /out:$(1) $(2) -MKSHAREDLIBRPATH= - -### Canonicalize the name of a system library -SYSLIB=$(1).lib - -### The ranlib command -RANLIB=echo -RANLIBCMD= - -### The ar command -ARCMD= - -############# Configuration for the native-code compiler - -### Name of architecture for the native-code compiler -ARCH=amd64 -ARCH64=true - -### Name of architecture model for the native-code compiler. -MODEL=default - -### Name of operating system family for the native-code compiler. -SYSTEM=win64 - -OCAMLOPT_CFLAGS=-nologo -O2 -Gy- -MD -OCAMLOPT_CPPFLAGS=-D_CRT_SECURE_NO_DEPRECATE - -### Build partially-linked object file -PACKLD=link -lib -nologo -machine:AMD64 -out:# must have no space after '-out:' - -### Set to "true" to install ".byte" executables (ocamlc.byte, etc.) -INSTALL_BYTECODE_PROGRAMS=true - -### Clear this to disable compiling ocamldebug -WITH_DEBUGGER=ocamldebugger - -### Clear this to disable compiling ocamldoc -WITH_OCAMLDOC=ocamldoc - -############# Configuration for the contributed libraries - -OTHERLIBRARIES=win32unix systhreads str win32graph dynlink bigarray - -############# for the testsuite makefiles -OTOPDIR=$(WINTOPDIR) -CTOPDIR=$(WINTOPDIR) -CYGPATH=cygpath -m -DIFF=/usr/bin/diff -q --strip-trailing-cr -FIND=/usr/bin/find -SORT=/usr/bin/sort -SET_LD_PATH=PATH="$(PATH):$(LD_PATH)" -MAX_TESTSUITE_DIR_RETRIES=1 -FLAT_FLOAT_ARRAY=true diff --git a/config/auto-aux/align.c b/config/auto-aux/align.c deleted file mode 100644 index c5f5f3f0..00000000 --- a/config/auto-aux/align.c +++ /dev/null @@ -1,103 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include -#include -#include - -long foo; - -void access16(short int *p) -{ - foo = *p; -} - -void access32(long int *p) -{ - foo = *p; -} - -jmp_buf failure; - -void sig_handler(int dummy) -{ - longjmp(failure, 1); -} - -int test(void (*fct) (/* ??? */), char *p) -{ - int res; - - signal(SIGSEGV, sig_handler); - signal(SIGBUS, sig_handler); - if(setjmp(failure) == 0) { - fct(p); - res = 0; - } else { - res = 1; - } - signal(SIGSEGV, SIG_DFL); - signal(SIGBUS, SIG_DFL); - return res; -} - -jmp_buf timer; - -void alarm_handler(int dummy) -{ - longjmp(timer, 1); -} - -void use(int n) -{ - return; -} - -int speedtest(char *p) -{ - int * q; - volatile int total; - int i; - volatile int sum; - - signal(SIGALRM, alarm_handler); - sum = 0; - if (setjmp(timer) == 0) { - alarm(1); - total = 0; - while(1) { - for (q = (int *) p, i = 1000; i > 0; q++, i--) - sum += *q; - total++; - } - } - use(sum); - signal(SIGALRM, SIG_DFL); - return total; -} - -main(void) -{ - long n[1001]; - int speed_aligned, speed_unaligned; - - if (test(access16, (char *) n + 1)) exit(1); - if (test(access32, (char *) n + 1)) exit(1); - if (test(access32, (char *) n + 2)) exit(1); - speed_aligned = speedtest((char *) n); - speed_unaligned = speedtest((char *) n + 1); - if (speed_aligned >= 3 * speed_unaligned) exit(1); - exit(0); -} diff --git a/config/auto-aux/ansi.c b/config/auto-aux/ansi.c deleted file mode 100644 index 65d82400..00000000 --- a/config/auto-aux/ansi.c +++ /dev/null @@ -1,27 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -int main() -{ -#ifdef __STDC__ -#if defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L - return 0; -#else - return 1; -#endif -#else - return 2; -#endif -} diff --git a/config/auto-aux/async_io.c b/config/auto-aux/async_io.c deleted file mode 100644 index b8f52572..00000000 --- a/config/auto-aux/async_io.c +++ /dev/null @@ -1,60 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include -#include -#include -#include -#include -#include -#include "s.h" - -int signalled; - -void sigio_handler(int arg) -{ - signalled = 1; -} - -int main(void) -{ -#if defined(SIGIO) && defined(FASYNC) && defined(F_SETFL) && defined(F_SETOWN) - int p[2]; - int ret; -#define OUT 0 -#define IN 1 - if (socketpair(PF_UNIX, SOCK_STREAM, 0, p) == -1) return 1; - signalled = 0; - signal(SIGIO, sigio_handler); - ret = fcntl(p[OUT], F_GETFL, 0); - fcntl(p[OUT], F_SETFL, ret | FASYNC); - fcntl(p[OUT], F_SETOWN, getpid()); - switch(fork()) { - case -1: - return 1; - case 0: - close(p[OUT]); - write(p[IN], "x", 1); - sleep(1); - exit(0); - default: - close(p[IN]); - while(wait(NULL) == -1 && errno == EINTR) /*nothing*/; - } - if (signalled) return 0; else return 1; -#else - return 1; -#endif -} diff --git a/config/auto-aux/cckind.c b/config/auto-aux/cckind.c deleted file mode 100644 index 203f701f..00000000 --- a/config/auto-aux/cckind.c +++ /dev/null @@ -1,32 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ -/* */ -/* Copyright 2015 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -/* Determine vendor and version of C compiler */ - -/* This file is to be preprocessed and its output examined. */ -/* It is not C source code to be executed. */ -/* This helps with cross-compilation. */ - -#if defined(__INTEL_COMPILER) -icc __INTEL_COMPILER -#elif defined(__clang_major__) && defined(__clang_minor__) -clang __clang_major__ __clang_minor__ -#elif defined(__GNUC__) && defined(__GNUC_MINOR__) -gcc __GNUC__ __GNUC_MINOR__ -#elif defined(__xlc__) && (__xlC__) -xlc __xlC__ __xlC_ver__ -#else -unknown -#endif diff --git a/config/auto-aux/cfi.S b/config/auto-aux/cfi.S deleted file mode 100644 index acd052df..00000000 --- a/config/auto-aux/cfi.S +++ /dev/null @@ -1,6 +0,0 @@ -camlPervasives__loop_1128: - .file 1 "pervasives.ml" - .loc 1 193 - .cfi_startproc - .cfi_adjust_cfa_offset 8 - .cfi_endproc diff --git a/config/auto-aux/dblalign.c b/config/auto-aux/dblalign.c deleted file mode 100644 index 69097103..00000000 --- a/config/auto-aux/dblalign.c +++ /dev/null @@ -1,54 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include -#include -#include - -volatile double foo; - -void access_double(volatile double *p) -{ - foo = *p; -} - -jmp_buf failure; - -void sig_handler(int sig) -{ - longjmp(failure, 1); -} - -int main(void) -{ - long n[10]; - int res; - signal(SIGSEGV, sig_handler); -#ifdef SIGBUS - signal(SIGBUS, sig_handler); -#endif - if(setjmp(failure) == 0) { - access_double((volatile double *) n); - access_double((volatile double *) (n+1)); - res = 0; - } else { - res = 1; - } - signal(SIGSEGV, SIG_DFL); -#ifdef SIGBUS - signal(SIGBUS, SIG_DFL); -#endif - return res; -} diff --git a/config/auto-aux/elf.c b/config/auto-aux/elf.c deleted file mode 100644 index e7f044b9..00000000 --- a/config/auto-aux/elf.c +++ /dev/null @@ -1,26 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1999 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include - -int main(int argc, char ** argv) -{ -#ifdef __ELF__ - printf("elf\n"); -#else - printf("aout\n"); -#endif - return 0; -} diff --git a/config/auto-aux/endian.c b/config/auto-aux/endian.c deleted file mode 100644 index bd2bbe04..00000000 --- a/config/auto-aux/endian.c +++ /dev/null @@ -1,42 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include -#include "m.h" - -#ifndef ARCH_SIXTYFOUR -long intval = 0x41424344L; -char * bigendian = "ABCD"; -char * littleendian = "DCBA"; -#else -long intval = 0x4142434445464748L; -char * bigendian = "ABCDEFGH"; -char * littleendian = "HGFEDCBA"; -#endif - -int main(void) -{ - long n[2]; - char * p; - - n[0] = intval; - n[1] = 0; - p = (char *) n; - if (strcmp(p, bigendian) == 0) - return 0; - if (strcmp(p, littleendian) == 0) - return 1; - return 2; -} diff --git a/config/auto-aux/getgroups.c b/config/auto-aux/getgroups.c deleted file mode 100644 index a538ed03..00000000 --- a/config/auto-aux/getgroups.c +++ /dev/null @@ -1,32 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include -#include - -#ifdef NGROUPS_MAX - -int main(void) -{ - int gidset[NGROUPS_MAX]; - if (getgroups(NGROUPS_MAX, gidset) == -1) return 1; - return 0; -} - -#else - -int main(void) { return 1; } - -#endif diff --git a/config/auto-aux/gethostbyaddr.c b/config/auto-aux/gethostbyaddr.c deleted file mode 100644 index a932d11f..00000000 --- a/config/auto-aux/gethostbyaddr.c +++ /dev/null @@ -1,55 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#ifndef _REENTRANT -/* This helps detection on Digital Unix... */ -#define _REENTRANT -#endif - -#include -#include - -#ifdef SYS_netbsd -#error "this OS doesn't have gethostbyaddr_r" -#endif - -int main(int argc, char ** argv) -{ -#if NUM_ARGS == 7 - char * address; - int length; - int type; - struct hostent h; - char buffer[10]; - int buflen; - int h_errnop; - struct hostent * hp; - hp = gethostbyaddr_r(address, length, type, &h, - buffer, buflen, &h_errnop); -#elif NUM_ARGS == 8 - char * address; - int length; - int type; - struct hostent h; - char buffer[10]; - int buflen; - int h_errnop; - struct hostent * hp; - int rc; - rc = gethostbyaddr_r(address, length, type, &h, - buffer, buflen, &hp, &h_errnop); -#endif - return 0; -} diff --git a/config/auto-aux/gethostbyname.c b/config/auto-aux/gethostbyname.c deleted file mode 100644 index aefd85fc..00000000 --- a/config/auto-aux/gethostbyname.c +++ /dev/null @@ -1,45 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#ifndef _REENTRANT -/* This helps detection on Digital Unix... */ -#define _REENTRANT -#endif - -#include -#include - -#ifdef SYS_netbsd -#error "this OS doesn't have gethostbyname_r" -#endif - -int main(int argc, char ** argv) -{ -#if NUM_ARGS == 5 - struct hostent *hp; - struct hostent h; - char buffer[1000]; - int h_errno; - hp = gethostbyname_r("www.caml.org", &h, buffer, 10, &h_errno); -#elif NUM_ARGS == 6 - struct hostent *hp; - struct hostent h; - char buffer[1000]; - int h_errno; - int rc; - rc = gethostbyname_r("www.caml.org", &h, buffer, 10, &hp, &h_errno); -#endif - return 0; -} diff --git a/config/auto-aux/hasgot b/config/auto-aux/hasgot deleted file mode 100755 index 54281a42..00000000 --- a/config/auto-aux/hasgot +++ /dev/null @@ -1,47 +0,0 @@ -#!/bin/sh - -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -#* * -#* Copyright 1995 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -opts="" -libs="$cclibs" -args=$* -rm -f hasgot.c -var="x" -while : ; do - case "$1" in - -i) echo "#include <$2>" >> hasgot.c; shift;; - -t) echo "$2 $var;" >> hasgot.c; var="x$var"; shift;; - -Xl) libs="$libs $2"; shift;; - -l*|-L*|-F*) libs="$libs $1";; - -framework) libs="$libs $1 $2"; shift;; - -*) opts="$opts $1";; - *) break;; - esac - shift -done - -(echo "int main() {" - for f in $*; do echo " $f();"; done - echo " return 0; }") >> hasgot.c - -cmd="$cc $cflags $opts -o tst hasgot.c $ldflags $libs" - -if $verbose; then - echo "hasgot $args: $cmd" >&2 - exec $cmd > /dev/null -else - exec $cmd > /dev/null 2>/dev/null -fi diff --git a/config/auto-aux/hasgot2 b/config/auto-aux/hasgot2 deleted file mode 100644 index 5a3444e0..00000000 --- a/config/auto-aux/hasgot2 +++ /dev/null @@ -1,46 +0,0 @@ -#!/bin/sh - -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -#* * -#* Copyright 2011 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -opts="" -libs="$cclibs" -args=$* -rm -f hasgot.c -var="x" -while : ; do - case "$1" in - -i) echo "#include <$2>" >> hasgot.c; shift;; - -t) echo "$2 $var;" >> hasgot.c; var="x$var"; shift;; - -l*|-L*|-F*) libs="$libs $1";; - -framework) libs="$libs $1 $2"; shift;; - -*) opts="$opts $1";; - *) break;; - esac - shift -done - -(echo "int main() {" - for f in $*; do echo " (void) & $f;"; done - echo " return 0; }") >> hasgot.c - -cmd="$cc $cflags $opts -o tst hasgot.c $ldflags $libs" - -if $verbose; then - echo "hasgot2 $args: $cmd" >&2 - exec $cmd > /dev/null -else - exec $cmd > /dev/null 2>/dev/null -fi diff --git a/config/auto-aux/hashbang b/config/auto-aux/hashbang deleted file mode 100755 index eb447baa..00000000 --- a/config/auto-aux/hashbang +++ /dev/null @@ -1,2 +0,0 @@ -#! /bin/cat -exit 1 diff --git a/config/auto-aux/hashbang2 b/config/auto-aux/hashbang2 deleted file mode 100755 index 37530963..00000000 --- a/config/auto-aux/hashbang2 +++ /dev/null @@ -1,2 +0,0 @@ -#! /usr/bin/cat -exit 1 diff --git a/config/auto-aux/hashbang3 b/config/auto-aux/hashbang3 deleted file mode 100755 index 90002cbd..00000000 --- a/config/auto-aux/hashbang3 +++ /dev/null @@ -1,2 +0,0 @@ -#! /usr/bin/env cat -exit 1 diff --git a/config/auto-aux/ia32sse2.c b/config/auto-aux/ia32sse2.c deleted file mode 100644 index d0391eaf..00000000 --- a/config/auto-aux/ia32sse2.c +++ /dev/null @@ -1,24 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -/* Test whether IA32 assembler supports SSE2 instructions */ - -int main() -{ - asm("pmuludq %mm1, %mm0"); - asm("paddq %mm1, %mm0"); - asm("psubq %mm1, %mm0"); - return 0; -} diff --git a/config/auto-aux/initgroups.c b/config/auto-aux/initgroups.c deleted file mode 100644 index af968039..00000000 --- a/config/auto-aux/initgroups.c +++ /dev/null @@ -1,26 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Contributed by Stephane Glondu */ -/* */ -/* Copyright 2009 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include - -#include -#include -#include - -int main(void) -{ - if (initgroups("root", 0) == -1 && errno != EPERM) return 1; - return 0; -} diff --git a/config/auto-aux/int64align.c b/config/auto-aux/int64align.c deleted file mode 100644 index adf9821e..00000000 --- a/config/auto-aux/int64align.c +++ /dev/null @@ -1,65 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include -#include -#include -#include "m.h" - -#if defined(ARCH_INT64_TYPE) -typedef ARCH_INT64_TYPE myint64_t; -#elif SIZEOF_LONG == 8 -typedef long myint64_t; -#elif SIZEOF_LONGLONG == 8 -typedef long long myint64_t; -#else -#error "No 64-bit integer type available" -#endif - -volatile myint64_t foo; - -void access_int64(volatile myint64_t *p) -{ - foo = *p; -} - -jmp_buf failure; - -void sig_handler(int sig) -{ - longjmp(failure, 1); -} - -int main(void) -{ - long n[10]; - int res; - signal(SIGSEGV, sig_handler); -#ifdef SIGBUS - signal(SIGBUS, sig_handler); -#endif - if(setjmp(failure) == 0) { - access_int64((volatile myint64_t *) n); - access_int64((volatile myint64_t *) (n+1)); - res = 0; - } else { - res = 1; - } - signal(SIGSEGV, SIG_DFL); -#ifdef SIGBUS - signal(SIGBUS, SIG_DFL); -#endif - return res; -} diff --git a/config/auto-aux/mmap-huge.c b/config/auto-aux/mmap-huge.c deleted file mode 100644 index 9bd43ba1..00000000 --- a/config/auto-aux/mmap-huge.c +++ /dev/null @@ -1,51 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, Jane Street Group, LLC */ -/* */ -/* Copyright 2015 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include -#include -#include - -#define huge_page_size (4 * 1024 * 1024) - -/* Test for the possible availability of huge pages. Answer yes - if the OS knows about huge pages, even if they are not available - on the build machine at configure time, because (on Linux) huge - pages can be activated and deactivated easily while the system - is running. -*/ - -int main (int argc, char *argv[]){ - void *block; - char *p; - int i, res; - block = mmap (NULL, huge_page_size, PROT_READ | PROT_WRITE, - MAP_PRIVATE | MAP_ANONYMOUS | MAP_HUGETLB, - -1, 0); - if (block == MAP_FAILED){ - block = mmap (NULL, huge_page_size, PROT_READ | PROT_WRITE, - MAP_PRIVATE | MAP_ANONYMOUS, - -1, 0); - } - if (block == MAP_FAILED){ - perror ("mmap"); - return 3; - } - /*printf ("block = %p\n", block);*/ - p = (char *) block; - for (i = 0; i < huge_page_size; i += 4096){ - p[i] = (char) i; - } - return 0; -} diff --git a/config/auto-aux/nanosecond_stat.c b/config/auto-aux/nanosecond_stat.c deleted file mode 100644 index 8a15a30d..00000000 --- a/config/auto-aux/nanosecond_stat.c +++ /dev/null @@ -1,30 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Jeremie Dimino, Jane Street Group, LLC */ -/* */ -/* Copyright 2015 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#define _GNU_SOURCE -#include -#include -#include - -#include "../../otherlibs/unix/nanosecond_stat.h" - -int main() { - struct stat *buf; - double a, m, c; - a = (double)NSEC(buf, a); - m = (double)NSEC(buf, m); - c = (double)NSEC(buf, c); - return 0; -} diff --git a/config/auto-aux/runtest b/config/auto-aux/runtest deleted file mode 100755 index c889a0db..00000000 --- a/config/auto-aux/runtest +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/sh - -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -#* * -#* Copyright 1995 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -cmd="$cc $cflags -o tst $* $ldflags $cclibs" - -if $verbose; then - echo "runtest: $cmd" >&2 - $cmd || exit 100 -else - $cmd 2> /dev/null || exit 100 -fi -exec ./tst diff --git a/config/auto-aux/searchpath b/config/auto-aux/searchpath deleted file mode 100755 index 0f5d9e8c..00000000 --- a/config/auto-aux/searchpath +++ /dev/null @@ -1,34 +0,0 @@ -#!/bin/sh - -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -#* * -#* Copyright 1996 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -# Find a program in the path - -doprint=false -case $1 in - -p) shift; doprint=true;; - *) ;; -esac - -IFS=':' -for dir in $PATH; do - if test -z "$dir"; then dir=.; fi - if test -f $dir/$1 -a -x $dir/$1; then - if $doprint; then echo "$dir/$1"; fi - exit 0 - fi -done -exit 1 diff --git a/config/auto-aux/setgroups.c b/config/auto-aux/setgroups.c deleted file mode 100644 index 8a9e3658..00000000 --- a/config/auto-aux/setgroups.c +++ /dev/null @@ -1,28 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Contributed by Stephane Glondu */ -/* */ -/* Copyright 2009 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include - -#include -#include -#include - -int main(void) -{ - gid_t gidset[1]; - gidset[0] = 0; - if (setgroups(1, gidset) == -1 && errno != EPERM) return 1; - return 0; -} diff --git a/config/auto-aux/signals.c b/config/auto-aux/signals.c deleted file mode 100644 index 90b893f7..00000000 --- a/config/auto-aux/signals.c +++ /dev/null @@ -1,68 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -/* To determine the semantics of signal handlers - (System V: signal is reset to default behavior on entrance to the handler - BSD: signal handler remains active). */ - -#include -#include - -/* Find a signal that is ignored by default */ - -#ifdef SIGCHLD -#define IGNSIG SIGCHLD -#else -#ifdef SIGIO -#define IGNSIG SIGIO -#else -#ifdef SIGCLD -#define IGNSIG SIGCLD -#else -#ifdef SIGPWR -#define IGNSIG SIGPWR -#endif -#endif -#endif -#endif - -#ifdef IGNSIG - -int counter; - -void sig_handler(int dummy) -{ - counter++; -} - -int main(int argc, char **argv) -{ - signal(IGNSIG, sig_handler); - counter = 0; - kill(getpid(), IGNSIG); - kill(getpid(), IGNSIG); - return (counter == 2 ? 0 : 1); -} - -#else - -/* If no suitable signal was found, assume System V */ - -int main(int argc, char ** argv) -{ - return 1; -} - -#endif diff --git a/config/auto-aux/simple.S b/config/auto-aux/simple.S deleted file mode 100644 index c27acb72..00000000 --- a/config/auto-aux/simple.S +++ /dev/null @@ -1,3 +0,0 @@ -camlPervasives__loop_1128: - .file 1 "pervasives.ml" - .loc 1 193 diff --git a/config/auto-aux/sizes.c b/config/auto-aux/sizes.c deleted file mode 100644 index ffa9fb7d..00000000 --- a/config/auto-aux/sizes.c +++ /dev/null @@ -1,27 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include - -int main(int argc, char **argv) -{ - printf("%d %d %d %d %d\n", - (int) sizeof(int), - (int) sizeof(long), - (int) sizeof(long *), - (int) sizeof(short), - (int) sizeof(long long)); - return 0; -} diff --git a/config/auto-aux/solaris-ld b/config/auto-aux/solaris-ld deleted file mode 100644 index 48239ac8..00000000 --- a/config/auto-aux/solaris-ld +++ /dev/null @@ -1,23 +0,0 @@ -#!/bin/sh - -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -#* * -#* Copyright 2001 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -# Determine if gcc calls the Solaris ld or the GNU ld -# Exit code is 0 for Solaris ld, 1 for GNU ld - -echo "int main() { return 0; }" > hasgot.c -$cc $cflags -v -o tst hasgot.c $ldflags 2>&1 | grep -s '^ld:' > /dev/null -exit $? diff --git a/config/auto-aux/tryassemble b/config/auto-aux/tryassemble deleted file mode 100644 index c07c1361..00000000 --- a/config/auto-aux/tryassemble +++ /dev/null @@ -1,33 +0,0 @@ -#!/bin/sh - -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -#* * -#* Copyright 2012 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -if $verbose; then - echo "tryassemble: $aspp -o tst $*" >&2 - $aspp -o tst $* || exit 100 -else - $aspp -o tst $* 2> /dev/null || exit 100 -fi - -# test as also (if differs) -if test "$aspp" != "$as"; then - if $verbose; then - echo "tryassemble: $as -o tst $*" >&2 - $as -o tst $* || exit 100 - else - $as -o tst $* 2> /dev/null || exit 100 - fi -fi diff --git a/config/auto-aux/trycompile b/config/auto-aux/trycompile deleted file mode 100755 index c6974132..00000000 --- a/config/auto-aux/trycompile +++ /dev/null @@ -1,25 +0,0 @@ -#!/bin/sh - -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -#* * -#* Copyright 2002 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -cmd="$cc $cflags -o tst $* $ldflags $cclibs" - -if $verbose; then - echo "trycompile: $cmd" >&2 - $cmd || exit 100 -else - $cmd 2> /dev/null || exit 100 -fi diff --git a/config/gnu/config.guess b/config/gnu/config.guess deleted file mode 100755 index b79252d6..00000000 --- a/config/gnu/config.guess +++ /dev/null @@ -1,1558 +0,0 @@ -#! /bin/sh -# Attempt to guess a canonical system name. -# Copyright 1992-2013 Free Software Foundation, Inc. - -timestamp='2013-06-10' - -# This file is free software; you can redistribute it and/or modify it -# under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 3 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, see . -# -# As a special exception to the GNU General Public License, if you -# distribute this file as part of a program that contains a -# configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that -# program. This Exception is an additional permission under section 7 -# of the GNU General Public License, version 3 ("GPLv3"). -# -# Originally written by Per Bothner. -# -# You can get the latest version of this script from: -# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD -# -# Please send patches with a ChangeLog entry to config-patches@gnu.org. - - -me=`echo "$0" | sed -e 's,.*/,,'` - -usage="\ -Usage: $0 [OPTION] - -Output the configuration name of the system \`$me' is run on. - -Operation modes: - -h, --help print this help, then exit - -t, --time-stamp print date of last modification, then exit - -v, --version print version number, then exit - -Report bugs and patches to ." - -version="\ -GNU config.guess ($timestamp) - -Originally written by Per Bothner. -Copyright 1992-2013 Free Software Foundation, Inc. - -This is free software; see the source for copying conditions. There is NO -warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." - -help=" -Try \`$me --help' for more information." - -# Parse command line -while test $# -gt 0 ; do - case $1 in - --time-stamp | --time* | -t ) - echo "$timestamp" ; exit ;; - --version | -v ) - echo "$version" ; exit ;; - --help | --h* | -h ) - echo "$usage"; exit ;; - -- ) # Stop option processing - shift; break ;; - - ) # Use stdin as input. - break ;; - -* ) - echo "$me: invalid option $1$help" >&2 - exit 1 ;; - * ) - break ;; - esac -done - -if test $# != 0; then - echo "$me: too many arguments$help" >&2 - exit 1 -fi - -trap 'exit 1' 1 2 15 - -# CC_FOR_BUILD -- compiler used by this script. Note that the use of a -# compiler to aid in system detection is discouraged as it requires -# temporary files to be created and, as you can see below, it is a -# headache to deal with in a portable fashion. - -# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still -# use `HOST_CC' if defined, but it is deprecated. - -# Portable tmp directory creation inspired by the Autoconf team. - -set_cc_for_build=' -trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; -trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; -: ${TMPDIR=/tmp} ; - { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || - { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || - { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || - { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; -dummy=$tmp/dummy ; -tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; -case $CC_FOR_BUILD,$HOST_CC,$CC in - ,,) echo "int x;" > $dummy.c ; - for c in cc gcc c89 c99 ; do - if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then - CC_FOR_BUILD="$c"; break ; - fi ; - done ; - if test x"$CC_FOR_BUILD" = x ; then - CC_FOR_BUILD=no_compiler_found ; - fi - ;; - ,,*) CC_FOR_BUILD=$CC ;; - ,*,*) CC_FOR_BUILD=$HOST_CC ;; -esac ; set_cc_for_build= ;' - -# This is needed to find uname on a Pyramid OSx when run in the BSD universe. -# (ghazi@noc.rutgers.edu 1994-08-24) -if (test -f /.attbin/uname) >/dev/null 2>&1 ; then - PATH=$PATH:/.attbin ; export PATH -fi - -UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown -UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown -UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown -UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown - -case "${UNAME_SYSTEM}" in -Linux|GNU|GNU/*) - # If the system lacks a compiler, then just pick glibc. - # We could probably try harder. - LIBC=gnu - - eval $set_cc_for_build - cat <<-EOF > $dummy.c - #include - #if defined(__UCLIBC__) - LIBC=uclibc - #elif defined(__dietlibc__) - LIBC=dietlibc - #else - LIBC=gnu - #endif - EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC'` - ;; -esac - -# Note: order is significant - the case branches are not exclusive. - -case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in - *:NetBSD:*:*) - # NetBSD (nbsd) targets should (where applicable) match one or - # more of the tuples: *-*-netbsdelf*, *-*-netbsdaout*, - # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently - # switched to ELF, *-*-netbsd* would select the old - # object file format. This provides both forward - # compatibility and a consistent mechanism for selecting the - # object file format. - # - # Note: NetBSD doesn't particularly care about the vendor - # portion of the name. We always set it to "unknown". - sysctl="sysctl -n hw.machine_arch" - UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ - /usr/sbin/$sysctl 2>/dev/null || echo unknown)` - case "${UNAME_MACHINE_ARCH}" in - armeb) machine=armeb-unknown ;; - arm*) machine=arm-unknown ;; - sh3el) machine=shl-unknown ;; - sh3eb) machine=sh-unknown ;; - sh5el) machine=sh5le-unknown ;; - *) machine=${UNAME_MACHINE_ARCH}-unknown ;; - esac - # The Operating System including object format, if it has switched - # to ELF recently, or will in the future. - case "${UNAME_MACHINE_ARCH}" in - arm*|i386|m68k|ns32k|sh3*|sparc|vax) - eval $set_cc_for_build - if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ - | grep -q __ELF__ - then - # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). - # Return netbsd for either. FIX? - os=netbsd - else - os=netbsdelf - fi - ;; - *) - os=netbsd - ;; - esac - # The OS release - # Debian GNU/NetBSD machines have a different userland, and - # thus, need a distinct triplet. However, they do not need - # kernel version information, so it can be replaced with a - # suitable tag, in the style of linux-gnu. - case "${UNAME_VERSION}" in - Debian*) - release='-gnu' - ;; - *) - release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` - ;; - esac - # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: - # contains redundant information, the shorter form: - # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. - echo "${machine}-${os}${release}" - exit ;; - *:Bitrig:*:*) - UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'` - echo ${UNAME_MACHINE_ARCH}-unknown-bitrig${UNAME_RELEASE} - exit ;; - *:OpenBSD:*:*) - UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` - echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} - exit ;; - *:ekkoBSD:*:*) - echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} - exit ;; - *:SolidBSD:*:*) - echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} - exit ;; - macppc:MirBSD:*:*) - echo powerpc-unknown-mirbsd${UNAME_RELEASE} - exit ;; - *:MirBSD:*:*) - echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} - exit ;; - alpha:OSF1:*:*) - case $UNAME_RELEASE in - *4.0) - UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` - ;; - *5.*) - UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` - ;; - esac - # According to Compaq, /usr/sbin/psrinfo has been available on - # OSF/1 and Tru64 systems produced since 1995. I hope that - # covers most systems running today. This code pipes the CPU - # types through head -n 1, so we only detect the type of CPU 0. - ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` - case "$ALPHA_CPU_TYPE" in - "EV4 (21064)") - UNAME_MACHINE="alpha" ;; - "EV4.5 (21064)") - UNAME_MACHINE="alpha" ;; - "LCA4 (21066/21068)") - UNAME_MACHINE="alpha" ;; - "EV5 (21164)") - UNAME_MACHINE="alphaev5" ;; - "EV5.6 (21164A)") - UNAME_MACHINE="alphaev56" ;; - "EV5.6 (21164PC)") - UNAME_MACHINE="alphapca56" ;; - "EV5.7 (21164PC)") - UNAME_MACHINE="alphapca57" ;; - "EV6 (21264)") - UNAME_MACHINE="alphaev6" ;; - "EV6.7 (21264A)") - UNAME_MACHINE="alphaev67" ;; - "EV6.8CB (21264C)") - UNAME_MACHINE="alphaev68" ;; - "EV6.8AL (21264B)") - UNAME_MACHINE="alphaev68" ;; - "EV6.8CX (21264D)") - UNAME_MACHINE="alphaev68" ;; - "EV6.9A (21264/EV69A)") - UNAME_MACHINE="alphaev69" ;; - "EV7 (21364)") - UNAME_MACHINE="alphaev7" ;; - "EV7.9 (21364A)") - UNAME_MACHINE="alphaev79" ;; - esac - # A Pn.n version is a patched version. - # A Vn.n version is a released version. - # A Tn.n version is a released field test version. - # A Xn.n version is an unreleased experimental baselevel. - # 1.2 uses "1.2" for uname -r. - echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` - # Reset EXIT trap before exiting to avoid spurious non-zero exit code. - exitcode=$? - trap '' 0 - exit $exitcode ;; - Alpha\ *:Windows_NT*:*) - # How do we know it's Interix rather than the generic POSIX subsystem? - # Should we change UNAME_MACHINE based on the output of uname instead - # of the specific Alpha model? - echo alpha-pc-interix - exit ;; - 21064:Windows_NT:50:3) - echo alpha-dec-winnt3.5 - exit ;; - Amiga*:UNIX_System_V:4.0:*) - echo m68k-unknown-sysv4 - exit ;; - *:[Aa]miga[Oo][Ss]:*:*) - echo ${UNAME_MACHINE}-unknown-amigaos - exit ;; - *:[Mm]orph[Oo][Ss]:*:*) - echo ${UNAME_MACHINE}-unknown-morphos - exit ;; - *:OS/390:*:*) - echo i370-ibm-openedition - exit ;; - *:z/VM:*:*) - echo s390-ibm-zvmoe - exit ;; - *:OS400:*:*) - echo powerpc-ibm-os400 - exit ;; - arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) - echo arm-acorn-riscix${UNAME_RELEASE} - exit ;; - arm*:riscos:*:*|arm*:RISCOS:*:*) - echo arm-unknown-riscos - exit ;; - SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) - echo hppa1.1-hitachi-hiuxmpp - exit ;; - Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) - # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. - if test "`(/bin/universe) 2>/dev/null`" = att ; then - echo pyramid-pyramid-sysv3 - else - echo pyramid-pyramid-bsd - fi - exit ;; - NILE*:*:*:dcosx) - echo pyramid-pyramid-svr4 - exit ;; - DRS?6000:unix:4.0:6*) - echo sparc-icl-nx6 - exit ;; - DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) - case `/usr/bin/uname -p` in - sparc) echo sparc-icl-nx7; exit ;; - esac ;; - s390x:SunOS:*:*) - echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - sun4H:SunOS:5.*:*) - echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) - echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) - echo i386-pc-auroraux${UNAME_RELEASE} - exit ;; - i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) - eval $set_cc_for_build - SUN_ARCH="i386" - # If there is a compiler, see if it is configured for 64-bit objects. - # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. - # This test works for both compilers. - if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then - if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ - (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ - grep IS_64BIT_ARCH >/dev/null - then - SUN_ARCH="x86_64" - fi - fi - echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - sun4*:SunOS:6*:*) - # According to config.sub, this is the proper way to canonicalize - # SunOS6. Hard to guess exactly what SunOS6 will be like, but - # it's likely to be more like Solaris than SunOS4. - echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - sun4*:SunOS:*:*) - case "`/usr/bin/arch -k`" in - Series*|S4*) - UNAME_RELEASE=`uname -v` - ;; - esac - # Japanese Language versions have a version number like `4.1.3-JL'. - echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` - exit ;; - sun3*:SunOS:*:*) - echo m68k-sun-sunos${UNAME_RELEASE} - exit ;; - sun*:*:4.2BSD:*) - UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` - test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 - case "`/bin/arch`" in - sun3) - echo m68k-sun-sunos${UNAME_RELEASE} - ;; - sun4) - echo sparc-sun-sunos${UNAME_RELEASE} - ;; - esac - exit ;; - aushp:SunOS:*:*) - echo sparc-auspex-sunos${UNAME_RELEASE} - exit ;; - # The situation for MiNT is a little confusing. The machine name - # can be virtually everything (everything which is not - # "atarist" or "atariste" at least should have a processor - # > m68000). The system name ranges from "MiNT" over "FreeMiNT" - # to the lowercase version "mint" (or "freemint"). Finally - # the system name "TOS" denotes a system which is actually not - # MiNT. But MiNT is downward compatible to TOS, so this should - # be no problem. - atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit ;; - atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit ;; - *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit ;; - milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) - echo m68k-milan-mint${UNAME_RELEASE} - exit ;; - hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) - echo m68k-hades-mint${UNAME_RELEASE} - exit ;; - *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) - echo m68k-unknown-mint${UNAME_RELEASE} - exit ;; - m68k:machten:*:*) - echo m68k-apple-machten${UNAME_RELEASE} - exit ;; - powerpc:machten:*:*) - echo powerpc-apple-machten${UNAME_RELEASE} - exit ;; - RISC*:Mach:*:*) - echo mips-dec-mach_bsd4.3 - exit ;; - RISC*:ULTRIX:*:*) - echo mips-dec-ultrix${UNAME_RELEASE} - exit ;; - VAX*:ULTRIX*:*:*) - echo vax-dec-ultrix${UNAME_RELEASE} - exit ;; - 2020:CLIX:*:* | 2430:CLIX:*:*) - echo clipper-intergraph-clix${UNAME_RELEASE} - exit ;; - mips:*:*:UMIPS | mips:*:*:RISCos) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c -#ifdef __cplusplus -#include /* for printf() prototype */ - int main (int argc, char *argv[]) { -#else - int main (argc, argv) int argc; char *argv[]; { -#endif - #if defined (host_mips) && defined (MIPSEB) - #if defined (SYSTYPE_SYSV) - printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); - #endif - #if defined (SYSTYPE_SVR4) - printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); - #endif - #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) - printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); - #endif - #endif - exit (-1); - } -EOF - $CC_FOR_BUILD -o $dummy $dummy.c && - dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && - SYSTEM_NAME=`$dummy $dummyarg` && - { echo "$SYSTEM_NAME"; exit; } - echo mips-mips-riscos${UNAME_RELEASE} - exit ;; - Motorola:PowerMAX_OS:*:*) - echo powerpc-motorola-powermax - exit ;; - Motorola:*:4.3:PL8-*) - echo powerpc-harris-powermax - exit ;; - Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) - echo powerpc-harris-powermax - exit ;; - Night_Hawk:Power_UNIX:*:*) - echo powerpc-harris-powerunix - exit ;; - m88k:CX/UX:7*:*) - echo m88k-harris-cxux7 - exit ;; - m88k:*:4*:R4*) - echo m88k-motorola-sysv4 - exit ;; - m88k:*:3*:R3*) - echo m88k-motorola-sysv3 - exit ;; - AViiON:dgux:*:*) - # DG/UX returns AViiON for all architectures - UNAME_PROCESSOR=`/usr/bin/uname -p` - if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] - then - if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ - [ ${TARGET_BINARY_INTERFACE}x = x ] - then - echo m88k-dg-dgux${UNAME_RELEASE} - else - echo m88k-dg-dguxbcs${UNAME_RELEASE} - fi - else - echo i586-dg-dgux${UNAME_RELEASE} - fi - exit ;; - M88*:DolphinOS:*:*) # DolphinOS (SVR3) - echo m88k-dolphin-sysv3 - exit ;; - M88*:*:R3*:*) - # Delta 88k system running SVR3 - echo m88k-motorola-sysv3 - exit ;; - XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) - echo m88k-tektronix-sysv3 - exit ;; - Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) - echo m68k-tektronix-bsd - exit ;; - *:IRIX*:*:*) - echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` - exit ;; - ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. - echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id - exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' - i*86:AIX:*:*) - echo i386-ibm-aix - exit ;; - ia64:AIX:*:*) - if [ -x /usr/bin/oslevel ] ; then - IBM_REV=`/usr/bin/oslevel` - else - IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} - fi - echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} - exit ;; - *:AIX:2:3) - if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #include - - main() - { - if (!__power_pc()) - exit(1); - puts("powerpc-ibm-aix3.2.5"); - exit(0); - } -EOF - if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` - then - echo "$SYSTEM_NAME" - else - echo rs6000-ibm-aix3.2.5 - fi - elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then - echo rs6000-ibm-aix3.2.4 - else - echo rs6000-ibm-aix3.2 - fi - exit ;; - *:AIX:*:[4567]) - IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` - if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then - IBM_ARCH=rs6000 - else - IBM_ARCH=powerpc - fi - if [ -x /usr/bin/oslevel ] ; then - IBM_REV=`/usr/bin/oslevel` - else - IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} - fi - echo ${IBM_ARCH}-ibm-aix${IBM_REV} - exit ;; - *:AIX:*:*) - echo rs6000-ibm-aix - exit ;; - ibmrt:4.4BSD:*|romp-ibm:BSD:*) - echo romp-ibm-bsd4.4 - exit ;; - ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and - echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to - exit ;; # report: romp-ibm BSD 4.3 - *:BOSX:*:*) - echo rs6000-bull-bosx - exit ;; - DPX/2?00:B.O.S.:*:*) - echo m68k-bull-sysv3 - exit ;; - 9000/[34]??:4.3bsd:1.*:*) - echo m68k-hp-bsd - exit ;; - hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) - echo m68k-hp-bsd4.4 - exit ;; - 9000/[34678]??:HP-UX:*:*) - HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` - case "${UNAME_MACHINE}" in - 9000/31? ) HP_ARCH=m68000 ;; - 9000/[34]?? ) HP_ARCH=m68k ;; - 9000/[678][0-9][0-9]) - if [ -x /usr/bin/getconf ]; then - sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` - sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` - case "${sc_cpu_version}" in - 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 - 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 - 532) # CPU_PA_RISC2_0 - case "${sc_kernel_bits}" in - 32) HP_ARCH="hppa2.0n" ;; - 64) HP_ARCH="hppa2.0w" ;; - '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 - esac ;; - esac - fi - if [ "${HP_ARCH}" = "" ]; then - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - - #define _HPUX_SOURCE - #include - #include - - int main () - { - #if defined(_SC_KERNEL_BITS) - long bits = sysconf(_SC_KERNEL_BITS); - #endif - long cpu = sysconf (_SC_CPU_VERSION); - - switch (cpu) - { - case CPU_PA_RISC1_0: puts ("hppa1.0"); break; - case CPU_PA_RISC1_1: puts ("hppa1.1"); break; - case CPU_PA_RISC2_0: - #if defined(_SC_KERNEL_BITS) - switch (bits) - { - case 64: puts ("hppa2.0w"); break; - case 32: puts ("hppa2.0n"); break; - default: puts ("hppa2.0"); break; - } break; - #else /* !defined(_SC_KERNEL_BITS) */ - puts ("hppa2.0"); break; - #endif - default: puts ("hppa1.0"); break; - } - exit (0); - } -EOF - (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` - test -z "$HP_ARCH" && HP_ARCH=hppa - fi ;; - esac - if [ ${HP_ARCH} = "hppa2.0w" ] - then - eval $set_cc_for_build - - # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating - # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler - # generating 64-bit code. GNU and HP use different nomenclature: - # - # $ CC_FOR_BUILD=cc ./config.guess - # => hppa2.0w-hp-hpux11.23 - # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess - # => hppa64-hp-hpux11.23 - - if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | - grep -q __LP64__ - then - HP_ARCH="hppa2.0w" - else - HP_ARCH="hppa64" - fi - fi - echo ${HP_ARCH}-hp-hpux${HPUX_REV} - exit ;; - ia64:HP-UX:*:*) - HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` - echo ia64-hp-hpux${HPUX_REV} - exit ;; - 3050*:HI-UX:*:*) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #include - int - main () - { - long cpu = sysconf (_SC_CPU_VERSION); - /* The order matters, because CPU_IS_HP_MC68K erroneously returns - true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct - results, however. */ - if (CPU_IS_PA_RISC (cpu)) - { - switch (cpu) - { - case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; - case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; - case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; - default: puts ("hppa-hitachi-hiuxwe2"); break; - } - } - else if (CPU_IS_HP_MC68K (cpu)) - puts ("m68k-hitachi-hiuxwe2"); - else puts ("unknown-hitachi-hiuxwe2"); - exit (0); - } -EOF - $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && - { echo "$SYSTEM_NAME"; exit; } - echo unknown-hitachi-hiuxwe2 - exit ;; - 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) - echo hppa1.1-hp-bsd - exit ;; - 9000/8??:4.3bsd:*:*) - echo hppa1.0-hp-bsd - exit ;; - *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) - echo hppa1.0-hp-mpeix - exit ;; - hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) - echo hppa1.1-hp-osf - exit ;; - hp8??:OSF1:*:*) - echo hppa1.0-hp-osf - exit ;; - i*86:OSF1:*:*) - if [ -x /usr/sbin/sysversion ] ; then - echo ${UNAME_MACHINE}-unknown-osf1mk - else - echo ${UNAME_MACHINE}-unknown-osf1 - fi - exit ;; - parisc*:Lites*:*:*) - echo hppa1.1-hp-lites - exit ;; - C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) - echo c1-convex-bsd - exit ;; - C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit ;; - C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) - echo c34-convex-bsd - exit ;; - C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) - echo c38-convex-bsd - exit ;; - C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) - echo c4-convex-bsd - exit ;; - CRAY*Y-MP:*:*:*) - echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*[A-Z]90:*:*:*) - echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ - | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ - -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ - -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*TS:*:*:*) - echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*T3E:*:*:*) - echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*SV1:*:*:*) - echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - *:UNICOS/mp:*:*) - echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) - FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` - FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` - FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` - echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" - exit ;; - 5000:UNIX_System_V:4.*:*) - FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` - FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` - echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" - exit ;; - i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) - echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} - exit ;; - sparc*:BSD/OS:*:*) - echo sparc-unknown-bsdi${UNAME_RELEASE} - exit ;; - *:BSD/OS:*:*) - echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} - exit ;; - *:FreeBSD:*:*) - UNAME_PROCESSOR=`/usr/bin/uname -p` - case ${UNAME_PROCESSOR} in - amd64) - echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; - *) - echo ${UNAME_PROCESSOR}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; - esac - exit ;; - i*:CYGWIN*:*) - echo ${UNAME_MACHINE}-pc-cygwin - exit ;; - *:MINGW64*:*) - echo ${UNAME_MACHINE}-pc-mingw64 - exit ;; - *:MINGW*:*) - echo ${UNAME_MACHINE}-pc-mingw32 - exit ;; - i*:MSYS*:*) - echo ${UNAME_MACHINE}-pc-msys - exit ;; - i*:windows32*:*) - # uname -m includes "-pc" on this system. - echo ${UNAME_MACHINE}-mingw32 - exit ;; - i*:PW*:*) - echo ${UNAME_MACHINE}-pc-pw32 - exit ;; - *:Interix*:*) - case ${UNAME_MACHINE} in - x86) - echo i586-pc-interix${UNAME_RELEASE} - exit ;; - authenticamd | genuineintel | EM64T) - echo x86_64-unknown-interix${UNAME_RELEASE} - exit ;; - IA64) - echo ia64-unknown-interix${UNAME_RELEASE} - exit ;; - esac ;; - [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) - echo i${UNAME_MACHINE}-pc-mks - exit ;; - 8664:Windows_NT:*) - echo x86_64-pc-mks - exit ;; - i*:Windows_NT*:* | Pentium*:Windows_NT*:*) - # How do we know it's Interix rather than the generic POSIX subsystem? - # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we - # UNAME_MACHINE based on the output of uname instead of i386? - echo i586-pc-interix - exit ;; - i*:UWIN*:*) - echo ${UNAME_MACHINE}-pc-uwin - exit ;; - amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) - echo x86_64-unknown-cygwin - exit ;; - p*:CYGWIN*:*) - echo powerpcle-unknown-cygwin - exit ;; - prep*:SunOS:5.*:*) - echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - *:GNU:*:*) - # the GNU system - echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-${LIBC}`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` - exit ;; - *:GNU/*:*:*) - # other systems with GNU libc and userland - echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-${LIBC} - exit ;; - i*86:Minix:*:*) - echo ${UNAME_MACHINE}-pc-minix - exit ;; - aarch64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - aarch64_be:Linux:*:*) - UNAME_MACHINE=aarch64_be - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - alpha:Linux:*:*) - case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in - EV5) UNAME_MACHINE=alphaev5 ;; - EV56) UNAME_MACHINE=alphaev56 ;; - PCA56) UNAME_MACHINE=alphapca56 ;; - PCA57) UNAME_MACHINE=alphapca56 ;; - EV6) UNAME_MACHINE=alphaev6 ;; - EV67) UNAME_MACHINE=alphaev67 ;; - EV68*) UNAME_MACHINE=alphaev68 ;; - esac - objdump --private-headers /bin/sh | grep -q ld.so.1 - if test "$?" = 0 ; then LIBC="gnulibc1" ; fi - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - arc:Linux:*:* | arceb:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - arm*:Linux:*:*) - eval $set_cc_for_build - if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ - | grep -q __ARM_EABI__ - then - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - else - if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ - | grep -q __ARM_PCS_VFP - then - echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabi - else - echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabihf - fi - fi - exit ;; - avr32*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - cris:Linux:*:*) - echo ${UNAME_MACHINE}-axis-linux-${LIBC} - exit ;; - crisv32:Linux:*:*) - echo ${UNAME_MACHINE}-axis-linux-${LIBC} - exit ;; - frv:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - hexagon:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - i*86:Linux:*:*) - echo ${UNAME_MACHINE}-pc-linux-${LIBC} - exit ;; - ia64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - m32r*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - m68*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - mips:Linux:*:* | mips64:Linux:*:*) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #undef CPU - #undef ${UNAME_MACHINE} - #undef ${UNAME_MACHINE}el - #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) - CPU=${UNAME_MACHINE}el - #else - #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) - CPU=${UNAME_MACHINE} - #else - CPU= - #endif - #endif -EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` - test x"${CPU}" != x && { echo "${CPU}-unknown-linux-${LIBC}"; exit; } - ;; - or1k:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - or32:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - padre:Linux:*:*) - echo sparc-unknown-linux-${LIBC} - exit ;; - parisc64:Linux:*:* | hppa64:Linux:*:*) - echo hppa64-unknown-linux-${LIBC} - exit ;; - parisc:Linux:*:* | hppa:Linux:*:*) - # Look for CPU level - case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in - PA7*) echo hppa1.1-unknown-linux-${LIBC} ;; - PA8*) echo hppa2.0-unknown-linux-${LIBC} ;; - *) echo hppa-unknown-linux-${LIBC} ;; - esac - exit ;; - ppc64:Linux:*:*) - echo powerpc64-unknown-linux-${LIBC} - exit ;; - ppc:Linux:*:*) - echo powerpc-unknown-linux-${LIBC} - exit ;; - ppc64le:Linux:*:*) - echo powerpc64le-unknown-linux-${LIBC} - exit ;; - ppcle:Linux:*:*) - echo powerpcle-unknown-linux-${LIBC} - exit ;; - s390:Linux:*:* | s390x:Linux:*:*) - echo ${UNAME_MACHINE}-ibm-linux-${LIBC} - exit ;; - sh64*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - sh*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - sparc:Linux:*:* | sparc64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - tile*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - vax:Linux:*:*) - echo ${UNAME_MACHINE}-dec-linux-${LIBC} - exit ;; - x86_64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - xtensa*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - i*86:DYNIX/ptx:4*:*) - # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. - # earlier versions are messed up and put the nodename in both - # sysname and nodename. - echo i386-sequent-sysv4 - exit ;; - i*86:UNIX_SV:4.2MP:2.*) - # Unixware is an offshoot of SVR4, but it has its own version - # number series starting with 2... - # I am not positive that other SVR4 systems won't match this, - # I just have to hope. -- rms. - # Use sysv4.2uw... so that sysv4* matches it. - echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} - exit ;; - i*86:OS/2:*:*) - # If we were able to find `uname', then EMX Unix compatibility - # is probably installed. - echo ${UNAME_MACHINE}-pc-os2-emx - exit ;; - i*86:XTS-300:*:STOP) - echo ${UNAME_MACHINE}-unknown-stop - exit ;; - i*86:atheos:*:*) - echo ${UNAME_MACHINE}-unknown-atheos - exit ;; - i*86:syllable:*:*) - echo ${UNAME_MACHINE}-pc-syllable - exit ;; - i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) - echo i386-unknown-lynxos${UNAME_RELEASE} - exit ;; - i*86:*DOS:*:*) - echo ${UNAME_MACHINE}-pc-msdosdjgpp - exit ;; - i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) - UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` - if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then - echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} - else - echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} - fi - exit ;; - i*86:*:5:[678]*) - # UnixWare 7.x, OpenUNIX and OpenServer 6. - case `/bin/uname -X | grep "^Machine"` in - *486*) UNAME_MACHINE=i486 ;; - *Pentium) UNAME_MACHINE=i586 ;; - *Pent*|*Celeron) UNAME_MACHINE=i686 ;; - esac - echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} - exit ;; - i*86:*:3.2:*) - if test -f /usr/options/cb.name; then - UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then - UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` - (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 - (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ - && UNAME_MACHINE=i586 - (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ - && UNAME_MACHINE=i686 - (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ - && UNAME_MACHINE=i686 - echo ${UNAME_MACHINE}-pc-sco$UNAME_REL - else - echo ${UNAME_MACHINE}-pc-sysv32 - fi - exit ;; - pc:*:*:*) - # Left here for compatibility: - # uname -m prints for DJGPP always 'pc', but it prints nothing about - # the processor, so we play safe by assuming i586. - # Note: whatever this is, it MUST be the same as what config.sub - # prints for the "djgpp" host, or else GDB configury will decide that - # this is a cross-build. - echo i586-pc-msdosdjgpp - exit ;; - Intel:Mach:3*:*) - echo i386-pc-mach3 - exit ;; - paragon:*:*:*) - echo i860-intel-osf1 - exit ;; - i860:*:4.*:*) # i860-SVR4 - if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then - echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 - else # Add other i860-SVR4 vendors below as they are discovered. - echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 - fi - exit ;; - mini*:CTIX:SYS*5:*) - # "miniframe" - echo m68010-convergent-sysv - exit ;; - mc68k:UNIX:SYSTEM5:3.51m) - echo m68k-convergent-sysv - exit ;; - M680?0:D-NIX:5.3:*) - echo m68k-diab-dnix - exit ;; - M68*:*:R3V[5678]*:*) - test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; - 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) - OS_REL='' - test -r /etc/.relid \ - && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` - /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && { echo i486-ncr-sysv4.3${OS_REL}; exit; } - /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ - && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; - 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) - /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && { echo i486-ncr-sysv4; exit; } ;; - NCR*:*:4.2:* | MPRAS*:*:4.2:*) - OS_REL='.3' - test -r /etc/.relid \ - && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` - /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && { echo i486-ncr-sysv4.3${OS_REL}; exit; } - /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ - && { echo i586-ncr-sysv4.3${OS_REL}; exit; } - /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ - && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; - m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) - echo m68k-unknown-lynxos${UNAME_RELEASE} - exit ;; - mc68030:UNIX_System_V:4.*:*) - echo m68k-atari-sysv4 - exit ;; - TSUNAMI:LynxOS:2.*:*) - echo sparc-unknown-lynxos${UNAME_RELEASE} - exit ;; - rs6000:LynxOS:2.*:*) - echo rs6000-unknown-lynxos${UNAME_RELEASE} - exit ;; - PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) - echo powerpc-unknown-lynxos${UNAME_RELEASE} - exit ;; - SM[BE]S:UNIX_SV:*:*) - echo mips-dde-sysv${UNAME_RELEASE} - exit ;; - RM*:ReliantUNIX-*:*:*) - echo mips-sni-sysv4 - exit ;; - RM*:SINIX-*:*:*) - echo mips-sni-sysv4 - exit ;; - *:SINIX-*:*:*) - if uname -p 2>/dev/null >/dev/null ; then - UNAME_MACHINE=`(uname -p) 2>/dev/null` - echo ${UNAME_MACHINE}-sni-sysv4 - else - echo ns32k-sni-sysv - fi - exit ;; - PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort - # says - echo i586-unisys-sysv4 - exit ;; - *:UNIX_System_V:4*:FTX*) - # From Gerald Hewes . - # How about differentiating between stratus architectures? -djm - echo hppa1.1-stratus-sysv4 - exit ;; - *:*:*:FTX*) - # From seanf@swdc.stratus.com. - echo i860-stratus-sysv4 - exit ;; - i*86:VOS:*:*) - # From Paul.Green@stratus.com. - echo ${UNAME_MACHINE}-stratus-vos - exit ;; - *:VOS:*:*) - # From Paul.Green@stratus.com. - echo hppa1.1-stratus-vos - exit ;; - mc68*:A/UX:*:*) - echo m68k-apple-aux${UNAME_RELEASE} - exit ;; - news*:NEWS-OS:6*:*) - echo mips-sony-newsos6 - exit ;; - R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) - if [ -d /usr/nec ]; then - echo mips-nec-sysv${UNAME_RELEASE} - else - echo mips-unknown-sysv${UNAME_RELEASE} - fi - exit ;; - BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. - echo powerpc-be-beos - exit ;; - BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. - echo powerpc-apple-beos - exit ;; - BePC:BeOS:*:*) # BeOS running on Intel PC compatible. - echo i586-pc-beos - exit ;; - BePC:Haiku:*:*) # Haiku running on Intel PC compatible. - echo i586-pc-haiku - exit ;; - x86_64:Haiku:*:*) - echo x86_64-unknown-haiku - exit ;; - SX-4:SUPER-UX:*:*) - echo sx4-nec-superux${UNAME_RELEASE} - exit ;; - SX-5:SUPER-UX:*:*) - echo sx5-nec-superux${UNAME_RELEASE} - exit ;; - SX-6:SUPER-UX:*:*) - echo sx6-nec-superux${UNAME_RELEASE} - exit ;; - SX-7:SUPER-UX:*:*) - echo sx7-nec-superux${UNAME_RELEASE} - exit ;; - SX-8:SUPER-UX:*:*) - echo sx8-nec-superux${UNAME_RELEASE} - exit ;; - SX-8R:SUPER-UX:*:*) - echo sx8r-nec-superux${UNAME_RELEASE} - exit ;; - Power*:Rhapsody:*:*) - echo powerpc-apple-rhapsody${UNAME_RELEASE} - exit ;; - *:Rhapsody:*:*) - echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} - exit ;; - *:Darwin:*:*) - UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown - eval $set_cc_for_build - if test "$UNAME_PROCESSOR" = unknown ; then - UNAME_PROCESSOR=powerpc - fi - if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then - if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ - (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ - grep IS_64BIT_ARCH >/dev/null - then - case $UNAME_PROCESSOR in - i386) UNAME_PROCESSOR=x86_64 ;; - powerpc) UNAME_PROCESSOR=powerpc64 ;; - esac - fi - fi - echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} - exit ;; - *:procnto*:*:* | *:QNX:[0123456789]*:*) - UNAME_PROCESSOR=`uname -p` - if test "$UNAME_PROCESSOR" = "x86"; then - UNAME_PROCESSOR=i386 - UNAME_MACHINE=pc - fi - echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} - exit ;; - *:QNX:*:4*) - echo i386-pc-qnx - exit ;; - NEO-?:NONSTOP_KERNEL:*:*) - echo neo-tandem-nsk${UNAME_RELEASE} - exit ;; - NSE-*:NONSTOP_KERNEL:*:*) - echo nse-tandem-nsk${UNAME_RELEASE} - exit ;; - NSR-?:NONSTOP_KERNEL:*:*) - echo nsr-tandem-nsk${UNAME_RELEASE} - exit ;; - *:NonStop-UX:*:*) - echo mips-compaq-nonstopux - exit ;; - BS2000:POSIX*:*:*) - echo bs2000-siemens-sysv - exit ;; - DS/*:UNIX_System_V:*:*) - echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} - exit ;; - *:Plan9:*:*) - # "uname -m" is not consistent, so use $cputype instead. 386 - # is converted to i386 for consistency with other x86 - # operating systems. - if test "$cputype" = "386"; then - UNAME_MACHINE=i386 - else - UNAME_MACHINE="$cputype" - fi - echo ${UNAME_MACHINE}-unknown-plan9 - exit ;; - *:TOPS-10:*:*) - echo pdp10-unknown-tops10 - exit ;; - *:TENEX:*:*) - echo pdp10-unknown-tenex - exit ;; - KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) - echo pdp10-dec-tops20 - exit ;; - XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) - echo pdp10-xkl-tops20 - exit ;; - *:TOPS-20:*:*) - echo pdp10-unknown-tops20 - exit ;; - *:ITS:*:*) - echo pdp10-unknown-its - exit ;; - SEI:*:*:SEIUX) - echo mips-sei-seiux${UNAME_RELEASE} - exit ;; - *:DragonFly:*:*) - echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` - exit ;; - *:*VMS:*:*) - UNAME_MACHINE=`(uname -p) 2>/dev/null` - case "${UNAME_MACHINE}" in - A*) echo alpha-dec-vms ; exit ;; - I*) echo ia64-dec-vms ; exit ;; - V*) echo vax-dec-vms ; exit ;; - esac ;; - *:XENIX:*:SysV) - echo i386-pc-xenix - exit ;; - i*86:skyos:*:*) - echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' - exit ;; - i*86:rdos:*:*) - echo ${UNAME_MACHINE}-pc-rdos - exit ;; - i*86:AROS:*:*) - echo ${UNAME_MACHINE}-pc-aros - exit ;; - x86_64:VMkernel:*:*) - echo ${UNAME_MACHINE}-unknown-esx - exit ;; -esac - -eval $set_cc_for_build -cat >$dummy.c < -# include -#endif -main () -{ -#if defined (sony) -#if defined (MIPSEB) - /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, - I don't know.... */ - printf ("mips-sony-bsd\n"); exit (0); -#else -#include - printf ("m68k-sony-newsos%s\n", -#ifdef NEWSOS4 - "4" -#else - "" -#endif - ); exit (0); -#endif -#endif - -#if defined (__arm) && defined (__acorn) && defined (__unix) - printf ("arm-acorn-riscix\n"); exit (0); -#endif - -#if defined (hp300) && !defined (hpux) - printf ("m68k-hp-bsd\n"); exit (0); -#endif - -#if defined (NeXT) -#if !defined (__ARCHITECTURE__) -#define __ARCHITECTURE__ "m68k" -#endif - int version; - version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; - if (version < 4) - printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); - else - printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); - exit (0); -#endif - -#if defined (MULTIMAX) || defined (n16) -#if defined (UMAXV) - printf ("ns32k-encore-sysv\n"); exit (0); -#else -#if defined (CMU) - printf ("ns32k-encore-mach\n"); exit (0); -#else - printf ("ns32k-encore-bsd\n"); exit (0); -#endif -#endif -#endif - -#if defined (__386BSD__) - printf ("i386-pc-bsd\n"); exit (0); -#endif - -#if defined (sequent) -#if defined (i386) - printf ("i386-sequent-dynix\n"); exit (0); -#endif -#if defined (ns32000) - printf ("ns32k-sequent-dynix\n"); exit (0); -#endif -#endif - -#if defined (_SEQUENT_) - struct utsname un; - - uname(&un); - - if (strncmp(un.version, "V2", 2) == 0) { - printf ("i386-sequent-ptx2\n"); exit (0); - } - if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ - printf ("i386-sequent-ptx1\n"); exit (0); - } - printf ("i386-sequent-ptx\n"); exit (0); - -#endif - -#if defined (vax) -# if !defined (ultrix) -# include -# if defined (BSD) -# if BSD == 43 - printf ("vax-dec-bsd4.3\n"); exit (0); -# else -# if BSD == 199006 - printf ("vax-dec-bsd4.3reno\n"); exit (0); -# else - printf ("vax-dec-bsd\n"); exit (0); -# endif -# endif -# else - printf ("vax-dec-bsd\n"); exit (0); -# endif -# else - printf ("vax-dec-ultrix\n"); exit (0); -# endif -#endif - -#if defined (alliant) && defined (i860) - printf ("i860-alliant-bsd\n"); exit (0); -#endif - - exit (1); -} -EOF - -$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` && - { echo "$SYSTEM_NAME"; exit; } - -# Apollos put the system type in the environment. - -test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; } - -# Convex versions that predate uname can use getsysinfo(1) - -if [ -x /usr/convex/getsysinfo ] -then - case `getsysinfo -f cpu_type` in - c1*) - echo c1-convex-bsd - exit ;; - c2*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit ;; - c34*) - echo c34-convex-bsd - exit ;; - c38*) - echo c38-convex-bsd - exit ;; - c4*) - echo c4-convex-bsd - exit ;; - esac -fi - -cat >&2 < in order to provide the needed -information to handle your system. - -config.guess timestamp = $timestamp - -uname -m = `(uname -m) 2>/dev/null || echo unknown` -uname -r = `(uname -r) 2>/dev/null || echo unknown` -uname -s = `(uname -s) 2>/dev/null || echo unknown` -uname -v = `(uname -v) 2>/dev/null || echo unknown` - -/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` -/bin/uname -X = `(/bin/uname -X) 2>/dev/null` - -hostinfo = `(hostinfo) 2>/dev/null` -/bin/universe = `(/bin/universe) 2>/dev/null` -/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` -/bin/arch = `(/bin/arch) 2>/dev/null` -/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` -/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` - -UNAME_MACHINE = ${UNAME_MACHINE} -UNAME_RELEASE = ${UNAME_RELEASE} -UNAME_SYSTEM = ${UNAME_SYSTEM} -UNAME_VERSION = ${UNAME_VERSION} -EOF - -exit 1 - -# Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) -# time-stamp-start: "timestamp='" -# time-stamp-format: "%:y-%02m-%02d" -# time-stamp-end: "'" -# End: diff --git a/config/gnu/config.sub b/config/gnu/config.sub deleted file mode 100755 index 8b612ab8..00000000 --- a/config/gnu/config.sub +++ /dev/null @@ -1,1788 +0,0 @@ -#! /bin/sh -# Configuration validation subroutine script. -# Copyright 1992-2013 Free Software Foundation, Inc. - -timestamp='2013-04-24' - -# This file is free software; you can redistribute it and/or modify it -# under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 3 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, see . -# -# As a special exception to the GNU General Public License, if you -# distribute this file as part of a program that contains a -# configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that -# program. This Exception is an additional permission under section 7 -# of the GNU General Public License, version 3 ("GPLv3"). - - -# Please send patches with a ChangeLog entry to config-patches@gnu.org. -# -# Configuration subroutine to validate and canonicalize a configuration type. -# Supply the specified configuration type as an argument. -# If it is invalid, we print an error message on stderr and exit with code 1. -# Otherwise, we print the canonical config type on stdout and succeed. - -# You can get the latest version of this script from: -# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD - -# This file is supposed to be the same for all GNU packages -# and recognize all the CPU types, system types and aliases -# that are meaningful with *any* GNU software. -# Each package is responsible for reporting which valid configurations -# it does not support. The user should be able to distinguish -# a failure to support a valid configuration from a meaningless -# configuration. - -# The goal of this file is to map all the various variations of a given -# machine specification into a single specification in the form: -# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM -# or in some cases, the newer four-part form: -# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM -# It is wrong to echo any other type of specification. - -me=`echo "$0" | sed -e 's,.*/,,'` - -usage="\ -Usage: $0 [OPTION] CPU-MFR-OPSYS - $0 [OPTION] ALIAS - -Canonicalize a configuration name. - -Operation modes: - -h, --help print this help, then exit - -t, --time-stamp print date of last modification, then exit - -v, --version print version number, then exit - -Report bugs and patches to ." - -version="\ -GNU config.sub ($timestamp) - -Copyright 1992-2013 Free Software Foundation, Inc. - -This is free software; see the source for copying conditions. There is NO -warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." - -help=" -Try \`$me --help' for more information." - -# Parse command line -while test $# -gt 0 ; do - case $1 in - --time-stamp | --time* | -t ) - echo "$timestamp" ; exit ;; - --version | -v ) - echo "$version" ; exit ;; - --help | --h* | -h ) - echo "$usage"; exit ;; - -- ) # Stop option processing - shift; break ;; - - ) # Use stdin as input. - break ;; - -* ) - echo "$me: invalid option $1$help" - exit 1 ;; - - *local*) - # First pass through any local machine types. - echo $1 - exit ;; - - * ) - break ;; - esac -done - -case $# in - 0) echo "$me: missing argument$help" >&2 - exit 1;; - 1) ;; - *) echo "$me: too many arguments$help" >&2 - exit 1;; -esac - -# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). -# Here we must recognize all the valid KERNEL-OS combinations. -maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` -case $maybe_os in - nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \ - linux-musl* | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ - knetbsd*-gnu* | netbsd*-gnu* | \ - kopensolaris*-gnu* | \ - storm-chaos* | os2-emx* | rtmk-nova*) - os=-$maybe_os - basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` - ;; - android-linux) - os=-linux-android - basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`-unknown - ;; - *) - basic_machine=`echo $1 | sed 's/-[^-]*$//'` - if [ $basic_machine != $1 ] - then os=`echo $1 | sed 's/.*-/-/'` - else os=; fi - ;; -esac - -### Let's recognize common machines as not being operating systems so -### that things like config.sub decstation-3100 work. We also -### recognize some manufacturers as not being operating systems, so we -### can provide default operating systems below. -case $os in - -sun*os*) - # Prevent following clause from handling this invalid input. - ;; - -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ - -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ - -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ - -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ - -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ - -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ - -apple | -axis | -knuth | -cray | -microblaze*) - os= - basic_machine=$1 - ;; - -bluegene*) - os=-cnk - ;; - -sim | -cisco | -oki | -wec | -winbond) - os= - basic_machine=$1 - ;; - -scout) - ;; - -wrs) - os=-vxworks - basic_machine=$1 - ;; - -chorusos*) - os=-chorusos - basic_machine=$1 - ;; - -chorusrdb) - os=-chorusrdb - basic_machine=$1 - ;; - -hiux*) - os=-hiuxwe2 - ;; - -sco6) - os=-sco5v6 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco5) - os=-sco3.2v5 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco4) - os=-sco3.2v4 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco3.2.[4-9]*) - os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco3.2v[4-9]*) - # Don't forget version if it is 3.2v4 or newer. - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco5v6*) - # Don't forget version if it is 3.2v4 or newer. - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco*) - os=-sco3.2v2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -udk*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -isc) - os=-isc2.2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -clix*) - basic_machine=clipper-intergraph - ;; - -isc*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -lynx*178) - os=-lynxos178 - ;; - -lynx*5) - os=-lynxos5 - ;; - -lynx*) - os=-lynxos - ;; - -ptx*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` - ;; - -windowsnt*) - os=`echo $os | sed -e 's/windowsnt/winnt/'` - ;; - -psos*) - os=-psos - ;; - -mint | -mint[0-9]*) - basic_machine=m68k-atari - os=-mint - ;; -esac - -# Decode aliases for certain CPU-COMPANY combinations. -case $basic_machine in - # Recognize the basic CPU types without company name. - # Some are omitted here because they have special meanings below. - 1750a | 580 \ - | a29k \ - | aarch64 | aarch64_be \ - | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ - | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ - | am33_2.0 \ - | arc | arceb \ - | arm | arm[bl]e | arme[lb] | armv[2-8] | armv[3-8][lb] | armv7[arm] \ - | avr | avr32 \ - | be32 | be64 \ - | bfin \ - | c4x | clipper \ - | d10v | d30v | dlx | dsp16xx \ - | epiphany \ - | fido | fr30 | frv \ - | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ - | hexagon \ - | i370 | i860 | i960 | ia64 \ - | ip2k | iq2000 \ - | le32 | le64 \ - | lm32 \ - | m32c | m32r | m32rle | m68000 | m68k | m88k \ - | maxq | mb | microblaze | microblazeel | mcore | mep | metag \ - | mips | mipsbe | mipseb | mipsel | mipsle \ - | mips16 \ - | mips64 | mips64el \ - | mips64octeon | mips64octeonel \ - | mips64orion | mips64orionel \ - | mips64r5900 | mips64r5900el \ - | mips64vr | mips64vrel \ - | mips64vr4100 | mips64vr4100el \ - | mips64vr4300 | mips64vr4300el \ - | mips64vr5000 | mips64vr5000el \ - | mips64vr5900 | mips64vr5900el \ - | mipsisa32 | mipsisa32el \ - | mipsisa32r2 | mipsisa32r2el \ - | mipsisa64 | mipsisa64el \ - | mipsisa64r2 | mipsisa64r2el \ - | mipsisa64sb1 | mipsisa64sb1el \ - | mipsisa64sr71k | mipsisa64sr71kel \ - | mipsr5900 | mipsr5900el \ - | mipstx39 | mipstx39el \ - | mn10200 | mn10300 \ - | moxie \ - | mt \ - | msp430 \ - | nds32 | nds32le | nds32be \ - | nios | nios2 | nios2eb | nios2el \ - | ns16k | ns32k \ - | open8 \ - | or1k | or32 \ - | pdp10 | pdp11 | pj | pjl \ - | powerpc | powerpc64 | powerpc64le | powerpcle \ - | pyramid \ - | rl78 | rx \ - | score \ - | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ - | sh64 | sh64le \ - | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ - | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ - | spu \ - | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \ - | ubicom32 \ - | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \ - | we32k \ - | x86 | xc16x | xstormy16 | xtensa \ - | z8k | z80) - basic_machine=$basic_machine-unknown - ;; - c54x) - basic_machine=tic54x-unknown - ;; - c55x) - basic_machine=tic55x-unknown - ;; - c6x) - basic_machine=tic6x-unknown - ;; - m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | picochip) - basic_machine=$basic_machine-unknown - os=-none - ;; - m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) - ;; - ms1) - basic_machine=mt-unknown - ;; - - strongarm | thumb | xscale) - basic_machine=arm-unknown - ;; - xgate) - basic_machine=$basic_machine-unknown - os=-none - ;; - xscaleeb) - basic_machine=armeb-unknown - ;; - - xscaleel) - basic_machine=armel-unknown - ;; - - # We use `pc' rather than `unknown' - # because (1) that's what they normally are, and - # (2) the word "unknown" tends to confuse beginning users. - i*86 | x86_64) - basic_machine=$basic_machine-pc - ;; - # Object if more than one company name word. - *-*-*) - echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 - exit 1 - ;; - # Recognize the basic CPU types with company name. - 580-* \ - | a29k-* \ - | aarch64-* | aarch64_be-* \ - | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ - | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ - | alphapca5[67]-* | alpha64pca5[67]-* | arc-* | arceb-* \ - | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ - | avr-* | avr32-* \ - | be32-* | be64-* \ - | bfin-* | bs2000-* \ - | c[123]* | c30-* | [cjt]90-* | c4x-* \ - | clipper-* | craynv-* | cydra-* \ - | d10v-* | d30v-* | dlx-* \ - | elxsi-* \ - | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ - | h8300-* | h8500-* \ - | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ - | hexagon-* \ - | i*86-* | i860-* | i960-* | ia64-* \ - | ip2k-* | iq2000-* \ - | le32-* | le64-* \ - | lm32-* \ - | m32c-* | m32r-* | m32rle-* \ - | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ - | m88110-* | m88k-* | maxq-* | mcore-* | metag-* \ - | microblaze-* | microblazeel-* \ - | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ - | mips16-* \ - | mips64-* | mips64el-* \ - | mips64octeon-* | mips64octeonel-* \ - | mips64orion-* | mips64orionel-* \ - | mips64r5900-* | mips64r5900el-* \ - | mips64vr-* | mips64vrel-* \ - | mips64vr4100-* | mips64vr4100el-* \ - | mips64vr4300-* | mips64vr4300el-* \ - | mips64vr5000-* | mips64vr5000el-* \ - | mips64vr5900-* | mips64vr5900el-* \ - | mipsisa32-* | mipsisa32el-* \ - | mipsisa32r2-* | mipsisa32r2el-* \ - | mipsisa64-* | mipsisa64el-* \ - | mipsisa64r2-* | mipsisa64r2el-* \ - | mipsisa64sb1-* | mipsisa64sb1el-* \ - | mipsisa64sr71k-* | mipsisa64sr71kel-* \ - | mipsr5900-* | mipsr5900el-* \ - | mipstx39-* | mipstx39el-* \ - | mmix-* \ - | mt-* \ - | msp430-* \ - | nds32-* | nds32le-* | nds32be-* \ - | nios-* | nios2-* | nios2eb-* | nios2el-* \ - | none-* | np1-* | ns16k-* | ns32k-* \ - | open8-* \ - | orion-* \ - | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ - | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ - | pyramid-* \ - | rl78-* | romp-* | rs6000-* | rx-* \ - | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ - | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ - | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ - | sparclite-* \ - | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx?-* \ - | tahoe-* \ - | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ - | tile*-* \ - | tron-* \ - | ubicom32-* \ - | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \ - | vax-* \ - | we32k-* \ - | x86-* | x86_64-* | xc16x-* | xps100-* \ - | xstormy16-* | xtensa*-* \ - | ymp-* \ - | z8k-* | z80-*) - ;; - # Recognize the basic CPU types without company name, with glob match. - xtensa*) - basic_machine=$basic_machine-unknown - ;; - # Recognize the various machine names and aliases which stand - # for a CPU type and a company and sometimes even an OS. - 386bsd) - basic_machine=i386-unknown - os=-bsd - ;; - 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) - basic_machine=m68000-att - ;; - 3b*) - basic_machine=we32k-att - ;; - a29khif) - basic_machine=a29k-amd - os=-udi - ;; - abacus) - basic_machine=abacus-unknown - ;; - adobe68k) - basic_machine=m68010-adobe - os=-scout - ;; - alliant | fx80) - basic_machine=fx80-alliant - ;; - altos | altos3068) - basic_machine=m68k-altos - ;; - am29k) - basic_machine=a29k-none - os=-bsd - ;; - amd64) - basic_machine=x86_64-pc - ;; - amd64-*) - basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - amdahl) - basic_machine=580-amdahl - os=-sysv - ;; - amiga | amiga-*) - basic_machine=m68k-unknown - ;; - amigaos | amigados) - basic_machine=m68k-unknown - os=-amigaos - ;; - amigaunix | amix) - basic_machine=m68k-unknown - os=-sysv4 - ;; - apollo68) - basic_machine=m68k-apollo - os=-sysv - ;; - apollo68bsd) - basic_machine=m68k-apollo - os=-bsd - ;; - aros) - basic_machine=i386-pc - os=-aros - ;; - aux) - basic_machine=m68k-apple - os=-aux - ;; - balance) - basic_machine=ns32k-sequent - os=-dynix - ;; - blackfin) - basic_machine=bfin-unknown - os=-linux - ;; - blackfin-*) - basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'` - os=-linux - ;; - bluegene*) - basic_machine=powerpc-ibm - os=-cnk - ;; - c54x-*) - basic_machine=tic54x-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - c55x-*) - basic_machine=tic55x-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - c6x-*) - basic_machine=tic6x-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - c90) - basic_machine=c90-cray - os=-unicos - ;; - cegcc) - basic_machine=arm-unknown - os=-cegcc - ;; - convex-c1) - basic_machine=c1-convex - os=-bsd - ;; - convex-c2) - basic_machine=c2-convex - os=-bsd - ;; - convex-c32) - basic_machine=c32-convex - os=-bsd - ;; - convex-c34) - basic_machine=c34-convex - os=-bsd - ;; - convex-c38) - basic_machine=c38-convex - os=-bsd - ;; - cray | j90) - basic_machine=j90-cray - os=-unicos - ;; - craynv) - basic_machine=craynv-cray - os=-unicosmp - ;; - cr16 | cr16-*) - basic_machine=cr16-unknown - os=-elf - ;; - crds | unos) - basic_machine=m68k-crds - ;; - crisv32 | crisv32-* | etraxfs*) - basic_machine=crisv32-axis - ;; - cris | cris-* | etrax*) - basic_machine=cris-axis - ;; - crx) - basic_machine=crx-unknown - os=-elf - ;; - da30 | da30-*) - basic_machine=m68k-da30 - ;; - decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) - basic_machine=mips-dec - ;; - decsystem10* | dec10*) - basic_machine=pdp10-dec - os=-tops10 - ;; - decsystem20* | dec20*) - basic_machine=pdp10-dec - os=-tops20 - ;; - delta | 3300 | motorola-3300 | motorola-delta \ - | 3300-motorola | delta-motorola) - basic_machine=m68k-motorola - ;; - delta88) - basic_machine=m88k-motorola - os=-sysv3 - ;; - dicos) - basic_machine=i686-pc - os=-dicos - ;; - djgpp) - basic_machine=i586-pc - os=-msdosdjgpp - ;; - dpx20 | dpx20-*) - basic_machine=rs6000-bull - os=-bosx - ;; - dpx2* | dpx2*-bull) - basic_machine=m68k-bull - os=-sysv3 - ;; - ebmon29k) - basic_machine=a29k-amd - os=-ebmon - ;; - elxsi) - basic_machine=elxsi-elxsi - os=-bsd - ;; - encore | umax | mmax) - basic_machine=ns32k-encore - ;; - es1800 | OSE68k | ose68k | ose | OSE) - basic_machine=m68k-ericsson - os=-ose - ;; - fx2800) - basic_machine=i860-alliant - ;; - genix) - basic_machine=ns32k-ns - ;; - gmicro) - basic_machine=tron-gmicro - os=-sysv - ;; - go32) - basic_machine=i386-pc - os=-go32 - ;; - h3050r* | hiux*) - basic_machine=hppa1.1-hitachi - os=-hiuxwe2 - ;; - h8300hms) - basic_machine=h8300-hitachi - os=-hms - ;; - h8300xray) - basic_machine=h8300-hitachi - os=-xray - ;; - h8500hms) - basic_machine=h8500-hitachi - os=-hms - ;; - harris) - basic_machine=m88k-harris - os=-sysv3 - ;; - hp300-*) - basic_machine=m68k-hp - ;; - hp300bsd) - basic_machine=m68k-hp - os=-bsd - ;; - hp300hpux) - basic_machine=m68k-hp - os=-hpux - ;; - hp3k9[0-9][0-9] | hp9[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hp9k2[0-9][0-9] | hp9k31[0-9]) - basic_machine=m68000-hp - ;; - hp9k3[2-9][0-9]) - basic_machine=m68k-hp - ;; - hp9k6[0-9][0-9] | hp6[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hp9k7[0-79][0-9] | hp7[0-79][0-9]) - basic_machine=hppa1.1-hp - ;; - hp9k78[0-9] | hp78[0-9]) - # FIXME: really hppa2.0-hp - basic_machine=hppa1.1-hp - ;; - hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) - # FIXME: really hppa2.0-hp - basic_machine=hppa1.1-hp - ;; - hp9k8[0-9][13679] | hp8[0-9][13679]) - basic_machine=hppa1.1-hp - ;; - hp9k8[0-9][0-9] | hp8[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hppa-next) - os=-nextstep3 - ;; - hppaosf) - basic_machine=hppa1.1-hp - os=-osf - ;; - hppro) - basic_machine=hppa1.1-hp - os=-proelf - ;; - i370-ibm* | ibm*) - basic_machine=i370-ibm - ;; - i*86v32) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv32 - ;; - i*86v4*) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv4 - ;; - i*86v) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv - ;; - i*86sol2) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-solaris2 - ;; - i386mach) - basic_machine=i386-mach - os=-mach - ;; - i386-vsta | vsta) - basic_machine=i386-unknown - os=-vsta - ;; - iris | iris4d) - basic_machine=mips-sgi - case $os in - -irix*) - ;; - *) - os=-irix4 - ;; - esac - ;; - isi68 | isi) - basic_machine=m68k-isi - os=-sysv - ;; - m68knommu) - basic_machine=m68k-unknown - os=-linux - ;; - m68knommu-*) - basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'` - os=-linux - ;; - m88k-omron*) - basic_machine=m88k-omron - ;; - magnum | m3230) - basic_machine=mips-mips - os=-sysv - ;; - merlin) - basic_machine=ns32k-utek - os=-sysv - ;; - microblaze*) - basic_machine=microblaze-xilinx - ;; - mingw64) - basic_machine=x86_64-pc - os=-mingw64 - ;; - mingw32) - basic_machine=i386-pc - os=-mingw32 - ;; - mingw32ce) - basic_machine=arm-unknown - os=-mingw32ce - ;; - miniframe) - basic_machine=m68000-convergent - ;; - *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) - basic_machine=m68k-atari - os=-mint - ;; - mips3*-*) - basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` - ;; - mips3*) - basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown - ;; - monitor) - basic_machine=m68k-rom68k - os=-coff - ;; - morphos) - basic_machine=powerpc-unknown - os=-morphos - ;; - msdos) - basic_machine=i386-pc - os=-msdos - ;; - ms1-*) - basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` - ;; - msys) - basic_machine=i386-pc - os=-msys - ;; - mvs) - basic_machine=i370-ibm - os=-mvs - ;; - nacl) - basic_machine=le32-unknown - os=-nacl - ;; - ncr3000) - basic_machine=i486-ncr - os=-sysv4 - ;; - netbsd386) - basic_machine=i386-unknown - os=-netbsd - ;; - netwinder) - basic_machine=armv4l-rebel - os=-linux - ;; - news | news700 | news800 | news900) - basic_machine=m68k-sony - os=-newsos - ;; - news1000) - basic_machine=m68030-sony - os=-newsos - ;; - news-3600 | risc-news) - basic_machine=mips-sony - os=-newsos - ;; - necv70) - basic_machine=v70-nec - os=-sysv - ;; - next | m*-next ) - basic_machine=m68k-next - case $os in - -nextstep* ) - ;; - -ns2*) - os=-nextstep2 - ;; - *) - os=-nextstep3 - ;; - esac - ;; - nh3000) - basic_machine=m68k-harris - os=-cxux - ;; - nh[45]000) - basic_machine=m88k-harris - os=-cxux - ;; - nindy960) - basic_machine=i960-intel - os=-nindy - ;; - mon960) - basic_machine=i960-intel - os=-mon960 - ;; - nonstopux) - basic_machine=mips-compaq - os=-nonstopux - ;; - np1) - basic_machine=np1-gould - ;; - neo-tandem) - basic_machine=neo-tandem - ;; - nse-tandem) - basic_machine=nse-tandem - ;; - nsr-tandem) - basic_machine=nsr-tandem - ;; - op50n-* | op60c-*) - basic_machine=hppa1.1-oki - os=-proelf - ;; - openrisc | openrisc-*) - basic_machine=or32-unknown - ;; - os400) - basic_machine=powerpc-ibm - os=-os400 - ;; - OSE68000 | ose68000) - basic_machine=m68000-ericsson - os=-ose - ;; - os68k) - basic_machine=m68k-none - os=-os68k - ;; - pa-hitachi) - basic_machine=hppa1.1-hitachi - os=-hiuxwe2 - ;; - paragon) - basic_machine=i860-intel - os=-osf - ;; - parisc) - basic_machine=hppa-unknown - os=-linux - ;; - parisc-*) - basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'` - os=-linux - ;; - pbd) - basic_machine=sparc-tti - ;; - pbb) - basic_machine=m68k-tti - ;; - pc532 | pc532-*) - basic_machine=ns32k-pc532 - ;; - pc98) - basic_machine=i386-pc - ;; - pc98-*) - basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentium | p5 | k5 | k6 | nexgen | viac3) - basic_machine=i586-pc - ;; - pentiumpro | p6 | 6x86 | athlon | athlon_*) - basic_machine=i686-pc - ;; - pentiumii | pentium2 | pentiumiii | pentium3) - basic_machine=i686-pc - ;; - pentium4) - basic_machine=i786-pc - ;; - pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) - basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentiumpro-* | p6-* | 6x86-* | athlon-*) - basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) - basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentium4-*) - basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pn) - basic_machine=pn-gould - ;; - power) basic_machine=power-ibm - ;; - ppc | ppcbe) basic_machine=powerpc-unknown - ;; - ppc-* | ppcbe-*) - basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppcle | powerpclittle | ppc-le | powerpc-little) - basic_machine=powerpcle-unknown - ;; - ppcle-* | powerpclittle-*) - basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppc64) basic_machine=powerpc64-unknown - ;; - ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppc64le | powerpc64little | ppc64-le | powerpc64-little) - basic_machine=powerpc64le-unknown - ;; - ppc64le-* | powerpc64little-*) - basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ps2) - basic_machine=i386-ibm - ;; - pw32) - basic_machine=i586-unknown - os=-pw32 - ;; - rdos | rdos64) - basic_machine=x86_64-pc - os=-rdos - ;; - rdos32) - basic_machine=i386-pc - os=-rdos - ;; - rom68k) - basic_machine=m68k-rom68k - os=-coff - ;; - rm[46]00) - basic_machine=mips-siemens - ;; - rtpc | rtpc-*) - basic_machine=romp-ibm - ;; - s390 | s390-*) - basic_machine=s390-ibm - ;; - s390x | s390x-*) - basic_machine=s390x-ibm - ;; - sa29200) - basic_machine=a29k-amd - os=-udi - ;; - sb1) - basic_machine=mipsisa64sb1-unknown - ;; - sb1el) - basic_machine=mipsisa64sb1el-unknown - ;; - sde) - basic_machine=mipsisa32-sde - os=-elf - ;; - sei) - basic_machine=mips-sei - os=-seiux - ;; - sequent) - basic_machine=i386-sequent - ;; - sh) - basic_machine=sh-hitachi - os=-hms - ;; - sh5el) - basic_machine=sh5le-unknown - ;; - sh64) - basic_machine=sh64-unknown - ;; - sparclite-wrs | simso-wrs) - basic_machine=sparclite-wrs - os=-vxworks - ;; - sps7) - basic_machine=m68k-bull - os=-sysv2 - ;; - spur) - basic_machine=spur-unknown - ;; - st2000) - basic_machine=m68k-tandem - ;; - stratus) - basic_machine=i860-stratus - os=-sysv4 - ;; - strongarm-* | thumb-*) - basic_machine=arm-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - sun2) - basic_machine=m68000-sun - ;; - sun2os3) - basic_machine=m68000-sun - os=-sunos3 - ;; - sun2os4) - basic_machine=m68000-sun - os=-sunos4 - ;; - sun3os3) - basic_machine=m68k-sun - os=-sunos3 - ;; - sun3os4) - basic_machine=m68k-sun - os=-sunos4 - ;; - sun4os3) - basic_machine=sparc-sun - os=-sunos3 - ;; - sun4os4) - basic_machine=sparc-sun - os=-sunos4 - ;; - sun4sol2) - basic_machine=sparc-sun - os=-solaris2 - ;; - sun3 | sun3-*) - basic_machine=m68k-sun - ;; - sun4) - basic_machine=sparc-sun - ;; - sun386 | sun386i | roadrunner) - basic_machine=i386-sun - ;; - sv1) - basic_machine=sv1-cray - os=-unicos - ;; - symmetry) - basic_machine=i386-sequent - os=-dynix - ;; - t3e) - basic_machine=alphaev5-cray - os=-unicos - ;; - t90) - basic_machine=t90-cray - os=-unicos - ;; - tile*) - basic_machine=$basic_machine-unknown - os=-linux-gnu - ;; - tx39) - basic_machine=mipstx39-unknown - ;; - tx39el) - basic_machine=mipstx39el-unknown - ;; - toad1) - basic_machine=pdp10-xkl - os=-tops20 - ;; - tower | tower-32) - basic_machine=m68k-ncr - ;; - tpf) - basic_machine=s390x-ibm - os=-tpf - ;; - udi29k) - basic_machine=a29k-amd - os=-udi - ;; - ultra3) - basic_machine=a29k-nyu - os=-sym1 - ;; - v810 | necv810) - basic_machine=v810-nec - os=-none - ;; - vaxv) - basic_machine=vax-dec - os=-sysv - ;; - vms) - basic_machine=vax-dec - os=-vms - ;; - vpp*|vx|vx-*) - basic_machine=f301-fujitsu - ;; - vxworks960) - basic_machine=i960-wrs - os=-vxworks - ;; - vxworks68) - basic_machine=m68k-wrs - os=-vxworks - ;; - vxworks29k) - basic_machine=a29k-wrs - os=-vxworks - ;; - w65*) - basic_machine=w65-wdc - os=-none - ;; - w89k-*) - basic_machine=hppa1.1-winbond - os=-proelf - ;; - xbox) - basic_machine=i686-pc - os=-mingw32 - ;; - xps | xps100) - basic_machine=xps100-honeywell - ;; - xscale-* | xscalee[bl]-*) - basic_machine=`echo $basic_machine | sed 's/^xscale/arm/'` - ;; - ymp) - basic_machine=ymp-cray - os=-unicos - ;; - z8k-*-coff) - basic_machine=z8k-unknown - os=-sim - ;; - z80-*-coff) - basic_machine=z80-unknown - os=-sim - ;; - none) - basic_machine=none-none - os=-none - ;; - -# Here we handle the default manufacturer of certain CPU types. It is in -# some cases the only manufacturer, in others, it is the most popular. - w89k) - basic_machine=hppa1.1-winbond - ;; - op50n) - basic_machine=hppa1.1-oki - ;; - op60c) - basic_machine=hppa1.1-oki - ;; - romp) - basic_machine=romp-ibm - ;; - mmix) - basic_machine=mmix-knuth - ;; - rs6000) - basic_machine=rs6000-ibm - ;; - vax) - basic_machine=vax-dec - ;; - pdp10) - # there are many clones, so DEC is not a safe bet - basic_machine=pdp10-unknown - ;; - pdp11) - basic_machine=pdp11-dec - ;; - we32k) - basic_machine=we32k-att - ;; - sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele) - basic_machine=sh-unknown - ;; - sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v) - basic_machine=sparc-sun - ;; - cydra) - basic_machine=cydra-cydrome - ;; - orion) - basic_machine=orion-highlevel - ;; - orion105) - basic_machine=clipper-highlevel - ;; - mac | mpw | mac-mpw) - basic_machine=m68k-apple - ;; - pmac | pmac-mpw) - basic_machine=powerpc-apple - ;; - *-unknown) - # Make sure to match an already-canonicalized machine name. - ;; - *) - echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 - exit 1 - ;; -esac - -# Here we canonicalize certain aliases for manufacturers. -case $basic_machine in - *-digital*) - basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` - ;; - *-commodore*) - basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` - ;; - *) - ;; -esac - -# Decode manufacturer-specific aliases for certain operating systems. - -if [ x"$os" != x"" ] -then -case $os in - # First match some system type aliases - # that might get confused with valid system types. - # -solaris* is a basic system type, with this one exception. - -auroraux) - os=-auroraux - ;; - -solaris1 | -solaris1.*) - os=`echo $os | sed -e 's|solaris1|sunos4|'` - ;; - -solaris) - os=-solaris2 - ;; - -svr4*) - os=-sysv4 - ;; - -unixware*) - os=-sysv4.2uw - ;; - -gnu/linux*) - os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` - ;; - # First accept the basic system types. - # The portable systems comes first. - # Each alternative MUST END IN A *, to match a version number. - # -sysv* is not here because it comes later, after sysvr4. - -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ - | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\ - | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \ - | -sym* | -kopensolaris* | -plan9* \ - | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ - | -aos* | -aros* \ - | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ - | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ - | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ - | -bitrig* | -openbsd* | -solidbsd* \ - | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ - | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ - | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ - | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ - | -chorusos* | -chorusrdb* | -cegcc* \ - | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ - | -mingw32* | -mingw64* | -linux-gnu* | -linux-android* \ - | -linux-newlib* | -linux-musl* | -linux-uclibc* \ - | -uxpv* | -beos* | -mpeix* | -udk* \ - | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ - | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ - | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ - | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ - | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ - | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ - | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es*) - # Remember, each alternative MUST END IN *, to match a version number. - ;; - -qnx*) - case $basic_machine in - x86-* | i*86-*) - ;; - *) - os=-nto$os - ;; - esac - ;; - -nto-qnx*) - ;; - -nto*) - os=`echo $os | sed -e 's|nto|nto-qnx|'` - ;; - -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ - | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \ - | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) - ;; - -mac*) - os=`echo $os | sed -e 's|mac|macos|'` - ;; - -linux-dietlibc) - os=-linux-dietlibc - ;; - -linux*) - os=`echo $os | sed -e 's|linux|linux-gnu|'` - ;; - -sunos5*) - os=`echo $os | sed -e 's|sunos5|solaris2|'` - ;; - -sunos6*) - os=`echo $os | sed -e 's|sunos6|solaris3|'` - ;; - -opened*) - os=-openedition - ;; - -os400*) - os=-os400 - ;; - -wince*) - os=-wince - ;; - -osfrose*) - os=-osfrose - ;; - -osf*) - os=-osf - ;; - -utek*) - os=-bsd - ;; - -dynix*) - os=-bsd - ;; - -acis*) - os=-aos - ;; - -atheos*) - os=-atheos - ;; - -syllable*) - os=-syllable - ;; - -386bsd) - os=-bsd - ;; - -ctix* | -uts*) - os=-sysv - ;; - -nova*) - os=-rtmk-nova - ;; - -ns2 ) - os=-nextstep2 - ;; - -nsk*) - os=-nsk - ;; - # Preserve the version number of sinix5. - -sinix5.*) - os=`echo $os | sed -e 's|sinix|sysv|'` - ;; - -sinix*) - os=-sysv4 - ;; - -tpf*) - os=-tpf - ;; - -triton*) - os=-sysv3 - ;; - -oss*) - os=-sysv3 - ;; - -svr4) - os=-sysv4 - ;; - -svr3) - os=-sysv3 - ;; - -sysvr4) - os=-sysv4 - ;; - # This must come after -sysvr4. - -sysv*) - ;; - -ose*) - os=-ose - ;; - -es1800*) - os=-ose - ;; - -xenix) - os=-xenix - ;; - -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) - os=-mint - ;; - -aros*) - os=-aros - ;; - -zvmoe) - os=-zvmoe - ;; - -dicos*) - os=-dicos - ;; - -nacl*) - ;; - -none) - ;; - *) - # Get rid of the `-' at the beginning of $os. - os=`echo $os | sed 's/[^-]*-//'` - echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 - exit 1 - ;; -esac -else - -# Here we handle the default operating systems that come with various machines. -# The value should be what the vendor currently ships out the door with their -# machine or put another way, the most popular os provided with the machine. - -# Note that if you're going to try to match "-MANUFACTURER" here (say, -# "-sun"), then you have to tell the case statement up towards the top -# that MANUFACTURER isn't an operating system. Otherwise, code above -# will signal an error saying that MANUFACTURER isn't an operating -# system, and we'll never get to this point. - -case $basic_machine in - score-*) - os=-elf - ;; - spu-*) - os=-elf - ;; - *-acorn) - os=-riscix1.2 - ;; - arm*-rebel) - os=-linux - ;; - arm*-semi) - os=-aout - ;; - c4x-* | tic4x-*) - os=-coff - ;; - hexagon-*) - os=-elf - ;; - tic54x-*) - os=-coff - ;; - tic55x-*) - os=-coff - ;; - tic6x-*) - os=-coff - ;; - # This must come before the *-dec entry. - pdp10-*) - os=-tops20 - ;; - pdp11-*) - os=-none - ;; - *-dec | vax-*) - os=-ultrix4.2 - ;; - m68*-apollo) - os=-domain - ;; - i386-sun) - os=-sunos4.0.2 - ;; - m68000-sun) - os=-sunos3 - ;; - m68*-cisco) - os=-aout - ;; - mep-*) - os=-elf - ;; - mips*-cisco) - os=-elf - ;; - mips*-*) - os=-elf - ;; - or1k-*) - os=-elf - ;; - or32-*) - os=-coff - ;; - *-tti) # must be before sparc entry or we get the wrong os. - os=-sysv3 - ;; - sparc-* | *-sun) - os=-sunos4.1.1 - ;; - *-be) - os=-beos - ;; - *-haiku) - os=-haiku - ;; - *-ibm) - os=-aix - ;; - *-knuth) - os=-mmixware - ;; - *-wec) - os=-proelf - ;; - *-winbond) - os=-proelf - ;; - *-oki) - os=-proelf - ;; - *-hp) - os=-hpux - ;; - *-hitachi) - os=-hiux - ;; - i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) - os=-sysv - ;; - *-cbm) - os=-amigaos - ;; - *-dg) - os=-dgux - ;; - *-dolphin) - os=-sysv3 - ;; - m68k-ccur) - os=-rtu - ;; - m88k-omron*) - os=-luna - ;; - *-next ) - os=-nextstep - ;; - *-sequent) - os=-ptx - ;; - *-crds) - os=-unos - ;; - *-ns) - os=-genix - ;; - i370-*) - os=-mvs - ;; - *-next) - os=-nextstep3 - ;; - *-gould) - os=-sysv - ;; - *-highlevel) - os=-bsd - ;; - *-encore) - os=-bsd - ;; - *-sgi) - os=-irix - ;; - *-siemens) - os=-sysv4 - ;; - *-masscomp) - os=-rtu - ;; - f30[01]-fujitsu | f700-fujitsu) - os=-uxpv - ;; - *-rom68k) - os=-coff - ;; - *-*bug) - os=-coff - ;; - *-apple) - os=-macos - ;; - *-atari*) - os=-mint - ;; - *) - os=-none - ;; -esac -fi - -# Here we handle the case where we know the os, and the CPU type, but not the -# manufacturer. We pick the logical manufacturer. -vendor=unknown -case $basic_machine in - *-unknown) - case $os in - -riscix*) - vendor=acorn - ;; - -sunos*) - vendor=sun - ;; - -cnk*|-aix*) - vendor=ibm - ;; - -beos*) - vendor=be - ;; - -hpux*) - vendor=hp - ;; - -mpeix*) - vendor=hp - ;; - -hiux*) - vendor=hitachi - ;; - -unos*) - vendor=crds - ;; - -dgux*) - vendor=dg - ;; - -luna*) - vendor=omron - ;; - -genix*) - vendor=ns - ;; - -mvs* | -opened*) - vendor=ibm - ;; - -os400*) - vendor=ibm - ;; - -ptx*) - vendor=sequent - ;; - -tpf*) - vendor=ibm - ;; - -vxsim* | -vxworks* | -windiss*) - vendor=wrs - ;; - -aux*) - vendor=apple - ;; - -hms*) - vendor=hitachi - ;; - -mpw* | -macos*) - vendor=apple - ;; - -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) - vendor=atari - ;; - -vos*) - vendor=stratus - ;; - esac - basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` - ;; -esac - -echo $basic_machine$os -exit - -# Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) -# time-stamp-start: "timestamp='" -# time-stamp-format: "%:y-%02m-%02d" -# time-stamp-end: "'" -# End: diff --git a/config/m-nt.h b/config/m-nt.h deleted file mode 100644 index eae64b66..00000000 --- a/config/m-nt.h +++ /dev/null @@ -1,58 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -/* Machine configuration, Intel x86 processors, Win32, - Visual C++ or Mingw compiler */ - -#ifdef _WIN64 -#define ARCH_SIXTYFOUR -#else -#undef ARCH_SIXTYFOUR -#endif -#undef ARCH_BIG_ENDIAN -#undef ARCH_ALIGN_DOUBLE - -#define SIZEOF_INT 4 -#define SIZEOF_LONG 4 -#ifdef _WIN64 -#define SIZEOF_PTR 8 -#else -#define SIZEOF_PTR 4 -#endif -#define SIZEOF_SHORT 2 - -#ifdef __MINGW32__ -#define ARCH_INT64_TYPE long long -#define ARCH_UINT64_TYPE unsigned long long -#else -#define ARCH_INT64_TYPE __int64 -#define ARCH_UINT64_TYPE unsigned __int64 -#endif -#define ARCH_INT64_PRINTF_FORMAT "I64" -#if _MSC_VER >= 1800 -#define ARCH_SIZET_PRINTF_FORMAT "z" -#else -#define ARCH_SIZET_PRINTF_FORMAT "I" -#endif - -#if defined(_MSC_VER) && !defined(__cplusplus) -#define inline __inline -#endif - -#undef NONSTANDARD_DIV_MOD - -#define PROFINFO_WIDTH 0 - -#define FLAT_FLOAT_ARRAY diff --git a/config/s-nt.h b/config/s-nt.h deleted file mode 100644 index 9947158e..00000000 --- a/config/s-nt.h +++ /dev/null @@ -1,44 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -/* Operating system dependencies, Intel x86 processors, Windows NT */ - -#define OCAML_OS_TYPE "Win32" - -#if defined(__MINGW32__) || _MSC_VER >= 1600 -#define HAS_STDINT_H -#endif -#undef BSD_SIGNALS -#define HAS_STRERROR -#define HAS_SOCKETS -#define HAS_GETCWD -#define HAS_UTIME -#define HAS_DUP2 -#define HAS_GETHOSTNAME -#define HAS_MKTIME -#define HAS_PUTENV -#ifndef __MINGW32__ -#define HAS_LOCALE_H -#define HAS_STRTOD_L -#endif -#define HAS_BROKEN_PRINTF -#define HAS_IPV6 -#define HAS_NICE -#define SUPPORT_DYNAMIC_LINKING -#define HAS_EXECVPE -#if defined(_MSC_VER) && _MSC_VER < 1300 -#define LACKS_SANE_NAN -#define LACKS_VSCPRINTF -#endif diff --git a/configure b/configure index 9a78a455..85fb6842 100755 --- a/configure +++ b/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for OCaml 4.08.1. +# Generated by GNU Autoconf 2.69 for OCaml 4.09.0. # # Report bugs to . # @@ -590,8 +590,8 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='OCaml' PACKAGE_TARNAME='ocaml' -PACKAGE_VERSION='4.08.1' -PACKAGE_STRING='OCaml 4.08.1' +PACKAGE_VERSION='4.09.0' +PACKAGE_STRING='OCaml 4.09.0' PACKAGE_BUGREPORT='caml-list@inria.fr' PACKAGE_URL='http://www.ocaml.org' @@ -634,7 +634,6 @@ ac_includes_default="\ ac_subst_vars='LTLIBOBJS LIBOBJS -XMKMF PTHREAD_CFLAGS PTHREAD_LIBS PTHREAD_CC @@ -707,10 +706,8 @@ libunwind_available call_counts spacetime frame_pointers -cc_profile profinfo_width profinfo -profiling install_source_artifacts install_bytecode_programs mksharedlibrpath @@ -721,7 +718,6 @@ sharedlib_cflags asm_cfi_supported AS ASPP -asppprofflags libbfd_link libbfd_include x_libraries @@ -765,7 +761,6 @@ extralibs syslib outputobj outputexe -graphlib unixlib unix_or_win32 systhread_support @@ -802,7 +797,6 @@ infodir docdir oldincludedir includedir -runstatedir localstatedir sharedstatedir sysconfdir @@ -859,7 +853,6 @@ with_aix_soname with_gnu_ld with_sysroot enable_libtool_lock -with_x ' ac_precious_vars='build_alias host_alias @@ -878,8 +871,7 @@ LDFLAGS LIBS CPPFLAGS LT_SYS_LIBRARY_PATH -CPP -XMKMF' +CPP' # Initialize some variables set by options. @@ -918,7 +910,6 @@ datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' -runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' @@ -1171,15 +1162,6 @@ do | -silent | --silent | --silen | --sile | --sil) silent=yes ;; - -runstatedir | --runstatedir | --runstatedi | --runstated \ - | --runstate | --runstat | --runsta | --runst | --runs \ - | --run | --ru | --r) - ac_prev=runstatedir ;; - -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ - | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ - | --run=* | --ru=* | --r=*) - runstatedir=$ac_optarg ;; - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ @@ -1317,7 +1299,7 @@ fi for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir runstatedir + libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. @@ -1430,7 +1412,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures OCaml 4.08.1 to adapt to many kinds of systems. +\`configure' configures OCaml 4.09.0 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1470,7 +1452,6 @@ Fine tuning of the installation directories: --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] - --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] @@ -1488,10 +1469,6 @@ _ACEOF cat <<\_ACEOF -X features: - --x-includes=DIR X include files are in DIR - --x-libraries=DIR X library files are in DIR - System types: --build=BUILD configure for building on BUILD [guessed] --host=HOST cross-compile to build programs to run on HOST [BUILD] @@ -1501,7 +1478,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of OCaml 4.08.1:";; + short | recursive ) echo "Configuration of OCaml 4.09.0:";; esac cat <<\_ACEOF @@ -1513,9 +1490,8 @@ Optional Features: --enable-debugger build the debugger [default=auto] --enable-instrumented-runtime build the instrumented runtime [default=auto] - --disable-vmthreads disable the bytecode threads library + --disable-systhreads disable the Win32/POSIX threads library - --disable-graph-lib do not build the graphics library --disable-str-lib do not build the str library --disable-unix-lib do not build the unix library --disable-bigarray-lib do not build the legacy separate bigarray library @@ -1562,7 +1538,6 @@ Optional Packages: --with-gnu-ld assume the C compiler uses GNU ld [default=no] --with-sysroot[=DIR] Search for dependent libraries within DIR (or the compiler's sysroot if not specified). - --with-x use the X Window System Some influential environment variables: AS which assembler to use @@ -1588,7 +1563,6 @@ Some influential environment variables: LT_SYS_LIBRARY_PATH User-defined run-time library search path. CPP C preprocessor - XMKMF Path to xmkmf, Makefile generator for X Window System Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. @@ -1657,7 +1631,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -OCaml configure 4.08.1 +OCaml configure 4.09.0 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. @@ -2320,7 +2294,7 @@ cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by OCaml $as_me 4.08.1, which was +It was created by OCaml $as_me 4.09.0, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ @@ -2669,8 +2643,8 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:${as_lineno-$LINENO}: Configuring OCaml version 4.08.1" >&5 -$as_echo "$as_me: Configuring OCaml version 4.08.1" >&6;} +{ $as_echo "$as_me:${as_lineno-$LINENO}: Configuring OCaml version 4.09.0" >&5 +$as_echo "$as_me: Configuring OCaml version 4.09.0" >&6;} # Configuration variables @@ -2745,7 +2719,7 @@ ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. ## Output variables -VERSION=4.08.1 +VERSION=4.09.0 # Note: This is present for the flexdll bootstrap where it exposed as the old @@ -2798,7 +2772,6 @@ VERSION=4.08.1 - # TODO: rename this variable @@ -2835,9 +2808,6 @@ VERSION=4.08.1 - - - @@ -3017,7 +2987,8 @@ fi # Check whether --enable-vmthreads was given. if test "${enable_vmthreads+set}" = set; then : - enableval=$enable_vmthreads; + enableval=$enable_vmthreads; as_fn_error $? "The vmthreads library is no longer available. \ +It was deleted in OCaml 4.09." "$LINENO" 5 fi @@ -3040,7 +3011,9 @@ fi # Check whether --enable-graph-lib was given. if test "${enable_graph_lib+set}" = set; then : - enableval=$enable_graph_lib; + enableval=$enable_graph_lib; as_fn_error $? "The graphics library is no longer distributed with OCaml \ +since version 4.09. It is now distributed as a separate \"graphics\" package: \ +https://github.com/ocaml/graphics" "$LINENO" 5 fi @@ -12232,13 +12205,10 @@ case $host in #( *-*-mingw32|*-pc-windows) : unix_or_win32="win32" unixlib="win32unix" - graphlib="win32graph" - cc_profile='' ;; #( + ;; #( *) : unix_or_win32="unix" - unixlib="unix" - graphlib="graph" - cc_profile='-pg' ;; + unixlib="unix" ;; esac case $host in #( *-*-cygwin*|*-*-mingw32|*-pc-windows) : @@ -12365,7 +12335,7 @@ case $ocaml_cv_cc_vendor in #( msvc-*) : outputobj=-Fo; CPP="cl -nologo -EP"; gcc_warnings="" ;; #( *) : - outputobj='-o $(EMPTY)'; case 4.08.1 in #( + outputobj='-o $(EMPTY)'; case 4.09.0 in #( *+dev*) : gcc_warnings="-Wall -Werror" ;; #( *) : @@ -13375,10 +13345,6 @@ if test x"$enable_shared" != "xno"; then : natdynlink=true ;; #( x86_64-*-linux*) : natdynlink=true ;; #( - i[3456]86-*-darwin*) : - if $arch64; then : - natdynlink=true -fi ;; #( x86_64-*-darwin*) : natdynlink=true ;; #( s390x*-*-linux*) : @@ -13415,6 +13381,8 @@ fi ;; #( natdynlink=true ;; #( aarch64-*-linux*) : natdynlink=true ;; #( + aarch64-*-freebsd*) : + natdynlink=true ;; #( *) : ;; esac @@ -13466,12 +13434,6 @@ case $host in #( arch=i386; system=beos ;; #( i[3456]86-*-cygwin) : arch=i386; system=cygwin ;; #( - i[3456]86-*-darwin*) : - if $arch64; then : - arch=amd64 -else - arch=i386 -fi; system=macosx ;; #( i[3456]86-*-gnu*) : arch=i386; system=gnu ;; #( i[3456]86-*-mingw32) : @@ -13488,10 +13450,6 @@ fi; system=macosx ;; #( else model=ppc fi; system=elf ;; #( - powerpc-*-netbsd*) : - arch=power; model=ppc; system=netbsd ;; #( - powerpc-*-openbsd*) : - arch=power; model=ppc; system=bsd_elf ;; #( s390x*-*-linux*) : arch=s390x; model=z10; system=elf ;; #( armv6*-*-linux-gnueabihf) : @@ -13544,6 +13502,8 @@ fi; system=elf ;; #( arch=amd64; system=mingw64 ;; #( aarch64-*-linux*) : arch=arm64; system=linux ;; #( + aarch64-*-freebsd*) : + arch=arm64; system=freebsd ;; #( x86_64-*-cygwin*) : arch=amd64; system=cygwin ;; #( @@ -13697,52 +13657,8 @@ if test $arch != "none" && $arch64 ; then : otherlibraries="$otherlibraries raw_spacetime_lib" fi -# Profiling - -case "$arch,$system" in #( - i386,linux_elf) : - profiling=true ;; #( - i386,gnu) : - profiling=true ;; #( - i386,bsd_elf) : - profiling=true ;; #( - amd64,macosx) : - profiling=true ;; #( - i386,macosx) : - profiling=true ;; #( - amd64,linux) : - profiling=true ;; #( - amd64,openbsd) : - profiling=true ;; #( - amd64,freebsd) : - profiling=true ;; #( - amd64,netbsd) : - profiling=true ;; #( - arm,netbsd) : - profiling=true ;; #( - amd64,gnu) : - profiling=true ;; #( - arm,linux*) : - profiling=true ;; #( - power,elf) : - profiling=true ;; #( - power,bsd*) : - profiling=true ;; #( - power,netbsd) : - profiling=true ;; #( - *) : - profiling=false ;; -esac - # Assembler -case $host in #( - *-*-mingw32|*-pc-windows) : - asppprofflags='' ;; #( - *) : - asppprofflags='-DPROFILING' ;; -esac - if test -n "$host_alias"; then : toolpref="${host_alias}-" else @@ -13792,7 +13708,7 @@ esac ;; #( s390x,elf) : default_as="${toolpref}as -m 64 -march=$model" default_aspp="${toolpref}gcc -c -Wa,-march=$model" ;; #( - arm,freebsd) : + arm,freebsd|arm64,freebsd) : default_as="${toolpref}cc -c" default_aspp="${toolpref}cc -c" ;; #( *,dragonfly) : @@ -13801,7 +13717,7 @@ esac ;; #( *,freebsd) : default_as="${toolpref}as" default_aspp="${toolpref}cc -c" ;; #( - amd64,*|arm,*|arm64,*|i386,*|power,bsd*|power,netbsd) : + amd64,*|arm,*|arm64,*|i386,*) : default_as="${toolpref}as" case $ocaml_cv_cc_vendor in #( clang-*) : @@ -13859,18 +13775,6 @@ $as_echo "$as_me: POSIX signal handling found." >&6;} else { $as_echo "$as_me:${as_lineno-$LINENO}: assuming signals have the System V semantics." >&5 $as_echo "$as_me: assuming signals have the System V semantics." >&6;} - for ac_func in sigsetmask -do : - ac_fn_c_check_func "$LINENO" "sigsetmask" "ac_cv_func_sigsetmask" -if test "x$ac_cv_func_sigsetmask" = xyes; then : - cat >>confdefs.h <<_ACEOF -#define HAVE_SIGSETMASK 1 -_ACEOF - $as_echo "#define HAS_SIGSETMASK 1" >>confdefs.h - -fi -done - fi @@ -14229,17 +14133,6 @@ if test "x$ac_cv_func_getcwd" = xyes; then : fi -ac_fn_c_check_func "$LINENO" "getpriority" "ac_cv_func_getpriority" -if test "x$ac_cv_func_getpriority" = xyes; then : - ac_fn_c_check_func "$LINENO" "setpriority" "ac_cv_func_setpriority" -if test "x$ac_cv_func_setpriority" = xyes; then : - $as_echo "#define HAS_GETPRIORITY 1" >>confdefs.h - -fi - -fi - - ## utime ## Note: this was defined in config/s-nt.h but the autoconf macros do not # seem to detect it properly on Windows so we hardcode the definition @@ -14274,13 +14167,6 @@ if test "x$ac_cv_func_utimes" = xyes; then : fi -ac_fn_c_check_func "$LINENO" "dup2" "ac_cv_func_dup2" -if test "x$ac_cv_func_dup2" = xyes; then : - $as_echo "#define HAS_DUP2 1" >>confdefs.h - -fi - - ac_fn_c_check_func "$LINENO" "fchmod" "ac_cv_func_fchmod" if test "x$ac_cv_func_fchmod" = xyes; then : ac_fn_c_check_func "$LINENO" "fchown" "ac_cv_func_fchown" @@ -14421,80 +14307,6 @@ fi -## Asynchronous I/O - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for asynchronous I/O" >&5 -$as_echo_n "checking for asynchronous I/O... " >&6; } -if test "$cross_compiling" = yes; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } - -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -#include -#include -#include -#include -#include -#include - -int signalled; - -void sigio_handler(int arg) -{ - signalled = 1; -} - -int main(void) -{ -#if defined(SIGIO) && defined(FASYNC) && defined(F_SETFL) && defined(F_SETOWN) - int p[2]; - int ret; -#define OUT 0 -#define IN 1 - if (socketpair(PF_UNIX, SOCK_STREAM, 0, p) == -1) return 1; - signalled = 0; - signal(SIGIO, sigio_handler); - ret = fcntl(p[OUT], F_GETFL, 0); - fcntl(p[OUT], F_SETFL, ret | FASYNC); - fcntl(p[OUT], F_SETOWN, getpid()); - switch(fork()) { - case -1: - return 1; - case 0: - close(p[OUT]); - write(p[IN], "x", 1); - sleep(1); - exit(0); - default: - close(p[IN]); - while(wait(NULL) == -1 && errno == EINTR) /*nothing*/; - } - if (signalled) return 0; else return 1; -#else - return 1; -#endif -} - -_ACEOF -if ac_fn_c_try_run "$LINENO"; then : - - $as_echo "#define HAS_ASYNC_IO 1" >>confdefs.h - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } - -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi -rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext -fi - - ## setitimer ac_fn_c_check_func "$LINENO" "setitimer" "ac_cv_func_setitimer" @@ -15327,7 +15139,7 @@ esac $as_echo_n "checking whether stack overflows can be detected... " >&6; } case $arch,$system in #( - i386,linux_elf|amd64,linux|amd64,macosx|i386,macosx \ + i386,linux_elf|amd64,linux|amd64,macosx \ |amd64,openbsd|i386,bsd_elf) : $as_echo "#define HAS_STACK_OVERFLOW_DETECTION 1" >>confdefs.h @@ -16024,254 +15836,6 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu esac fi -## Determine if the bytecode thread library is supported - -if test x"$enable_vmthreads" = "xno"; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: the bytecode threads library is disabled" >&5 -$as_echo "$as_me: the bytecode threads library is disabled" >&6;} -else - if $select && $setitimer && $gettimeofday && $wait; then : - otherlibraries="$otherlibraries threads" - { $as_echo "$as_me:${as_lineno-$LINENO}: the bytecode threads library is supported" >&5 -$as_echo "$as_me: the bytecode threads library is supported" >&6;} -else - if test x"$enable_vmthreads" = "xyes"; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: the bytecode threads library is not available" >&5 -$as_echo "$as_me: the bytecode threads library is not available" >&6;} -else - { $as_echo "$as_me:${as_lineno-$LINENO}: the bytecode threads library is not supported" >&5 -$as_echo "$as_me: the bytecode threads library is not supported" >&6;} -fi -fi -fi - -## XWindow - -if test x"$enable_graph_lib" = "xno" ; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: the graph library has been disabled" >&5 -$as_echo "$as_me: the graph library has been disabled" >&6;} -else - case $host in #( - *-*-mingw32|*-pc-windows) : - otherlibraries="$otherlibraries win32graph" ;; #( - *) : - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for X" >&5 -$as_echo_n "checking for X... " >&6; } - - -# Check whether --with-x was given. -if test "${with_x+set}" = set; then : - withval=$with_x; -fi - -# $have_x is `yes', `no', `disabled', or empty when we do not yet know. -if test "x$with_x" = xno; then - # The user explicitly disabled X. - have_x=disabled -else - case $x_includes,$x_libraries in #( - *\'*) as_fn_error $? "cannot use X directory names containing '" "$LINENO" 5;; #( - *,NONE | NONE,*) if ${ac_cv_have_x+:} false; then : - $as_echo_n "(cached) " >&6 -else - # One or both of the vars are not set, and there is no cached value. -ac_x_includes=no ac_x_libraries=no -rm -f -r conftest.dir -if mkdir conftest.dir; then - cd conftest.dir - cat >Imakefile <<'_ACEOF' -incroot: - @echo incroot='${INCROOT}' -usrlibdir: - @echo usrlibdir='${USRLIBDIR}' -libdir: - @echo libdir='${LIBDIR}' -_ACEOF - if (export CC; ${XMKMF-xmkmf}) >/dev/null 2>/dev/null && test -f Makefile; then - # GNU make sometimes prints "make[1]: Entering ...", which would confuse us. - for ac_var in incroot usrlibdir libdir; do - eval "ac_im_$ac_var=\`\${MAKE-make} $ac_var 2>/dev/null | sed -n 's/^$ac_var=//p'\`" - done - # Open Windows xmkmf reportedly sets LIBDIR instead of USRLIBDIR. - for ac_extension in a so sl dylib la dll; do - if test ! -f "$ac_im_usrlibdir/libX11.$ac_extension" && - test -f "$ac_im_libdir/libX11.$ac_extension"; then - ac_im_usrlibdir=$ac_im_libdir; break - fi - done - # Screen out bogus values from the imake configuration. They are - # bogus both because they are the default anyway, and because - # using them would break gcc on systems where it needs fixed includes. - case $ac_im_incroot in - /usr/include) ac_x_includes= ;; - *) test -f "$ac_im_incroot/X11/Xos.h" && ac_x_includes=$ac_im_incroot;; - esac - case $ac_im_usrlibdir in - /usr/lib | /usr/lib64 | /lib | /lib64) ;; - *) test -d "$ac_im_usrlibdir" && ac_x_libraries=$ac_im_usrlibdir ;; - esac - fi - cd .. - rm -f -r conftest.dir -fi - -# Standard set of common directories for X headers. -# Check X11 before X11Rn because it is often a symlink to the current release. -ac_x_header_dirs=' -/usr/X11/include -/usr/X11R7/include -/usr/X11R6/include -/usr/X11R5/include -/usr/X11R4/include - -/usr/include/X11 -/usr/include/X11R7 -/usr/include/X11R6 -/usr/include/X11R5 -/usr/include/X11R4 - -/usr/local/X11/include -/usr/local/X11R7/include -/usr/local/X11R6/include -/usr/local/X11R5/include -/usr/local/X11R4/include - -/usr/local/include/X11 -/usr/local/include/X11R7 -/usr/local/include/X11R6 -/usr/local/include/X11R5 -/usr/local/include/X11R4 - -/usr/X386/include -/usr/x386/include -/usr/XFree86/include/X11 - -/usr/include -/usr/local/include -/usr/unsupported/include -/usr/athena/include -/usr/local/x11r5/include -/usr/lpp/Xamples/include - -/usr/openwin/include -/usr/openwin/share/include' - -if test "$ac_x_includes" = no; then - # Guess where to find include files, by looking for Xlib.h. - # First, try using that file with no special directory specified. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -_ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : - # We can compile using X headers with no special include directory. -ac_x_includes= -else - for ac_dir in $ac_x_header_dirs; do - if test -r "$ac_dir/X11/Xlib.h"; then - ac_x_includes=$ac_dir - break - fi -done -fi -rm -f conftest.err conftest.i conftest.$ac_ext -fi # $ac_x_includes = no - -if test "$ac_x_libraries" = no; then - # Check for the libraries. - # See if we find them without any special options. - # Don't add to $LIBS permanently. - ac_save_LIBS=$LIBS - LIBS="-lX11 $LIBS" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -int -main () -{ -XrmInitialize () - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - LIBS=$ac_save_LIBS -# We can link X programs with no special library path. -ac_x_libraries= -else - LIBS=$ac_save_LIBS -for ac_dir in `$as_echo "$ac_x_includes $ac_x_header_dirs" | sed s/include/lib/g` -do - # Don't even attempt the hair of trying to link an X program! - for ac_extension in a so sl dylib la dll; do - if test -r "$ac_dir/libX11.$ac_extension"; then - ac_x_libraries=$ac_dir - break 2 - fi - done -done -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -fi # $ac_x_libraries = no - -case $ac_x_includes,$ac_x_libraries in #( - no,* | *,no | *\'*) - # Didn't find X, or a directory has "'" in its name. - ac_cv_have_x="have_x=no";; #( - *) - # Record where we found X for the cache. - ac_cv_have_x="have_x=yes\ - ac_x_includes='$ac_x_includes'\ - ac_x_libraries='$ac_x_libraries'" -esac -fi -;; #( - *) have_x=yes;; - esac - eval "$ac_cv_have_x" -fi # $with_x != no - -if test "$have_x" != yes; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $have_x" >&5 -$as_echo "$have_x" >&6; } - no_x=yes -else - # If each of the values was on the command line, it overrides each guess. - test "x$x_includes" = xNONE && x_includes=$ac_x_includes - test "x$x_libraries" = xNONE && x_libraries=$ac_x_libraries - # Update the cache value to reflect the command line values. - ac_cv_have_x="have_x=yes\ - ac_x_includes='$x_includes'\ - ac_x_libraries='$x_libraries'" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: libraries $x_libraries, headers $x_includes" >&5 -$as_echo "libraries $x_libraries, headers $x_includes" >&6; } -fi - - if test -z "$no_x"; then : - if test -z $x_libraries; then : - x_libraries="-lX11" -else - x_libraries="-L$x_libraries -lX11" -fi - { $as_echo "$as_me:${as_lineno-$LINENO}: X has been found" >&5 -$as_echo "$as_me: X has been found" >&6;} - otherlibraries="$otherlibraries graph" - { $as_echo "$as_me:${as_lineno-$LINENO}: the graph library will be built" >&5 -$as_echo "$as_me: the graph library will be built" >&6;} -else - { $as_echo "$as_me:${as_lineno-$LINENO}: X has not been found" >&5 -$as_echo "$as_me: X has not been found" >&6;} - if test x"$enable_graph_lib" = "xyes" ; then : - as_fn_error $? "can not build the graph library which was requested" "$LINENO" 5 -else - { $as_echo "$as_me:${as_lineno-$LINENO}: the graph library will not be built" >&5 -$as_echo "$as_me: the graph library will not be built" >&6;} -fi -fi ;; -esac -fi - ## libbfd ac_fn_c_check_header_mongrel "$LINENO" "bfd.h" "ac_cv_header_bfd_h" "$ac_includes_default" @@ -17560,7 +17124,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by OCaml $as_me 4.08.1, which was +This file was extended by OCaml $as_me 4.09.0, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -17627,7 +17191,7 @@ _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ -OCaml config.status 4.08.1 +OCaml config.status 4.09.0 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" diff --git a/configure.ac b/configure.ac index f5d8a268..c2f18537 100644 --- a/configure.ac +++ b/configure.ac @@ -87,7 +87,6 @@ AC_SUBST([system]) AC_SUBST([systhread_support]) AC_SUBST([unix_or_win32]) AC_SUBST([unixlib]) -AC_SUBST([graphlib]) AC_SUBST([outputexe]) AC_SUBST([outputobj]) AC_SUBST([syslib]) @@ -131,7 +130,6 @@ AC_SUBST([x_includes]) AC_SUBST([x_libraries]) AC_SUBST([libbfd_include]) AC_SUBST([libbfd_link]) -AC_SUBST([asppprofflags]) AC_SUBST([ASPP]) AC_SUBST([AS]) AC_SUBST([asm_cfi_supported]) @@ -142,10 +140,8 @@ AC_SUBST([mkmaindll]) AC_SUBST([mksharedlibrpath]) AC_SUBST([install_bytecode_programs]) AC_SUBST([install_source_artifacts]) -AC_SUBST([profiling]) AC_SUBST([profinfo]) AC_SUBST([profinfo_width]) -AC_SUBST([cc_profile]) AC_SUBST([frame_pointers]) AC_SUBST([spacetime]) AC_SUBST([call_counts]) @@ -219,9 +215,10 @@ AC_ARG_ENABLE([instrumented-runtime], [], [enable_instrumented_runtime=auto]) -AC_ARG_ENABLE([vmthreads], - [AS_HELP_STRING([--disable-vmthreads], - [disable the bytecode threads library])]) +AC_ARG_ENABLE([vmthreads], [], + [AC_MSG_ERROR([The vmthreads library is no longer available. \ +It was deleted in OCaml 4.09.])], + []) AC_ARG_ENABLE([systhreads], [AS_HELP_STRING([--disable-systhreads], @@ -237,9 +234,11 @@ AC_ARG_VAR([LIBUNWIND_INCLUDE_DIR], AC_ARG_VAR([LIBUNWIND_LIB_DIR], [location of library files for libunwind]) -AC_ARG_ENABLE([graph-lib], - [AS_HELP_STRING([--disable-graph-lib], - [do not build the graphics library])]) +AC_ARG_ENABLE([graph-lib], [], + [AC_MSG_ERROR([The graphics library is no longer distributed with OCaml \ +since version 4.09. It is now distributed as a separate "graphics" package: \ +https://github.com/ocaml/graphics])], + []) AC_ARG_ENABLE([str-lib], [AS_HELP_STRING([--disable-str-lib], @@ -428,12 +427,9 @@ AS_CASE([$host], [*-*-mingw32|*-pc-windows], [unix_or_win32="win32" unixlib="win32unix" - graphlib="win32graph" - cc_profile=''], + ], [unix_or_win32="unix" - unixlib="unix" - graphlib="graph" - cc_profile='-pg']) + unixlib="unix"]) AS_CASE([$host], [*-*-cygwin*|*-*-mingw32|*-pc-windows], [exeext=".exe"], @@ -781,7 +777,6 @@ AS_IF([test x"$enable_shared" != "xno"], [[i[3456]86-*-linux*]], [natdynlink=true], [[i[3456]86-*-gnu*]], [natdynlink=true], [[x86_64-*-linux*]], [natdynlink=true], - [[i[3456]86-*-darwin*]], [AS_IF([$arch64], [natdynlink=true])], [x86_64-*-darwin*], [natdynlink=true], [s390x*-*-linux*], [natdynlink=true], [powerpc*-*-linux*], [natdynlink=true], @@ -799,7 +794,8 @@ AS_IF([test x"$enable_shared" != "xno"], [arm*-*-linux*], [natdynlink=true], [arm*-*-freebsd*], [natdynlink=true], [earm*-*-netbsd*], [natdynlink=true], - [aarch64-*-linux*], [natdynlink=true])]) + [aarch64-*-linux*], [natdynlink=true], + [aarch64-*-freebsd*], [natdynlink=true])]) # Try to work around the Skylake/Kaby Lake processor bug. AS_CASE(["$CC,$host"], @@ -823,8 +819,6 @@ AS_CASE([$host], [arch=i386; system=beos], [[i[3456]86-*-cygwin]], [arch=i386; system=cygwin], - [[i[3456]86-*-darwin*]], - [AS_IF([$arch64], [arch=amd64], [arch=i386]); system=macosx], [[i[3456]86-*-gnu*]], [arch=i386; system=gnu], [[i[3456]86-*-mingw32]], @@ -837,10 +831,6 @@ AS_CASE([$host], [arch=power; model=ppc64le; system=elf], [[powerpc*-*-linux*]], [arch=power; AS_IF([$arch64],[model=ppc64],[model=ppc]); system=elf], - [[powerpc-*-netbsd*]], - [arch=power; model=ppc; system=netbsd], - [[powerpc-*-openbsd*]], - [arch=power; model=ppc; system=bsd_elf], [[s390x*-*-linux*]], [arch=s390x; model=z10; system=elf], [armv6*-*-linux-gnueabihf], @@ -893,6 +883,8 @@ AS_CASE([$host], [arch=amd64; system=mingw64], [aarch64-*-linux*], [arch=arm64; system=linux], + [aarch64-*-freebsd*], + [arch=arm64; system=freebsd], [x86_64-*-cygwin*], [arch=amd64; system=cygwin] ) @@ -929,32 +921,8 @@ AS_IF([test -z "$PARTIALLD"], AS_IF([test $arch != "none" && $arch64 ], [otherlibraries="$otherlibraries raw_spacetime_lib"]) -# Profiling - -AS_CASE(["$arch,$system"], - [i386,linux_elf], [profiling=true], - [i386,gnu], [profiling=true], - [i386,bsd_elf], [profiling=true], - [amd64,macosx], [profiling=true], - [i386,macosx], [profiling=true], - [amd64,linux], [profiling=true], - [amd64,openbsd], [profiling=true], - [amd64,freebsd], [profiling=true], - [amd64,netbsd], [profiling=true], - [arm,netbsd], [profiling=true], - [amd64,gnu], [profiling=true], - [arm,linux*], [profiling=true], - [power,elf], [profiling=true], - [power,bsd*], [profiling=true], - [power,netbsd], [profiling=true], - [profiling=false]) - # Assembler -AS_CASE([$host], - [*-*-mingw32|*-pc-windows], [asppprofflags=''], - [asppprofflags='-DPROFILING']) - AS_IF([test -n "$host_alias"], [toolpref="${host_alias}-"], [toolpref=""]) # We first compute default values for as and aspp @@ -995,7 +963,7 @@ AS_CASE(["$arch,$system"], [s390x,elf], [default_as="${toolpref}as -m 64 -march=$model" default_aspp="${toolpref}gcc -c -Wa,-march=$model"], - [arm,freebsd], + [arm,freebsd|arm64,freebsd], [default_as="${toolpref}cc -c" default_aspp="${toolpref}cc -c"], [*,dragonfly], @@ -1004,7 +972,7 @@ AS_CASE(["$arch,$system"], [*,freebsd], [default_as="${toolpref}as" default_aspp="${toolpref}cc -c"], - [amd64,*|arm,*|arm64,*|i386,*|power,bsd*|power,netbsd], + [amd64,*|arm,*|arm64,*|i386,*], [default_as="${toolpref}as" AS_CASE([$ocaml_cv_cc_vendor], [clang-*], [default_aspp="${toolpref}clang -c -Wno-trigraphs"], @@ -1159,10 +1127,6 @@ AC_CHECK_FUNC([mkfifo], [AC_DEFINE([HAS_MKFIFO])]) AC_CHECK_FUNC([getcwd], [AC_DEFINE([HAS_GETCWD])]) -AC_CHECK_FUNC([getpriority], - [AC_CHECK_FUNC([setpriority], - [AC_DEFINE([HAS_GETPRIORITY])])]) - ## utime ## Note: this was defined in config/s-nt.h but the autoconf macros do not # seem to detect it properly on Windows so we hardcode the definition @@ -1175,8 +1139,6 @@ AS_CASE([$host], AC_CHECK_FUNC([utimes], [AC_DEFINE([HAS_UTIMES])]) -AC_CHECK_FUNC([dup2], [AC_DEFINE([HAS_DUP2])]) - AC_CHECK_FUNC([fchmod], [AC_CHECK_FUNC([fchown], [AC_DEFINE([HAS_FCHMOD])])]) @@ -1232,64 +1194,6 @@ AC_CHECK_HEADER([termios.h], [AC_CHECK_FUNC([tcflush], [AC_CHECK_FUNC([tcflow], [AC_DEFINE([HAS_TERMIOS])])])])])])]) -## Asynchronous I/O - -AC_MSG_CHECKING([for asynchronous I/O]) -AC_RUN_IFELSE( - [AC_LANG_SOURCE([[ -#include -#include -#include -#include -#include -#include - -int signalled; - -void sigio_handler(int arg) -{ - signalled = 1; -} - -int main(void) -{ -#if defined(SIGIO) && defined(FASYNC) && defined(F_SETFL) && defined(F_SETOWN) - int p[2]; - int ret; -#define OUT 0 -#define IN 1 - if (socketpair(PF_UNIX, SOCK_STREAM, 0, p) == -1) return 1; - signalled = 0; - signal(SIGIO, sigio_handler); - ret = fcntl(p[OUT], F_GETFL, 0); - fcntl(p[OUT], F_SETFL, ret | FASYNC); - fcntl(p[OUT], F_SETOWN, getpid()); - switch(fork()) { - case -1: - return 1; - case 0: - close(p[OUT]); - write(p[IN], "x", 1); - sleep(1); - exit(0); - default: - close(p[IN]); - while(wait(NULL) == -1 && errno == EINTR) /*nothing*/; - } - if (signalled) return 0; else return 1; -#else - return 1; -#endif -} - ]])], - [ - AC_DEFINE([HAS_ASYNC_IO]) - AC_MSG_RESULT([yes]) - ], - [AC_MSG_RESULT([no])], - [AC_MSG_RESULT([no])] -) - ## setitimer AC_CHECK_FUNC([setitimer], @@ -1494,7 +1398,7 @@ AS_CASE([$enable_debug_runtime], AC_MSG_CHECKING([whether stack overflows can be detected]) AS_CASE([$arch,$system], - [i386,linux_elf|amd64,linux|amd64,macosx|i386,macosx \ + [i386,linux_elf|amd64,linux|amd64,macosx \ |amd64,openbsd|i386,bsd_elf], [AC_DEFINE([HAS_STACK_OVERFLOW_DETECTION]) AC_MSG_RESULT([yes])], @@ -1531,36 +1435,6 @@ AS_IF([test x"$enable_systhreads" = "xno"], [systhread_support=false AC_MSG_NOTICE([the POSIX threads library is not supported])])])])]) -## Determine if the bytecode thread library is supported - -AS_IF([test x"$enable_vmthreads" = "xno"], - [AC_MSG_NOTICE([the bytecode threads library is disabled])], - [AS_IF([$select && $setitimer && $gettimeofday && $wait], - [otherlibraries="$otherlibraries threads" - AC_MSG_NOTICE([the bytecode threads library is supported])], - [AS_IF([test x"$enable_vmthreads" = "xyes"], - [AC_MSG_NOTICE([the bytecode threads library is not available])], - [AC_MSG_NOTICE([the bytecode threads library is not supported])])])]) - -## XWindow - -AS_IF([test x"$enable_graph_lib" = "xno" ], - [AC_MSG_NOTICE([the graph library has been disabled])], - [AS_CASE([$host], - [*-*-mingw32|*-pc-windows], [otherlibraries="$otherlibraries win32graph"], - [AC_PATH_X - AS_IF([test -z "$no_x"], - [AS_IF([test -z $x_libraries], - [x_libraries="-lX11"], - [x_libraries="-L$x_libraries -lX11"]) - AC_MSG_NOTICE([X has been found]) - otherlibraries="$otherlibraries graph" - AC_MSG_NOTICE([the graph library will be built])], - [AC_MSG_NOTICE([X has not been found]) - AS_IF([test x"$enable_graph_lib" = "xyes" ], - [AC_MSG_ERROR([can not build the graph library which was requested])], - [AC_MSG_NOTICE([the graph library will not be built])])])])]) - ## libbfd AC_CHECK_HEADER([bfd.h], diff --git a/debugger/.depend b/debugger/.depend index 841f8fe2..114bd380 100644 --- a/debugger/.depend +++ b/debugger/.depend @@ -255,9 +255,10 @@ loadprinter.cmo : \ ../utils/misc.cmi \ ../parsing/longident.cmi \ ../utils/load_path.cmi \ + ../typing/ident.cmi \ ../typing/env.cmi \ + ../otherlibs/dynlink/dynlink.cmi \ ../typing/ctype.cmi \ - ../driver/compdynlink.cmi \ loadprinter.cmi loadprinter.cmx : \ ../typing/types.cmx \ @@ -269,13 +270,14 @@ loadprinter.cmx : \ ../utils/misc.cmx \ ../parsing/longident.cmx \ ../utils/load_path.cmx \ + ../typing/ident.cmx \ ../typing/env.cmx \ + ../otherlibs/dynlink/dynlink.cmi \ ../typing/ctype.cmx \ - ../driver/compdynlink.cmi \ loadprinter.cmi loadprinter.cmi : \ ../parsing/longident.cmi \ - ../driver/compdynlink.cmi + ../otherlibs/dynlink/dynlink.cmi main.cmo : \ unix_tools.cmi \ $(UNIXDIR)/unix.cmi \ @@ -284,6 +286,7 @@ main.cmo : \ question.cmi \ program_management.cmi \ primitives.cmi \ + ../typing/persistent_env.cmi \ parameters.cmi \ ../utils/misc.cmi \ loadprinter.cmi \ @@ -291,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 : \ @@ -306,6 +308,7 @@ main.cmx : \ question.cmx \ program_management.cmx \ primitives.cmx \ + ../typing/persistent_env.cmx \ parameters.cmx \ ../utils/misc.cmx \ loadprinter.cmx \ @@ -313,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 : \ diff --git a/debugger/Makefile b/debugger/Makefile index 4d7a0966..1ff7fc25 100644 --- a/debugger/Makefile +++ b/debugger/Makefile @@ -18,6 +18,7 @@ ROOTDIR = .. include $(ROOTDIR)/Makefile.config include $(ROOTDIR)/Makefile.common +DYNLINKDIR=$(ROOTDIR)/otherlibs/dynlink UNIXDIR=$(ROOTDIR)/otherlibs/$(UNIXLIB) CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun CAMLYACC ?= $(ROOTDIR)/yacc/ocamlyacc$(EXE) @@ -25,15 +26,15 @@ CAMLYACC ?= $(ROOTDIR)/yacc/ocamlyacc$(EXE) CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -g -nostdlib -I $(ROOTDIR)/stdlib COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -warn-error A \ -safe-string -strict-sequence -strict-formats -LINKFLAGS=-linkall -I $(UNIXDIR) +LINKFLAGS=-linkall -I $(UNIXDIR) -I $(DYNLINKDIR) YACCFLAGS= CAMLLEX=$(CAMLRUN) $(ROOTDIR)/boot/ocamllex CAMLDEP=$(CAMLRUN) $(ROOTDIR)/boot/ocamlc -depend DEPFLAGS=-slash DEPINCLUDES=$(INCLUDES) -DIRECTORIES=$(UNIXDIR) $(addprefix $(ROOTDIR)/,\ - utils parsing typing bytecomp toplevel driver) +DIRECTORIES=$(UNIXDIR) $(DYNLINKDIR) $(addprefix $(ROOTDIR)/,\ + utils parsing typing bytecomp toplevel driver file_formats lambda) INCLUDES=$(addprefix -I ,$(DIRECTORIES)) @@ -47,18 +48,23 @@ parsing_modules := $(addprefix parsing/,\ typing_modules := $(addprefix typing/,\ ident path types btype primitive typedtree subst predef datarepr \ - cmi_format 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 := driver/compdynlink_types \ - driver/compdynlink_platform_intf \ - driver/compdynlink_common driver/compdynlink toplevel/genprintval +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 \ @@ -73,7 +79,7 @@ all_objects := $(addsuffix .cmo,$(all_modules)) all: ocamldebug$(EXE) -ocamldebug$(EXE): $(UNIXDIR)/unix.cma $(all_objects) +ocamldebug$(EXE): $(UNIXDIR)/unix.cma $(DYNLINKDIR)/dynlink.cma $(all_objects) $(CAMLC) $(LINKFLAGS) -o $@ -linkall $^ install: diff --git a/debugger/dune b/debugger/dune index 97560943..60813e0c 100644 --- a/debugger/dune +++ b/debugger/dune @@ -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)) diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml index fd1a9d35..f664a278 100644 --- a/debugger/loadprinter.ml +++ b/debugger/loadprinter.ml @@ -22,7 +22,7 @@ open Types (* Error report *) type error = - | Load_failure of Compdynlink.error + | Load_failure of Dynlink.error | Unbound_identifier of Longident.t | Unavailable_module of string * Longident.t | Wrong_type of Longident.t @@ -30,28 +30,6 @@ type error = exception Error of error -(* Symtable has global state, and normally holds the symbol table - for the debuggee. We need to switch it temporarily to the - symbol table for the debugger. *) - -let debugger_symtable = ref (None: Symtable.global_map option) - -let use_debugger_symtable fn arg = - let old_symtable = Symtable.current_state() in - begin match !debugger_symtable with - | None -> - Compdynlink.allow_unsafe_modules true; - debugger_symtable := Some(Symtable.current_state()) - | Some st -> - Symtable.restore_state st - end; - Misc.try_finally (fun () -> - let result = fn arg in - debugger_symtable := Some(Symtable.current_state()); - result - ) - ~always:(fun () -> Symtable.restore_state old_symtable) - (* Load a .cmo or .cma file *) open Format @@ -59,16 +37,21 @@ open Format let rec loadfiles ppf name = try let filename = Load_path.find name in - use_debugger_symtable Compdynlink.loadfile filename; + Dynlink.allow_unsafe_modules true; + Dynlink.loadfile filename; let d = Filename.dirname name in if d <> Filename.current_dir_name then begin if not (List.mem d (Load_path.get_paths ())) then Load_path.add_dir d; end; - fprintf ppf "File %s loaded@." filename; + fprintf ppf "File %s loaded@." + (if d <> Filename.current_dir_name then + filename + else + Filename.basename filename); true with - | Compdynlink.Error (Compdynlink.Unavailable_unit unit) -> + | Dynlink.Error (Dynlink.Unavailable_unit unit) -> loadfiles ppf (String.uncapitalize_ascii unit ^ ".cmo") && loadfiles ppf name @@ -78,7 +61,7 @@ let rec loadfiles ppf name = | Sys_error msg -> fprintf ppf "%s: %s@." name msg; false - | Compdynlink.Error e -> + | Dynlink.Error e -> raise(Error(Load_failure e)) let loadfile ppf name = @@ -89,11 +72,16 @@ let loadfile ppf name = the debuggee. *) let rec eval_address = function - | Env.Aident id -> Symtable.get_global_value id + | Env.Aident id -> + assert (Ident.persistent id); + let bytecode_or_asm_symbol = Ident.name id in + begin match Dynlink.unsafe_get_global_value ~bytecode_or_asm_symbol with + | None -> + raise (Symtable.Error (Symtable.Undefined_global bytecode_or_asm_symbol)) + | Some obj -> obj + end | Env.Adot(addr, pos) -> Obj.field (eval_address addr) pos -(* PR#7258: get rid of module aliases before evaluating paths *) - let eval_value_path env path = match Env.find_value_address path env with | addr -> eval_address addr @@ -141,7 +129,7 @@ let install_printer ppf lid = let (ty_arg, path, is_old_style) = find_printer_type lid in let v = try - use_debugger_symtable (eval_value_path Env.empty) path + eval_value_path Env.empty path with Symtable.Error(Symtable.Undefined_global s) -> raise(Error(Unavailable_module(s, lid))) in let print_function = @@ -165,7 +153,7 @@ open Format let report_error ppf = function | Load_failure e -> fprintf ppf "@[Error during code loading: %s@]@." - (Compdynlink.error_message e) + (Dynlink.error_message e) | Unbound_identifier lid -> fprintf ppf "@[Unbound identifier %a@]@." Printtyp.longident lid diff --git a/debugger/loadprinter.mli b/debugger/loadprinter.mli index 81e4814e..f20345a4 100644 --- a/debugger/loadprinter.mli +++ b/debugger/loadprinter.mli @@ -26,7 +26,7 @@ val remove_printer : Longident.t -> unit (* Error report *) type error = - | Load_failure of Compdynlink.error + | Load_failure of Dynlink.error | Unbound_identifier of Longident.t | Unavailable_module of string * Longident.t | Wrong_type of Longident.t diff --git a/debugger/main.ml b/debugger/main.ml index 41429a3b..60bbdd2b 100644 --- a/debugger/main.ml +++ b/debugger/main.ml @@ -199,6 +199,10 @@ let speclist = [ let function_placeholder () = raise Not_found +let report report_error error = + eprintf "Debugger [version %s] environment error:@ @[@;%a@]@.;" + Config.version report_error error + let main () = Callback.register "Debugger.function_placeholder" function_placeholder; try @@ -232,17 +236,13 @@ let main () = kill_program (); exit 0 with - Toplevel -> + | Toplevel -> exit 2 - | Env.Error e -> - eprintf "Debugger [version %s] environment error:@ @[@;" Config.version; - Env.report_error err_formatter e; - eprintf "@]@."; + | Persistent_env.Error e -> + report Persistent_env.report_error e; exit 2 | Cmi_format.Error e -> - eprintf "Debugger [version %s] environment error:@ @[@;" Config.version; - Cmi_format.report_error err_formatter e; - eprintf "@]@."; + report Cmi_format.report_error e; exit 2 let _ = diff --git a/driver/compenv.ml b/driver/compenv.ml index c4b62d63..d5dde211 100644 --- a/driver/compenv.ml +++ b/driver/compenv.ml @@ -179,8 +179,6 @@ let float_setter ppf name option s = ("OCAMLPARAM", Printf.sprintf "non-float parameter for \"%s\"" name)) *) -let load_plugin = ref (fun _ -> ()) - let check_bool ppf name s = match s with | "0" -> false @@ -199,7 +197,6 @@ let read_one_param ppf position name v = let clear name options s = setter ppf (fun b -> not b) name options s in match name with | "g" -> set "g" [ Clflags.debug ] v - | "p" -> set "p" [ Clflags.gprofile ] v | "bin-annot" -> set "bin-annot" [ Clflags.binary_annotations ] v | "afl-instrument" -> set "afl-instrument" [ Clflags.afl_instrument ] v | "afl-inst-ratio" -> @@ -235,6 +232,7 @@ let read_one_param ppf position name v = | "pp" -> preprocessor := Some v | "runtime-variant" -> runtime_variant := v + | "with-runtime" -> set "with-runtime" [ with_runtime ] v | "open" -> open_modules := List.rev_append (String.split_on_char ',' v) !open_modules | "cc" -> c_compiler := Some v @@ -341,6 +339,8 @@ let read_one_param ppf position name v = set "flambda-invariants" [ flambda_invariant_checks ] v | "linscan" -> set "linscan" [ use_linscan ] v + | "insn-sched" -> set "insn-sched" [ insn_sched ] v + | "no-insn-sched" -> clear "insn-sched" [ insn_sched ] v (* color output *) | "color" -> @@ -428,8 +428,6 @@ let read_one_param ppf position name v = let if_on = if name = "timings" then [ `Time ] else Profile.all_columns in profile_columns := if check_bool ppf name v then if_on else [] - | "plugin" -> !load_plugin v - | "stop-after" -> let module P = Clflags.Compiler_pass in begin match P.of_string v with diff --git a/driver/compenv.mli b/driver/compenv.mli index f9465b62..ddbdc818 100644 --- a/driver/compenv.mli +++ b/driver/compenv.mli @@ -29,9 +29,6 @@ val first_ppx : string list ref val first_include_dirs : string list ref val last_include_dirs : string list ref -(* function to call on plugin=XXX *) -val load_plugin : (string -> unit) ref - (* return the list of objfiles, after OCAMLPARAM and List.rev *) val get_objfiles : with_ocamlparam:bool -> string list val last_objfiles : string list ref diff --git a/driver/compify_dynlink.sh b/driver/compify_dynlink.sh deleted file mode 100755 index 63bb86bb..00000000 --- a/driver/compify_dynlink.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/sh - -grep -v 'REMOVE_ME for ' $1 | sed 's/Dynlink_/Compdynlink_/g' > $2 diff --git a/driver/compile.ml b/driver/compile.ml index ba63a63b..c41a877f 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -35,7 +35,7 @@ let to_bytecode i (typedtree, coercion) = (fun { Lambda.code = lambda; required_globals } -> lambda |> print_if i.ppf_dump Clflags.dump_rawlambda Printlambda.lambda - |> Simplif.simplify_lambda i.source_file + |> Simplif.simplify_lambda |> print_if i.ppf_dump Clflags.dump_lambda Printlambda.lambda |> Bytegen.compile_implementation i.module_name |> print_if i.ppf_dump Clflags.dump_instr Printinstr.instrlist diff --git a/driver/compile_common.ml b/driver/compile_common.ml index 2dc00d10..601cfa83 100644 --- a/driver/compile_common.ml +++ b/driver/compile_common.ml @@ -32,7 +32,7 @@ let cmo i = i.output_prefix ^ ".cmo" let annot i = i.output_prefix ^ ".annot" let with_info ~native ~tool_name ~source_file ~output_prefix ~dump_ext k = - Compmisc.init_path native; + Compmisc.init_path (); let module_name = module_of_filename source_file output_prefix in Env.set_unit_name module_name; let env = Compmisc.initial_env() in @@ -59,7 +59,7 @@ let typecheck_intf info ast = Profile.(record_call typing) @@ fun () -> let tsg = ast - |> Typemod.type_interface info.source_file info.env + |> Typemod.type_interface info.env |> print_if info.ppf_dump Clflags.dump_typedtree Printtyped.interface in let sg = tsg.Typedtree.sig_type in diff --git a/driver/compmisc.ml b/driver/compmisc.ml index 7cf81f2e..743df6c9 100644 --- a/driver/compmisc.ml +++ b/driver/compmisc.ml @@ -21,11 +21,9 @@ open Compenv then the standard library directory (unless the -nostdlib option is given). *) -let init_path ?(dir="") native = +let init_path ?(dir="") () = let dirs = if !Clflags.use_threads then "+threads" :: !Clflags.include_dirs - else if !Clflags.use_vmthreads && not native then - "+vmthreads" :: !Clflags.include_dirs else !Clflags.include_dirs in @@ -40,7 +38,7 @@ let init_path ?(dir="") native = (* Return the initial environment in which compilation proceeds. *) (* Note: do not do init_path() in initial_env, this breaks - toplevel initialization (PR#1775) *) + toplevel initialization (PR#8227) *) let initial_env () = Ident.reinit(); diff --git a/driver/compmisc.mli b/driver/compmisc.mli index dd1ded47..bb4c292b 100644 --- a/driver/compmisc.mli +++ b/driver/compmisc.mli @@ -13,7 +13,7 @@ (* *) (**************************************************************************) -val init_path : ?dir:string -> bool -> unit +val init_path : ?dir:string -> unit -> unit val initial_env : unit -> Env.t (* Support for flags that can also be set from an environment variable *) diff --git a/driver/compplugin.ml b/driver/compplugin.ml deleted file mode 100644 index ad29cc91..00000000 --- a/driver/compplugin.ml +++ /dev/null @@ -1,50 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* A table to avoid double linking of plugins, especially with OCAMLPARAM *) -let plugins = Hashtbl.create 13 - -let load plugin_name = - - let plugin_name = - try - Compdynlink.adapt_filename plugin_name - with Invalid_argument _ -> plugin_name - in - - let plugin_file = - if Filename.is_implicit plugin_name then - try - Compmisc.init_path !Clflags.native_code; - Load_path.find plugin_name - with Not_found -> - failwith (Printf.sprintf "Cannot find plugin %s in load path" - plugin_name) - else plugin_name - in - - if not (Hashtbl.mem plugins plugin_file) then begin - Compdynlink.loadfile plugin_file; - Hashtbl.add plugins plugin_file (); (* plugin loaded *) - end - -let () = - Location.register_error_of_exn (function - | Compdynlink.Error error -> - Some (Location.error ( - Printf.sprintf "%s while loading argument of -plugin" - (Compdynlink.error_message error))) - | _ -> None); - Compenv.load_plugin := load diff --git a/driver/compplugin.mli b/driver/compplugin.mli deleted file mode 100644 index a1103f64..00000000 --- a/driver/compplugin.mli +++ /dev/null @@ -1,16 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -val load : string -> unit diff --git a/driver/dune b/driver/dune deleted file mode 100644 index 7f2697e1..00000000 --- a/driver/dune +++ /dev/null @@ -1,55 +0,0 @@ -;************************************************************************** -;* * -;* 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 compdynlink.ml) - (deps (:ml ../otherlibs/dynlink/dynlink.ml) - (:sh ./compify_dynlink.sh)) - (action (run %{sh} %{ml} %{targets}))) - -(rule - (targets compdynlink.mli) - (deps (:ml ../otherlibs/dynlink/dynlink.mli) - (:sh ./compify_dynlink.sh)) - (action (run %{sh} %{ml} %{targets}))) - -(rule - (targets compdynlink_types.ml) - (deps (:ml ../otherlibs/dynlink/dynlink_types.ml) - (:sh ./compify_dynlink.sh)) - (action (run %{sh} %{ml} %{targets}))) - -(rule - (targets compdynlink_types.mli) - (deps (:ml ../otherlibs/dynlink/dynlink_types.mli) - (:sh ./compify_dynlink.sh)) - (action (run %{sh} %{ml} %{targets}))) - -(rule - (targets compdynlink_common.ml) - (deps (:ml ../otherlibs/dynlink/dynlink_common.ml) - (:sh ./compify_dynlink.sh)) - (action (run %{sh} %{ml} %{targets}))) - -(rule - (targets compdynlink_common.mli) - (deps (:ml ../otherlibs/dynlink/dynlink_common.mli) - (:sh ./compify_dynlink.sh)) - (action (run %{sh} %{ml} %{targets}))) - -(rule - (targets compdynlink_platform_intf.ml) - (deps (:ml ../otherlibs/dynlink/dynlink_platform_intf.ml) - (:sh ./compify_dynlink.sh)) - (action (run %{sh} %{ml} %{targets}))) diff --git a/driver/main.ml b/driver/main.ml index 93299aed..a649d24a 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -21,6 +21,12 @@ let usage = "Usage: ocamlc \nOptions are:" (* Error messages to standard error formatter *) let ppf = Format.err_formatter +let vmthread_removed_message = "\ +The -vmthread argument of ocamlc is no longer supported\n\ +since OCaml 4.09.0. Please switch to system threads, which have the\n\ +same API. Lightweight threads with VM-level scheduling are provided by\n\ +third-party libraries such as Lwt, but with a different API." + module Options = Main_args.Make_bytecomp_options (struct let set r () = r := true let unset r () = r := false @@ -89,12 +95,14 @@ module Options = Main_args.Make_bytecomp_options (struct let _pack = set make_package let _pp s = preprocessor := Some s let _ppx s = first_ppx := s :: !first_ppx - let _plugin p = Compplugin.load p + let _plugin _p = plugin := true let _principal = set principal let _no_principal = unset principal let _rectypes = set recursive_types let _no_rectypes = unset recursive_types let _runtime_variant s = runtime_variant := s + let _with_runtime = set with_runtime + let _without_runtime = unset with_runtime let _safe_string = unset unsafe_string let _short_paths = unset real_paths let _strict_sequence = set strict_sequence @@ -102,7 +110,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _strict_formats = set strict_formats let _no_strict_formats = unset strict_formats let _thread = set use_threads - let _vmthread = set use_vmthreads + let _vmthread = fun () -> fatal vmthread_removed_message let _unboxed_types = set unboxed_types let _no_unboxed_types = unset unboxed_types let _unsafe = set unsafe @@ -140,12 +148,6 @@ module Options = Main_args.Make_bytecomp_options (struct let anonymous = anonymous end) -let vmthread_deprecated_message = "\ -The -vmthread argument of ocamlc is deprecated\n\ -since OCaml 4.08.0. Please switch to system threads, which have the\n\ -same API. Lightweight threads with VM-level scheduling are provided by\n\ -third-party libraries such as Lwt, but with a different API." - let main () = Clflags.add_arguments __LOC__ Options.list; Clflags.add_arguments __LOC__ @@ -155,8 +157,8 @@ let main () = readenv ppf Before_args; Clflags.parse_arguments anonymous usage; Compmisc.read_clflags_from_env (); - if !Clflags.use_vmthreads then - Location.deprecated Location.none vmthread_deprecated_message; + if !Clflags.plugin then + fatal "-plugin is only supported up to OCaml 4.08.0"; begin try Compenv.process_deferred_actions (ppf, @@ -189,7 +191,7 @@ let main () = (String.concat "|" P.pass_names) end; if !make_archive then begin - Compmisc.init_path false; + Compmisc.init_path (); Bytelibrarian.create_archive (Compenv.get_objfiles ~with_ocamlparam:false) @@ -197,7 +199,7 @@ let main () = Warnings.check_fatal (); end else if !make_package then begin - Compmisc.init_path false; + Compmisc.init_path (); let extracted_output = extract_output !output_name in let revd = get_objfiles ~with_ocamlparam:false in Compmisc.with_ppf_dump ~file_prefix:extracted_output (fun ppf_dump -> @@ -222,7 +224,7 @@ let main () = else default_output !output_name in - Compmisc.init_path false; + Compmisc.init_path (); Bytelink.link (get_objfiles ~with_ocamlparam:true) target; Warnings.check_fatal (); end; diff --git a/driver/main_args.ml b/driver/main_args.ml index 456850eb..b7e3c082 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -245,6 +245,18 @@ let mk_intf_suffix_2 f = "-intf_suffix", Arg.String f, " (deprecated) same as -intf-suffix" ;; +let mk_insn_sched f = + "-insn-sched", Arg.Unit f, + Printf.sprintf " Run the instruction scheduling pass%s" + (if Clflags.insn_sched_default then " (default)" else "") +;; + +let mk_no_insn_sched f = + "-no-insn-sched", Arg.Unit f, + Printf.sprintf " Do not run the instruction scheduling pass%s" + (if not Clflags.insn_sched_default then " (default)" else "") +;; + let mk_keep_docs f = "-keep-docs", Arg.Unit f, " Keep documentation strings in .cmi files" ;; @@ -389,9 +401,7 @@ let mk_output_complete_obj f = ;; let mk_p f = - "-p", Arg.Unit f, - " Compile and link with profiling support for \"gprof\"\n\ - \ (not supported on all platforms)" + "-p", Arg.Unit f, " (no longer supported)" ;; let mk_pack_byt f = @@ -413,7 +423,7 @@ let mk_ppx f = let mk_plugin f = "-plugin", Arg.String f, - " Load dynamic plugin " + " (no longer supported)" ;; let mk_principal f = @@ -444,6 +454,16 @@ let mk_runtime_variant f = " Use the variant of the run-time system" ;; +let mk_with_runtime f = + "-with-runtime", Arg.Unit f, + "Include the runtime system in the generated program (default)" +;; + +let mk_without_runtime f = + "-without-runtime", Arg.Unit f, + "Do not include the runtime system in the generated program." +;; + let mk_S f = "-S", Arg.Unit f, " Keep intermediate assembly file" ;; @@ -564,8 +584,7 @@ let mk_no_version f = let mk_vmthread f = "-vmthread", Arg.Unit f, - " (deprecated) Generate code that supports the threads library\n\ - \ with VM-level scheduling" + " (no longer supported)" ;; let mk_vnum f = @@ -921,6 +940,8 @@ module type Compiler_options = sig val _no_principal : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit + val _with_runtime : unit -> unit + val _without_runtime : unit -> unit val _safe_string : unit -> unit val _short_paths : unit -> unit val _thread : unit -> unit @@ -1003,6 +1024,8 @@ module type Optcommon_options = sig val _no_unbox_specialised_args : unit -> unit val _o2 : unit -> unit val _o3 : unit -> unit + val _insn_sched : unit -> unit + val _no_insn_sched : unit -> unit val _clambda_checks : unit -> unit val _dflambda : unit -> unit @@ -1060,10 +1083,6 @@ module type Ocamldoc_options = sig val _intf : string -> unit val _intf_suffix : string -> unit val _pp : string -> unit - val _principal : unit -> unit - val _rectypes : unit -> unit - val _safe_string : unit -> unit - val _short_paths : unit -> unit val _thread : unit -> unit val _v : unit -> unit val _verbose : unit -> unit @@ -1137,6 +1156,8 @@ struct mk_rectypes F._rectypes; mk_no_rectypes F._no_rectypes; mk_runtime_variant F._runtime_variant; + mk_with_runtime F._with_runtime; + mk_without_runtime F._without_runtime; mk_safe_string F._safe_string; mk_short_paths F._short_paths; mk_strict_sequence F._strict_sequence; @@ -1281,6 +1302,7 @@ struct mk_inline_indirect_cost F._inline_indirect_cost; mk_inline_lifting_benefit F._inline_lifting_benefit; mk_inlining_report F._inlining_report; + mk_insn_sched F._insn_sched; mk_intf F._intf; mk_intf_suffix F._intf_suffix; mk_keep_docs F._keep_docs; @@ -1299,6 +1321,7 @@ struct mk_noassert F._noassert; mk_noautolink_opt F._noautolink; mk_nodynlink F._nodynlink; + mk_no_insn_sched F._no_insn_sched; mk_nolabels F._nolabels; mk_nostdlib F._nostdlib; mk_nopervasives F._nopervasives; @@ -1323,6 +1346,8 @@ struct mk_remove_unused_arguments F._remove_unused_arguments; mk_rounds F._rounds; mk_runtime_variant F._runtime_variant; + mk_with_runtime F._with_runtime; + mk_without_runtime F._without_runtime; mk_S F._S; mk_safe_string F._safe_string; mk_shared F._shared; @@ -1536,3 +1561,46 @@ struct mk__ F.anonymous; ] end;; + +[@@@ocaml.warning "-40"] +let options_with_command_line_syntax_inner r after_rest = + let rec loop ~name_opt (spec : Arg.spec) : Arg.spec = + let option = + match name_opt with + | None -> ignore + | Some name -> (fun () -> r := name :: !r) + in + let arg a = r := Filename.quote a :: !r in + let option_with_arg a = option (); arg a in + let rest a = + if not !after_rest then (after_rest := true; option ()); + arg a + in + match spec with + | Unit f -> Unit (fun a -> f a; option ()) + | Bool f -> Bool (fun a -> f a; option_with_arg (string_of_bool a)) + | Set r -> Unit (fun () -> r := true; option ()) + | Clear r -> Unit (fun () -> r := false; option ()) + | String f -> String (fun a -> f a; option_with_arg a) + | Set_string r -> String (fun a -> r := a; option_with_arg a) + | Int f -> Int (fun a -> f a; option_with_arg (string_of_int a)) + | Set_int r -> Int (fun a -> r := a; option_with_arg (string_of_int a)) + | Float f -> Float (fun a -> f a; option_with_arg (string_of_float a)) + | Set_float r -> + Float (fun a -> r := a; option_with_arg (string_of_float a)) + | Tuple [] -> Unit option + | Tuple (hd :: tl) -> + Tuple (loop ~name_opt hd :: List.map (loop ~name_opt:None) tl) + | Symbol (l, f) -> Symbol (l, (fun a -> f a; option_with_arg a)) + | Rest f -> Rest (fun a -> f a; rest a) + | Expand f -> Expand f + in + loop + +let options_with_command_line_syntax options r = + let rest = ref false in + List.map (fun (name, spec, doc) -> + (name, + options_with_command_line_syntax_inner r rest + ~name_opt:(Some name) spec, doc) + ) options diff --git a/driver/main_args.mli b/driver/main_args.mli index 1dff86e7..64067b2c 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -96,6 +96,8 @@ module type Compiler_options = sig val _no_principal : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit + val _with_runtime : unit -> unit + val _without_runtime : unit -> unit val _safe_string : unit -> unit val _short_paths : unit -> unit val _thread : unit -> unit @@ -178,6 +180,8 @@ module type Optcommon_options = sig val _no_unbox_specialised_args : unit -> unit val _o2 : unit -> unit val _o3 : unit -> unit + val _insn_sched : unit -> unit + val _no_insn_sched : unit -> unit val _clambda_checks : unit -> unit val _dflambda : unit -> unit @@ -235,10 +239,6 @@ module type Ocamldoc_options = sig val _intf : string -> unit val _intf_suffix : string -> unit val _pp : string -> unit - val _principal : unit -> unit - val _rectypes : unit -> unit - val _safe_string : unit -> unit - val _short_paths : unit -> unit val _thread : unit -> unit val _v : unit -> unit val _verbose : unit -> unit @@ -254,3 +254,13 @@ module Make_bytetop_options (F : Bytetop_options) : Arg_list;; module Make_optcomp_options (F : Optcomp_options) : Arg_list;; module Make_opttop_options (F : Opttop_options) : Arg_list;; module Make_ocamldoc_options (F : Ocamldoc_options) : Arg_list;; + +(** [options_with_command_line_syntax options r] returns [options2] that behaves + like [options], but additionally pushes command line argument on [r] (quoted + by [Filename.quote] when necessary). + This is meant for ocaml{c,opt}p, which use this to forward most of their + arguments to ocaml{c,opt}. *) +val options_with_command_line_syntax + : (string * Arg.spec * string) list + -> string list ref + -> (string * Arg.spec * string) list diff --git a/driver/makedepend.ml b/driver/makedepend.ml index 655a2510..d9494056 100644 --- a/driver/makedepend.ml +++ b/driver/makedepend.ml @@ -28,7 +28,6 @@ let mli_synonyms = ref [".mli"] let shared = ref false let native_only = ref false let bytecode_only = ref false -let error_occurred = ref false let raw_dependencies = ref false let sort_files = ref false let all_dependencies = ref false @@ -40,6 +39,17 @@ let map_files = ref [] let module_map = ref String.Map.empty let debug = ref false +module Error_occurred : sig + val set : unit -> unit + val get : unit -> bool +end = struct + (* Once set to [true], [error_occurred] should never be set to + [false]. *) + let error_occurred = ref false + let get () = !error_occurred + let set () = error_occurred := true +end + (* Fix path to use '/' as directory separator instead of '\'. Only under Windows. *) @@ -60,7 +70,7 @@ let readdir dir = Sys.readdir dir with Sys_error msg -> Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg; - error_occurred := true; + Error_occurred.set (); [||] in dirs := String.Map.add dir contents !dirs; @@ -76,23 +86,30 @@ let add_to_load_path dir = add_to_list load_path (dir, contents) with Sys_error msg -> Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg; - error_occurred := true + Error_occurred.set () let add_to_synonym_list synonyms suffix = if (String.length suffix) > 1 && suffix.[0] = '.' then add_to_list synonyms suffix else begin Format.fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix; - error_occurred := true + Error_occurred.set () end (* Find file 'name' (capitalized) in search path *) -let find_file name = - let uname = String.uncapitalize_ascii name in +let find_module_in_load_path name = + let names = List.map (fun ext -> name ^ ext) (!mli_synonyms @ !ml_synonyms) in + let unames = + let uname = String.uncapitalize_ascii name in + List.map (fun ext -> uname ^ ext) (!mli_synonyms @ !ml_synonyms) + in let rec find_in_array a pos = if pos >= Array.length a then None else begin let s = a.(pos) in - if s = name || s = uname then Some s else find_in_array a (pos + 1) + if List.mem s names || List.mem s unames then + Some s + else + find_in_array a (pos + 1) end in let rec find_in_path = function [] -> raise Not_found @@ -103,58 +120,49 @@ let find_file name = | None -> find_in_path rem in find_in_path !load_path -let rec find_file_in_list = function - [] -> raise Not_found -| x :: rem -> try find_file x with Not_found -> find_file_in_list rem - - let find_dependency target_kind modname (byt_deps, opt_deps) = try - let candidates = List.map ((^) modname) !mli_synonyms in - let filename = find_file_in_list candidates in + let filename = find_module_in_load_path modname in let basename = Filename.chop_extension filename in let cmi_file = basename ^ ".cmi" in let cmx_file = basename ^ ".cmx" in + let mli_exists = + List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !mli_synonyms in let ml_exists = List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !ml_synonyms in - let new_opt_dep = - if !all_dependencies then - match target_kind with - | MLI -> [ cmi_file ] - | ML -> - cmi_file :: (if ml_exists then [ cmx_file ] else []) - else + if mli_exists then + let new_opt_dep = + if !all_dependencies then + match target_kind with + | MLI -> [ cmi_file ] + | ML -> + cmi_file :: (if ml_exists then [ cmx_file ] else []) + else (* this is a make-specific hack that makes .cmx to be a 'proxy' target that would force the dependency on .cmi via transitivity *) if ml_exists then [ cmx_file ] else [ cmi_file ] - in - ( cmi_file :: byt_deps, new_opt_dep @ opt_deps) - with Not_found -> - try - (* "just .ml" case *) - let candidates = List.map ((^) modname) !ml_synonyms in - let filename = find_file_in_list candidates in - let basename = Filename.chop_extension filename in - let cmi_file = basename ^ ".cmi" in - let cmx_file = basename ^ ".cmx" in - let bytenames = - if !all_dependencies then - match target_kind with - | MLI -> [ cmi_file ] - | ML -> [ cmi_file ] - else - (* again, make-specific hack *) - [basename ^ (if !native_only then ".cmx" else ".cmo")] in - let optnames = - if !all_dependencies - then match target_kind with - | MLI -> [ cmi_file ] - | ML -> [ cmi_file; cmx_file ] - else [ cmx_file ] - in - (bytenames @ byt_deps, optnames @ opt_deps) + in + ( cmi_file :: byt_deps, new_opt_dep @ opt_deps) + else + (* "just .ml" case *) + let bytenames = + if !all_dependencies then + match target_kind with + | MLI -> [ cmi_file ] + | ML -> [ cmi_file ] + else + (* again, make-specific hack *) + [basename ^ (if !native_only then ".cmx" else ".cmo")] in + let optnames = + if !all_dependencies + then match target_kind with + | MLI -> [ cmi_file ] + | ML -> [ cmi_file; cmx_file ] + else [ cmx_file ] + in + (bytenames @ byt_deps, optnames @ opt_deps) with Not_found -> (byt_deps, opt_deps) @@ -235,10 +243,13 @@ let print_raw_dependencies source_file deps = (* Process one file *) -let report_err exn = - error_occurred := true; +let print_exception exn = Location.report_exception Format.err_formatter exn +let report_err exn = + Error_occurred.set (); + print_exception exn + let tool_name = "ocamldep" let rec lexical_approximation lexbuf = @@ -273,7 +284,6 @@ let rec lexical_approximation lexbuf = with Lexer.Error _ -> lexical_approximation lexbuf let read_and_approximate inputfile = - error_occurred := false; Depend.free_structure_names := String.Set.empty; let ic = open_in_bin inputfile in try @@ -311,10 +321,12 @@ let read_parse_and_extract parse_function extract_function def ast_kind raise x end with x -> begin - report_err x; - if not !allow_approximation - then (String.Set.empty, def) - else (read_and_approximate source_file, def) + print_exception x; + if not !allow_approximation then begin + Error_occurred.set (); + (String.Set.empty, def) + end else + (read_and_approximate source_file, def) end let print_ml_dependencies source_file extracted_deps pp_deps = @@ -490,7 +502,7 @@ let sort_files_by_dependencies files = ) !deps; Format.fprintf Format.err_formatter "@]@."; Printf.printf "%s " file) sorted_deps; - error_occurred := true + Error_occurred.set () end; Printf.printf "\n%!"; () @@ -594,8 +606,8 @@ let main () = " Output one line per file, regardless of the length"; "-open", Arg.String (add_to_list Clflags.open_modules), " Opens the module before typing"; - "-plugin", Arg.String Compplugin.load, - " Load dynamic plugin "; + "-plugin", Arg.String(fun _p -> Clflags.plugin := true), + " (no longer supported)"; "-pp", Arg.String(fun s -> Clflags.preprocessor := Some s), " Pipe sources through preprocessor "; "-ppx", Arg.String (add_to_list first_ppx), @@ -625,7 +637,7 @@ let main () = Compenv.readenv ppf Before_link; if !sort_files then sort_files_by_dependencies !files else List.iter print_file_dependencies (List.sort compare !files); - exit (if !error_occurred then 2 else 0) + exit (if Error_occurred.get () then 2 else 0) let main_from_option () = if Sys.argv.(1) <> "-depend" then begin diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 85c655e9..0af391cc 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -46,10 +46,10 @@ let flambda i backend typed = required_globals; code } -> ((module_ident, main_module_block_size), code) |>> print_if i.ppf_dump Clflags.dump_rawlambda Printlambda.lambda - |>> Simplif.simplify_lambda i.source_file + |>> 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) @@ -69,11 +69,11 @@ let clambda i typed = |> print_if i.ppf_dump Clflags.dump_rawlambda Printlambda.program |> Profile.(record generate) (fun program -> - let code = Simplif.simplify_lambda i.source_file program.Lambda.code in + let code = Simplif.simplify_lambda program.Lambda.code in { 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 diff --git a/driver/optcompile.mli b/driver/optcompile.mli index 27cd1e0d..9a23b8b2 100644 --- a/driver/optcompile.mli +++ b/driver/optcompile.mli @@ -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. diff --git a/driver/optmain.ml b/driver/optmain.ml index b6881571..59e531e4 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -118,8 +118,9 @@ module Options = Main_args.Make_optcomp_options (struct Float_arg_helper.parse spec "Syntax: -inline-branch-factor | =[,...]" inline_branch_factor - let _intf = intf let _intf_suffix s = Config.interface_suffix := s + let _insn_sched = set insn_sched + let _intf = intf let _keep_docs = set keep_docs let _no_keep_docs = clear keep_docs let _keep_locs = set keep_locs @@ -139,6 +140,7 @@ module Options = Main_args.Make_optcomp_options (struct let _noassert = set noassert let _noautolink = set no_auto_link let _nodynlink = clear dlcode + let _no_insn_sched = clear insn_sched let _nolabels = set classic let _nostdlib = set no_std_include let _no_unbox_free_vars_of_closures = clear unbox_free_vars_of_closures @@ -166,9 +168,11 @@ module Options = Main_args.Make_optcomp_options (struct let _output_obj = set output_c_object let _output_complete_obj () = set output_c_object (); set output_complete_object () - let _p = set gprofile + let _p () = + fatal "Profiling with \"gprof\" (option `-p') is only supported up \ + to OCaml 4.08.0" let _pack = set make_package - let _plugin p = Compplugin.load p + let _plugin _p = plugin := true let _pp s = preprocessor := Some s let _ppx s = first_ppx := s :: !first_ppx let _principal = set principal @@ -177,6 +181,8 @@ module Options = Main_args.Make_optcomp_options (struct let _no_rectypes = clear recursive_types let _remove_unused_arguments = set remove_unused_arguments let _runtime_variant s = runtime_variant := s + let _with_runtime = set with_runtime + let _without_runtime = clear with_runtime let _safe_string = clear unsafe_string let _short_paths = clear real_paths let _strict_sequence = set strict_sequence @@ -261,8 +267,8 @@ let main () = (use 'ocamlopt -depend -help' for details)"]; Clflags.parse_arguments anonymous usage; Compmisc.read_clflags_from_env (); - if !gprofile && not Config.profiling then - fatal "Profiling with \"gprof\" is not supported on this platform."; + if !Clflags.plugin then + fatal "-plugin is only supported up to OCaml 4.08.0"; begin try Compenv.process_deferred_actions (ppf, @@ -286,14 +292,14 @@ let main () = fatal "Please specify at most one of -pack, -a, -shared, -c, \ -output-obj"; if !make_archive then begin - Compmisc.init_path true; + Compmisc.init_path (); let target = extract_output !output_name in Asmlibrarian.create_archive (get_objfiles ~with_ocamlparam:false) target; Warnings.check_fatal (); end else if !make_package then begin - Compmisc.init_path true; + Compmisc.init_path (); let target = extract_output !output_name in Compmisc.with_ppf_dump ~file_prefix:target (fun ppf_dump -> Asmpackager.package_files ~ppf_dump (Compmisc.initial_env ()) @@ -301,7 +307,7 @@ let main () = Warnings.check_fatal (); end else if !shared then begin - Compmisc.init_path true; + Compmisc.init_path (); let target = extract_output !output_name in Compmisc.with_ppf_dump ~file_prefix:target (fun ppf_dump -> Asmlink.link_shared ~ppf_dump @@ -324,7 +330,7 @@ let main () = else default_output !output_name in - Compmisc.init_path true; + Compmisc.init_path (); Compmisc.with_ppf_dump ~file_prefix:target (fun ppf_dump -> Asmlink.link ~ppf_dump (get_objfiles ~with_ocamlparam:true) target); Warnings.check_fatal (); diff --git a/driver/pparse.ml b/driver/pparse.ml index 0b08b8c8..a5e98c0a 100644 --- a/driver/pparse.ml +++ b/driver/pparse.ml @@ -221,19 +221,10 @@ let parse_file ~tool_name invariant_fun parse kind sourcefile = file_aux ~tool_name inputfile parse invariant_fun kind) ~always:(fun () -> remove_preprocessed inputfile) -module ImplementationHooks = Misc.MakeHooks(struct - type t = Parsetree.structure - end) -module InterfaceHooks = Misc.MakeHooks(struct - type t = Parsetree.signature - end) - let parse_implementation ~tool_name sourcefile = parse_file ~tool_name Ast_invariants.structure (parse Structure) Structure sourcefile - |> ImplementationHooks.apply_hooks { Misc.sourcefile } let parse_interface ~tool_name sourcefile = parse_file ~tool_name Ast_invariants.signature (parse Signature) Signature sourcefile - |> InterfaceHooks.apply_hooks { Misc.sourcefile } diff --git a/driver/pparse.mli b/driver/pparse.mli index 73eff187..40b77a8b 100644 --- a/driver/pparse.mli +++ b/driver/pparse.mli @@ -13,7 +13,7 @@ (* *) (**************************************************************************) -(** Driver for the parser, external preprocessors and ast plugin hooks +(** Driver for the parser and external preprocessors. {b Warning:} this module is unstable and part of {{!Compiler_libs}compiler-libs}. @@ -64,6 +64,3 @@ val parse_interface: (* [call_external_preprocessor sourcefile pp] *) val call_external_preprocessor : string -> string -> string val open_and_check_magic : string -> string -> in_channel * bool - -module ImplementationHooks : Misc.HookSig with type t = Parsetree.structure -module InterfaceHooks : Misc.HookSig with type t = Parsetree.signature diff --git a/dune b/dune index a528f184..27824047 100644 --- a/dune +++ b/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 @@ -51,26 +55,30 @@ asttypes parsetree ;; TYPING - ident path primitive types btype oprint subst predef datarepr cmi_format env + ident path primitive types btype oprint subst predef datarepr + cmi_format persistent_env env typedtree printtyped ctype printtyp includeclass mtype envaux includecore - typedtreeIter tast_mapper cmt_format untypeast includemod + tast_iterator tast_mapper cmt_format untypeast includemod typetexp printpat parmatch stypes typedecl typeopt rec_check typecore typeclass typemod typedecl_variance typedecl_properties typedecl_immediacy typedecl_unboxed ; 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 compdynlink_types compdynlink_platform_intf compdynlink_common - compdynlink compplugin makedepend compile_common + ;; 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) @@ -78,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 ocamloptcomp) + (name ocamlmiddleend) (wrapped false) (flags (:standard -principal -nostdlib)) (libraries stdlib ocamlcommon) (modules_without_implementation - cmx_format x86_ast backend_intf inlining_decision_intf + cmx_format cmxs_format backend_intf inlining_decision_intf simplify_boxed_integer_ops_intf) (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 - 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 - cmx_format - - ; 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 - - ;; 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 - ; manual update: mli only files - backend_intf inlining_decision_intf simplify_boxed_integer_ops_intf + ;; 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 ocamlmiddleend) + (modules_without_implementation x86_ast) + (modules + ;; 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 + + ;; asmcomp/debug/ + reg_availability_set compute_ranges_intf available_regs reg_with_debug_info + compute_ranges + + ;; driver/ + optcompile opterrors ) ) @@ -155,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 @@ -165,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 diff --git a/file_formats/cmi_format.ml b/file_formats/cmi_format.ml new file mode 100644 index 00000000..a98520a8 --- /dev/null +++ b/file_formats/cmi_format.ml @@ -0,0 +1,111 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Misc + +type pers_flags = + | Rectypes + | Alerts of alerts + | Opaque + | Unsafe_string + +type error = + | Not_an_interface of filepath + | Wrong_version_interface of filepath * string + | Corrupted_interface of filepath + +exception Error of error + +type cmi_infos = { + cmi_name : Misc.modname; + cmi_sign : Types.signature_item list; + cmi_crcs : crcs; + cmi_flags : pers_flags list; +} + +let input_cmi ic = + let (name, sign) = input_value ic in + let crcs = input_value ic in + let flags = input_value ic in + { + cmi_name = name; + cmi_sign = sign; + cmi_crcs = crcs; + cmi_flags = flags; + } + +let read_cmi filename = + let ic = open_in_bin filename in + try + let buffer = + really_input_string ic (String.length Config.cmi_magic_number) + in + if buffer <> Config.cmi_magic_number then begin + close_in ic; + let pre_len = String.length Config.cmi_magic_number - 3 in + if String.sub buffer 0 pre_len + = String.sub Config.cmi_magic_number 0 pre_len then + begin + let msg = + if buffer < Config.cmi_magic_number then "an older" else "a newer" in + raise (Error (Wrong_version_interface (filename, msg))) + end else begin + raise(Error(Not_an_interface filename)) + end + end; + let cmi = input_cmi ic in + close_in ic; + cmi + with End_of_file | Failure _ -> + close_in ic; + raise(Error(Corrupted_interface(filename))) + | Error e -> + close_in ic; + raise (Error e) + +let output_cmi filename oc cmi = +(* beware: the provided signature must have been substituted for saving *) + output_string oc Config.cmi_magic_number; + output_value oc (cmi.cmi_name, cmi.cmi_sign); + flush oc; + let crc = Digest.file filename in + let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in + output_value oc crcs; + output_value oc cmi.cmi_flags; + crc + +(* Error report *) + +open Format + +let report_error ppf = function + | Not_an_interface filename -> + fprintf ppf "%a@ is not a compiled interface" + Location.print_filename filename + | Wrong_version_interface (filename, older_newer) -> + fprintf ppf + "%a@ is not a compiled interface for this version of OCaml.@.\ + It seems to be for %s version of OCaml." + Location.print_filename filename older_newer + | Corrupted_interface filename -> + fprintf ppf "Corrupted compiled interface@ %a" + Location.print_filename filename + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/file_formats/cmi_format.mli b/file_formats/cmi_format.mli new file mode 100644 index 00000000..d4d665fd --- /dev/null +++ b/file_formats/cmi_format.mli @@ -0,0 +1,51 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Misc + +type pers_flags = + | Rectypes + | Alerts of alerts + | Opaque + | Unsafe_string + +type cmi_infos = { + cmi_name : modname; + cmi_sign : Types.signature_item list; + cmi_crcs : crcs; + cmi_flags : pers_flags list; +} + +(* write the magic + the cmi information *) +val output_cmi : string -> out_channel -> cmi_infos -> Digest.t + +(* read the cmi information (the magic is supposed to have already been read) *) +val input_cmi : in_channel -> cmi_infos + +(* read a cmi from a filename, checking the magic *) +val read_cmi : string -> cmi_infos + +(* Error report *) + +type error = + | Not_an_interface of filepath + | Wrong_version_interface of filepath * string + | Corrupted_interface of filepath + +exception Error of error + +open Format + +val report_error: formatter -> error -> unit diff --git a/file_formats/cmo_format.mli b/file_formats/cmo_format.mli new file mode 100644 index 00000000..d953a881 --- /dev/null +++ b/file_formats/cmo_format.mli @@ -0,0 +1,66 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Symbol table information for .cmo and .cma files *) + +open Misc + +(* Relocation information *) + +type reloc_info = + Reloc_literal of Lambda.structured_constant (* structured constant *) + | Reloc_getglobal of Ident.t (* reference to a global *) + | Reloc_setglobal of Ident.t (* definition of a global *) + | Reloc_primitive of string (* C primitive number *) + +(* Descriptor for compilation units *) + +type compilation_unit = + { cu_name: modname; (* Name of compilation unit *) + mutable cu_pos: int; (* Absolute position in file *) + cu_codesize: int; (* Size of code block *) + cu_reloc: (reloc_info * int) list; (* Relocation information *) + cu_imports: crcs; (* Names and CRC of intfs imported *) + cu_required_globals: Ident.t list; (* Compilation units whose + initialization side effects + must occur before this one. *) + cu_primitives: string list; (* Primitives declared inside *) + mutable cu_force_link: bool; (* Must be linked even if unref'ed *) + mutable cu_debug: int; (* Position of debugging info, or 0 *) + cu_debugsize: int } (* Length of debugging info *) + +(* Format of a .cmo file: + magic number (Config.cmo_magic_number) + absolute offset of compilation unit descriptor + block of relocatable bytecode + debugging information if any + compilation unit descriptor *) + +(* Descriptor for libraries *) + +type library = + { lib_units: compilation_unit list; (* List of compilation units *) + lib_custom: bool; (* Requires custom mode linking? *) + lib_ccobjs: string list; (* C object files needed for -custom *) + lib_ccopts: string list; (* Extra opts to C compiler *) + lib_dllibs: string list } (* DLLs needed *) + +(* Format of a .cma file: + magic number (Config.cma_magic_number) + absolute offset of library descriptor + object code for first library member + ... + object code for last library member + library descriptor *) diff --git a/file_formats/cmt_format.ml b/file_formats/cmt_format.ml new file mode 100644 index 00000000..09c787d9 --- /dev/null +++ b/file_formats/cmt_format.ml @@ -0,0 +1,194 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Cmi_format +open Typedtree + +(* Note that in Typerex, there is an awful hack to save a cmt file + together with the interface file that was generated by ocaml (this + is because the installed version of ocaml might differ from the one + integrated in Typerex). +*) + + + +let read_magic_number ic = + let len_magic_number = String.length Config.cmt_magic_number in + really_input_string ic len_magic_number + +type binary_annots = + | Packed of Types.signature * string list + | Implementation of structure + | Interface of signature + | Partial_implementation of binary_part array + | Partial_interface of binary_part array + +and binary_part = +| Partial_structure of structure +| Partial_structure_item of structure_item +| Partial_expression of expression +| Partial_pattern of pattern +| Partial_class_expr of class_expr +| Partial_signature of signature +| Partial_signature_item of signature_item +| Partial_module_type of module_type + +type cmt_infos = { + cmt_modname : string; + cmt_annots : binary_annots; + cmt_value_dependencies : + (Types.value_description * Types.value_description) list; + cmt_comments : (string * Location.t) list; + cmt_args : string array; + cmt_sourcefile : string option; + cmt_builddir : string; + cmt_loadpath : string list; + cmt_source_digest : Digest.t option; + cmt_initial_env : Env.t; + cmt_imports : (string * Digest.t option) list; + cmt_interface_digest : Digest.t option; + cmt_use_summaries : bool; +} + +type error = + Not_a_typedtree of string + +let need_to_clear_env = + try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false + with Not_found -> true + +let keep_only_summary = Env.keep_only_summary + +open Tast_mapper + +let cenv = + {Tast_mapper.default with env = fun _sub env -> keep_only_summary env} + +let clear_part = function + | Partial_structure s -> Partial_structure (cenv.structure cenv s) + | Partial_structure_item s -> + Partial_structure_item (cenv.structure_item cenv s) + | Partial_expression e -> Partial_expression (cenv.expr cenv e) + | Partial_pattern p -> Partial_pattern (cenv.pat cenv p) + | Partial_class_expr ce -> Partial_class_expr (cenv.class_expr cenv ce) + | Partial_signature s -> Partial_signature (cenv.signature cenv s) + | Partial_signature_item s -> + Partial_signature_item (cenv.signature_item cenv s) + | Partial_module_type s -> Partial_module_type (cenv.module_type cenv s) + +let clear_env binary_annots = + if need_to_clear_env then + match binary_annots with + | Implementation s -> Implementation (cenv.structure cenv s) + | Interface s -> Interface (cenv.signature cenv s) + | Packed _ -> binary_annots + | Partial_implementation array -> + Partial_implementation (Array.map clear_part array) + | Partial_interface array -> + Partial_interface (Array.map clear_part array) + + else binary_annots + +exception Error of error + +let input_cmt ic = (input_value ic : cmt_infos) + +let output_cmt oc cmt = + output_string oc Config.cmt_magic_number; + output_value oc (cmt : cmt_infos) + +let read filename = +(* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *) + let ic = open_in_bin filename in + Misc.try_finally + ~always:(fun () -> close_in ic) + (fun () -> + let magic_number = read_magic_number ic in + let cmi, cmt = + if magic_number = Config.cmt_magic_number then + None, Some (input_cmt ic) + else if magic_number = Config.cmi_magic_number then + let cmi = Cmi_format.input_cmi ic in + let cmt = try + let magic_number = read_magic_number ic in + if magic_number = Config.cmt_magic_number then + let cmt = input_cmt ic in + Some cmt + else None + with _ -> None + in + Some cmi, cmt + else + raise(Cmi_format.Error(Cmi_format.Not_an_interface filename)) + in + cmi, cmt + ) + +let read_cmt filename = + match read filename with + _, None -> raise (Error (Not_a_typedtree filename)) + | _, Some cmt -> cmt + +let read_cmi filename = + match read filename with + None, _ -> + raise (Cmi_format.Error (Cmi_format.Not_an_interface filename)) + | Some cmi, _ -> cmi + +let saved_types = ref [] +let value_deps = ref [] + +let clear () = + saved_types := []; + value_deps := [] + +let add_saved_type b = saved_types := b :: !saved_types +let get_saved_types () = !saved_types +let set_saved_types l = saved_types := l + +let record_value_dependency vd1 vd2 = + if vd1.Types.val_loc <> vd2.Types.val_loc then + value_deps := (vd1, vd2) :: !value_deps + +let save_cmt filename modname binary_annots sourcefile initial_env cmi = + if !Clflags.binary_annotations && not !Clflags.print_types then begin + Misc.output_to_file_via_temporary + ~mode:[Open_binary] filename + (fun temp_file_name oc -> + let this_crc = + match cmi with + | None -> None + | Some cmi -> Some (output_cmi temp_file_name oc cmi) + in + let source_digest = Misc.may_map Digest.file sourcefile in + let cmt = { + cmt_modname = modname; + cmt_annots = clear_env binary_annots; + cmt_value_dependencies = !value_deps; + cmt_comments = Lexer.comments (); + cmt_args = Sys.argv; + cmt_sourcefile = sourcefile; + cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ()); + cmt_loadpath = Load_path.get_paths (); + cmt_source_digest = source_digest; + cmt_initial_env = if need_to_clear_env then + keep_only_summary initial_env else initial_env; + cmt_imports = List.sort compare (Env.imports ()); + cmt_interface_digest = this_crc; + cmt_use_summaries = need_to_clear_env; + } in + output_cmt oc cmt) + end; + clear () diff --git a/file_formats/cmt_format.mli b/file_formats/cmt_format.mli new file mode 100644 index 00000000..7649de7b --- /dev/null +++ b/file_formats/cmt_format.mli @@ -0,0 +1,123 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** cmt and cmti files format. *) + +open Misc + +(** The layout of a cmt file is as follows: + := \{\} \{cmt infos\} \{\} + where is the cmi file format: + := . + More precisely, the optional part must be present if and only if + the file is: + - a cmti, or + - a cmt, for a ml file which has no corresponding mli (hence no + corresponding cmti). + + Thus, we provide a common reading function for cmi and cmt(i) + files which returns an option for each of the three parts: cmi + info, cmt info, source info. *) + +open Typedtree + +type binary_annots = + | Packed of Types.signature * string list + | Implementation of structure + | Interface of signature + | Partial_implementation of binary_part array + | Partial_interface of binary_part array + +and binary_part = + | Partial_structure of structure + | Partial_structure_item of structure_item + | Partial_expression of expression + | Partial_pattern of pattern + | Partial_class_expr of class_expr + | Partial_signature of signature + | Partial_signature_item of signature_item + | Partial_module_type of module_type + +type cmt_infos = { + cmt_modname : modname; + cmt_annots : binary_annots; + cmt_value_dependencies : + (Types.value_description * Types.value_description) list; + cmt_comments : (string * Location.t) list; + cmt_args : string array; + cmt_sourcefile : string option; + cmt_builddir : string; + cmt_loadpath : string list; + cmt_source_digest : string option; + cmt_initial_env : Env.t; + cmt_imports : crcs; + cmt_interface_digest : Digest.t option; + cmt_use_summaries : bool; +} + +type error = + Not_a_typedtree of string + +exception Error of error + +(** [read filename] opens filename, and extract both the cmi_infos, if + it exists, and the cmt_infos, if it exists. Thus, it can be used + with .cmi, .cmt and .cmti files. + + .cmti files always contain a cmi_infos at the beginning. .cmt files + only contain a cmi_infos at the beginning if there is no associated + .cmti file. +*) +val read : string -> Cmi_format.cmi_infos option * cmt_infos option + +val read_cmt : string -> cmt_infos +val read_cmi : string -> Cmi_format.cmi_infos + +(** [save_cmt filename modname binary_annots sourcefile initial_env cmi] + writes a cmt(i) file. *) +val save_cmt : + string -> (* filename.cmt to generate *) + string -> (* module name *) + binary_annots -> + string option -> (* source file *) + Env.t -> (* initial env *) + Cmi_format.cmi_infos option -> (* if a .cmi was generated *) + unit + +(* Miscellaneous functions *) + +val read_magic_number : in_channel -> string + +val clear: unit -> unit + +val add_saved_type : binary_part -> unit +val get_saved_types : unit -> binary_part list +val set_saved_types : binary_part list -> unit + +val record_value_dependency: + Types.value_description -> Types.value_description -> unit + + +(* + + val is_magic_number : string -> bool + val read : in_channel -> Env.cmi_infos option * t + val write_magic_number : out_channel -> unit + val write : out_channel -> t -> unit + + val find : string list -> string -> string + val read_signature : 'a -> string -> Types.signature * 'b list * 'c list + +*) diff --git a/file_formats/cmx_format.mli b/file_formats/cmx_format.mli new file mode 100644 index 00000000..0efa32ee --- /dev/null +++ b/file_formats/cmx_format.mli @@ -0,0 +1,56 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2010 Institut National de Recherche en Informatique et *) +(* en Automatique *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Format of .cmx, .cmxa and .cmxs files *) + +open Misc + +(* Each .o file has a matching .cmx file that provides the following infos + on the compilation unit: + - list of other units imported, with MD5s of their .cmx files + - approximation of the structure implemented + (includes descriptions of known functions: arity and direct entry + points) + - list of currying functions and application functions needed + The .cmx file contains these infos (as an externed record) plus a MD5 + of these infos *) + +type export_info = + | Clambda of Clambda.value_approximation + | Flambda of Export_info.t + +type unit_infos = + { mutable ui_name: modname; (* Name of unit implemented *) + mutable ui_symbol: string; (* Prefix for symbols *) + mutable ui_defines: string list; (* Unit and sub-units implemented *) + mutable ui_imports_cmi: crcs; (* Interfaces imported *) + mutable ui_imports_cmx: crcs; (* Infos imported *) + mutable ui_curry_fun: int list; (* Currying functions needed *) + mutable ui_apply_fun: int list; (* Apply functions needed *) + mutable ui_send_fun: int list; (* Send functions needed *) + mutable ui_export_info: export_info; + mutable ui_force_link: bool } (* Always linked *) + +(* Each .a library has a matching .cmxa file that provides the following + infos on the library: *) + +type library_infos = + { lib_units: (unit_infos * Digest.t) list; (* List of unit infos w/ MD5s *) + lib_ccobjs: string list; (* C object files needed *) + lib_ccopts: string list } (* Extra opts to C compiler *) diff --git a/file_formats/cmxs_format.mli b/file_formats/cmxs_format.mli new file mode 100644 index 00000000..c670024f --- /dev/null +++ b/file_formats/cmxs_format.mli @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2010 Institut National de Recherche en Informatique et *) +(* en Automatique *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Format of .cmxs files *) + +open Misc + +(* Each .cmxs dynamically-loaded plugin contains a symbol + "caml_plugin_header" containing the following info + (as an externed record) *) + +type dynunit = { + dynu_name: modname; + dynu_crc: Digest.t; + dynu_imports_cmi: crcs; + dynu_imports_cmx: crcs; + dynu_defines: string list; +} + +type dynheader = { + dynu_magic: string; + dynu_units: dynunit list; +} diff --git a/lambda/debuginfo.ml b/lambda/debuginfo.ml new file mode 100644 index 00000000..7a339022 --- /dev/null +++ b/lambda/debuginfo.ml @@ -0,0 +1,145 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open! Int_replace_polymorphic_compare +open Lexing +open Location + +type item = { + dinfo_file: string; + dinfo_line: int; + dinfo_char_start: int; + dinfo_char_end: int; + dinfo_start_bol: int; + dinfo_end_bol: int; + dinfo_end_line: int; +} + +type t = item list + +let none = [] + +let is_none = function + | [] -> true + | _ :: _ -> false + +let to_string dbg = + match dbg with + | [] -> "" + | ds -> + let items = + List.map + (fun d -> + Printf.sprintf "%s:%d,%d-%d" + d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end) + ds + in + "{" ^ String.concat ";" items ^ "}" + +let item_from_location loc = + let valid_endpos = + String.equal loc.loc_end.pos_fname loc.loc_start.pos_fname in + { dinfo_file = loc.loc_start.pos_fname; + dinfo_line = loc.loc_start.pos_lnum; + dinfo_char_start = loc.loc_start.pos_cnum - loc.loc_start.pos_bol; + dinfo_char_end = + if valid_endpos + then loc.loc_end.pos_cnum - loc.loc_start.pos_bol + else loc.loc_start.pos_cnum - loc.loc_start.pos_bol; + dinfo_start_bol = loc.loc_start.pos_bol; + dinfo_end_bol = + if valid_endpos then loc.loc_end.pos_bol + else loc.loc_start.pos_bol; + dinfo_end_line = + if valid_endpos then loc.loc_end.pos_lnum + else loc.loc_start.pos_lnum; + } + +let from_location loc = + if loc == Location.none then [] else [item_from_location loc] + +let to_location = function + | [] -> Location.none + | d :: _ -> + let loc_start = + { pos_fname = d.dinfo_file; + pos_lnum = d.dinfo_line; + pos_bol = d.dinfo_start_bol; + pos_cnum = d.dinfo_start_bol + d.dinfo_char_start; + } in + let loc_end = + { pos_fname = d.dinfo_file; + pos_lnum = d.dinfo_end_line; + pos_bol = d.dinfo_end_bol; + pos_cnum = d.dinfo_start_bol + d.dinfo_char_end; + } in + { loc_ghost = false; loc_start; loc_end; } + +let inline loc t = + if loc == Location.none then t + else (item_from_location loc) :: t + +let concat dbg1 dbg2 = + dbg1 @ dbg2 + +(* CR-someday afrisch: FWIW, the current compare function does not seem very + good, since it reverses the two lists. I don't know how long the lists are, + nor if the specific currently implemented ordering is useful in other + contexts, but if one wants to use Map, a more efficient comparison should + be considered. *) +let compare dbg1 dbg2 = + let rec loop ds1 ds2 = + match ds1, ds2 with + | [], [] -> 0 + | _ :: _, [] -> 1 + | [], _ :: _ -> -1 + | d1 :: ds1, d2 :: ds2 -> + let c = String.compare d1.dinfo_file d2.dinfo_file in + if c <> 0 then c else + let c = compare d1.dinfo_line d2.dinfo_line in + if c <> 0 then c else + let c = compare d1.dinfo_char_end d2.dinfo_char_end in + if c <> 0 then c else + let c = compare d1.dinfo_char_start d2.dinfo_char_start in + if c <> 0 then c else + let c = compare d1.dinfo_start_bol d2.dinfo_start_bol in + if c <> 0 then c else + let c = compare d1.dinfo_end_bol d2.dinfo_end_bol in + if c <> 0 then c else + let c = compare d1.dinfo_end_line d2.dinfo_end_line in + if c <> 0 then c else + loop ds1 ds2 + in + loop (List.rev dbg1) (List.rev dbg2) + +let hash t = + List.fold_left (fun hash item -> Hashtbl.hash (hash, item)) 0 t + +let rec print_compact ppf t = + let print_item item = + Format.fprintf ppf "%a:%i" + Location.print_filename item.dinfo_file + item.dinfo_line; + if item.dinfo_char_start >= 0 then begin + Format.fprintf ppf ",%i--%i" item.dinfo_char_start item.dinfo_char_end + end + in + match t with + | [] -> () + | [item] -> print_item item + | item::t -> + print_item item; + Format.fprintf ppf ";"; + print_compact ppf t diff --git a/lambda/debuginfo.mli b/lambda/debuginfo.mli new file mode 100644 index 00000000..4dc5e599 --- /dev/null +++ b/lambda/debuginfo.mli @@ -0,0 +1,46 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type item = private { + dinfo_file: string; + dinfo_line: int; + dinfo_char_start: int; + dinfo_char_end: int; + dinfo_start_bol: int; + dinfo_end_bol: int; + dinfo_end_line: int; +} + +type t = item list + +val none : t + +val is_none : t -> bool + +val to_string : t -> string + +val from_location : Location.t -> t + +val to_location : t -> Location.t + +val concat: t -> t -> t + +val inline: Location.t -> t -> t + +val compare : t -> t -> int + +val hash : t -> int + +val print_compact : Format.formatter -> t -> unit diff --git a/lambda/dune b/lambda/dune new file mode 100644 index 00000000..034cdc3b --- /dev/null +++ b/lambda/dune @@ -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})))) diff --git a/lambda/generate_runtimedef.sh b/lambda/generate_runtimedef.sh new file mode 100755 index 00000000..66ccf3ce --- /dev/null +++ b/lambda/generate_runtimedef.sh @@ -0,0 +1,25 @@ +#!/bin/sh + +#************************************************************************** +#* * +#* OCaml * +#* * +#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * +#* * +#* Copyright 1999 Institut National de Recherche en Informatique et * +#* en Automatique. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +echo 'let builtin_exceptions = [|' +cat "$1" | tr -d '\r' | \ + sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$| \1;|p' +echo '|]' + +echo 'let builtin_primitives = [|' +sed -e 's/.*/ "&";/' "$2" +echo '|]' diff --git a/lambda/lambda.ml b/lambda/lambda.ml new file mode 100644 index 00000000..ebdd49a3 --- /dev/null +++ b/lambda/lambda.ml @@ -0,0 +1,891 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Misc +open Asttypes + +type compile_time_constant = + | Big_endian + | Word_size + | Int_size + | Max_wosize + | Ostype_unix + | Ostype_win32 + | Ostype_cygwin + | Backend_type + +type immediate_or_pointer = + | Immediate + | Pointer + +type initialization_or_assignment = + | Assignment + | Heap_initialization + | Root_initialization + +type is_safe = + | Safe + | Unsafe + +type primitive = + | Pidentity + | Pbytes_to_string + | Pbytes_of_string + | Pignore + | Prevapply + | Pdirapply + (* Globals *) + | Pgetglobal of Ident.t + | Psetglobal of Ident.t + (* Operations on heap blocks *) + | Pmakeblock of int * mutable_flag * block_shape + | Pfield of int + | Pfield_computed + | Psetfield of int * immediate_or_pointer * initialization_or_assignment + | Psetfield_computed of immediate_or_pointer * initialization_or_assignment + | Pfloatfield of int + | Psetfloatfield of int * initialization_or_assignment + | Pduprecord of Types.record_representation * int + (* Force lazy values *) + (* External call *) + | Pccall of Primitive.description + (* Exceptions *) + | Praise of raise_kind + (* Boolean operations *) + | Psequand | Psequor | Pnot + (* Integer operations *) + | Pnegint | Paddint | Psubint | Pmulint + | Pdivint of is_safe | Pmodint of is_safe + | Pandint | Porint | Pxorint + | Plslint | Plsrint | Pasrint + | Pintcomp of integer_comparison + | Poffsetint of int + | Poffsetref of int + (* Float operations *) + | Pintoffloat | Pfloatofint + | Pnegfloat | Pabsfloat + | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat + | Pfloatcomp of float_comparison + (* String operations *) + | Pstringlength | Pstringrefu | Pstringrefs + | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets + (* Array operations *) + | Pmakearray of array_kind * mutable_flag + | Pduparray of array_kind * mutable_flag + | Parraylength of array_kind + | Parrayrefu of array_kind + | Parraysetu of array_kind + | Parrayrefs of array_kind + | Parraysets of array_kind + (* Test if the argument is a block or an immediate integer *) + | Pisint + (* Test if the (integer) argument is outside an interval *) + | Pisout + (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *) + | Pbintofint of boxed_integer + | Pintofbint of boxed_integer + | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*) + | Pnegbint of boxed_integer + | Paddbint of boxed_integer + | Psubbint of boxed_integer + | Pmulbint of boxed_integer + | Pdivbint of { size : boxed_integer; is_safe : is_safe } + | Pmodbint of { size : boxed_integer; is_safe : is_safe } + | Pandbint of boxed_integer + | Porbint of boxed_integer + | Pxorbint of boxed_integer + | Plslbint of boxed_integer + | Plsrbint of boxed_integer + | Pasrbint of boxed_integer + | Pbintcomp of boxed_integer * integer_comparison + (* Operations on Bigarrays: (unsafe, #dimensions, kind, layout) *) + | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout + | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout + (* size of the nth dimension of a Bigarray *) + | Pbigarraydim of int + (* load/set 16,32,64 bits from a string: (unsafe)*) + | Pstring_load_16 of bool + | Pstring_load_32 of bool + | Pstring_load_64 of bool + | Pbytes_load_16 of bool + | Pbytes_load_32 of bool + | Pbytes_load_64 of bool + | Pbytes_set_16 of bool + | Pbytes_set_32 of bool + | Pbytes_set_64 of bool + (* load/set 16,32,64 bits from a + (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *) + | Pbigstring_load_16 of bool + | Pbigstring_load_32 of bool + | Pbigstring_load_64 of bool + | Pbigstring_set_16 of bool + | Pbigstring_set_32 of bool + | Pbigstring_set_64 of bool + (* Compile time constants *) + | Pctconst of compile_time_constant + (* byte swap *) + | Pbswap16 + | Pbbswap of boxed_integer + (* Integer to external pointer *) + | Pint_as_pointer + (* Inhibition of optimisation *) + | Popaque + +and integer_comparison = + Ceq | Cne | Clt | Cgt | Cle | Cge + +and float_comparison = + CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge + +and value_kind = + Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval + +and block_shape = + value_kind list option + +and array_kind = + Pgenarray | Paddrarray | Pintarray | Pfloatarray + +and boxed_integer = Primitive.boxed_integer = + Pnativeint | Pint32 | Pint64 + +and bigarray_kind = + Pbigarray_unknown + | Pbigarray_float32 | Pbigarray_float64 + | Pbigarray_sint8 | Pbigarray_uint8 + | Pbigarray_sint16 | Pbigarray_uint16 + | Pbigarray_int32 | Pbigarray_int64 + | Pbigarray_caml_int | Pbigarray_native_int + | Pbigarray_complex32 | Pbigarray_complex64 + +and bigarray_layout = + Pbigarray_unknown_layout + | Pbigarray_c_layout + | Pbigarray_fortran_layout + +and raise_kind = + | Raise_regular + | Raise_reraise + | Raise_notrace + +let equal_boxed_integer x y = + match x, y with + | Pnativeint, Pnativeint + | Pint32, Pint32 + | Pint64, Pint64 -> + true + | (Pnativeint | Pint32 | Pint64), _ -> + false + +let equal_primitive = + (* Should be implemented like [equal_value_kind] of [equal_boxed_integer], + i.e. by matching over the various constructors but the type has more + than 100 constructors... *) + (=) + +let equal_value_kind x y = + match x, y with + | Pgenval, Pgenval -> true + | Pfloatval, Pfloatval -> true + | Pboxedintval bi1, Pboxedintval bi2 -> equal_boxed_integer bi1 bi2 + | Pintval, Pintval -> true + | (Pgenval | Pfloatval | Pboxedintval _ | Pintval), _ -> false + + +type structured_constant = + Const_base of constant + | Const_pointer of int + | Const_block of int * structured_constant list + | Const_float_array of string list + | Const_immstring of string + +type inline_attribute = + | Always_inline (* [@inline] or [@inline always] *) + | Never_inline (* [@inline never] *) + | Unroll of int (* [@unroll x] *) + | Default_inline (* no [@inline] attribute *) + +let equal_inline_attribute x y = + match x, y with + | Always_inline, Always_inline + | Never_inline, Never_inline + | Default_inline, Default_inline + -> + true + | Unroll u, Unroll v -> + u = v + | (Always_inline | Never_inline | Unroll _ | Default_inline), _ -> + false + +type specialise_attribute = + | Always_specialise (* [@specialise] or [@specialise always] *) + | Never_specialise (* [@specialise never] *) + | Default_specialise (* no [@specialise] attribute *) + +let equal_specialise_attribute x y = + match x, y with + | Always_specialise, Always_specialise + | Never_specialise, Never_specialise + | Default_specialise, Default_specialise -> + true + | (Always_specialise | Never_specialise | Default_specialise), _ -> + false + +type local_attribute = + | Always_local (* [@local] or [@local always] *) + | Never_local (* [@local never] *) + | Default_local (* [@local maybe] or no [@local] attribute *) + +type function_kind = Curried | Tupled + +type let_kind = Strict | Alias | StrictOpt | Variable + +type meth_kind = Self | Public | Cached + +let equal_meth_kind x y = + match x, y with + | Self, Self -> true + | Public, Public -> true + | Cached, Cached -> true + | (Self | Public | Cached), _ -> false + +type shared_code = (int * int) list + +type function_attribute = { + inline : inline_attribute; + specialise : specialise_attribute; + local: local_attribute; + is_a_functor: bool; + stub: bool; +} + +type lambda = + Lvar of Ident.t + | Lconst of structured_constant + | Lapply of lambda_apply + | Lfunction of lfunction + | Llet of let_kind * value_kind * Ident.t * lambda * lambda + | Lletrec of (Ident.t * lambda) list * lambda + | Lprim of primitive * lambda list * Location.t + | Lswitch of lambda * lambda_switch * Location.t + | Lstringswitch of + lambda * (string * lambda) list * lambda option * Location.t + | Lstaticraise of int * lambda list + | Lstaticcatch of lambda * (int * (Ident.t * value_kind) list) * lambda + | Ltrywith of lambda * Ident.t * lambda + | Lifthenelse of lambda * lambda * lambda + | Lsequence of lambda * lambda + | Lwhile of lambda * lambda + | Lfor of Ident.t * lambda * lambda * direction_flag * lambda + | Lassign of Ident.t * lambda + | Lsend of meth_kind * lambda * lambda * lambda list * Location.t + | Levent of lambda * lambda_event + | Lifused of Ident.t * lambda + +and lfunction = + { kind: function_kind; + params: (Ident.t * value_kind) list; + return: value_kind; + body: lambda; + attr: function_attribute; (* specified with [@inline] attribute *) + loc: Location.t; } + +and lambda_apply = + { ap_func : lambda; + ap_args : lambda list; + ap_loc : Location.t; + ap_should_be_tailcall : bool; + ap_inlined : inline_attribute; + ap_specialised : specialise_attribute; } + +and lambda_switch = + { sw_numconsts: int; + sw_consts: (int * lambda) list; + sw_numblocks: int; + sw_blocks: (int * lambda) list; + sw_failaction : lambda option} + +and lambda_event = + { lev_loc: Location.t; + lev_kind: lambda_event_kind; + lev_repr: int ref option; + lev_env: Env.t } + +and lambda_event_kind = + Lev_before + | Lev_after of Types.type_expr + | Lev_function + | Lev_pseudo + | Lev_module_definition of Ident.t + +type program = + { module_ident : Ident.t; + main_module_block_size : int; + required_globals : Ident.Set.t; + code : lambda } + +let const_unit = Const_pointer 0 + +let lambda_unit = Lconst const_unit + +let default_function_attribute = { + inline = Default_inline; + specialise = Default_specialise; + local = Default_local; + is_a_functor = false; + stub = false; +} + +let default_stub_attribute = + { default_function_attribute with stub = true } + +(* Build sharing keys *) +(* + Those keys are later compared with Stdlib.compare. + For that reason, they should not include cycles. +*) + +exception Not_simple + +let max_raw = 32 + +let make_key e = + let count = ref 0 (* Used for controlling size *) + and make_key = Ident.make_key_generator () in + (* make_key is used for normalizing let-bound variables *) + let rec tr_rec env e = + incr count ; + if !count > max_raw then raise Not_simple ; (* Too big ! *) + match e with + | Lvar id -> + begin + try Ident.find_same id env + with Not_found -> e + end + | Lconst (Const_base (Const_string _)) -> + (* Mutable constants are not shared *) + raise Not_simple + | Lconst _ -> e + | Lapply ap -> + Lapply {ap with ap_func = tr_rec env ap.ap_func; + ap_args = tr_recs env ap.ap_args; + ap_loc = Location.none} + | Llet (Alias,_k,x,ex,e) -> (* Ignore aliases -> substitute *) + let ex = tr_rec env ex in + tr_rec (Ident.add x ex env) e + | Llet ((Strict | StrictOpt),_k,x,ex,Lvar v) when Ident.same v x -> + tr_rec env ex + | Llet (str,k,x,ex,e) -> + (* Because of side effects, keep other lets with normalized names *) + let ex = tr_rec env ex in + let y = make_key x in + Llet (str,k,y,ex,tr_rec (Ident.add x (Lvar y) env) e) + | Lprim (p,es,_) -> + Lprim (p,tr_recs env es, Location.none) + | Lswitch (e,sw,loc) -> + Lswitch (tr_rec env e,tr_sw env sw,loc) + | Lstringswitch (e,sw,d,_) -> + Lstringswitch + (tr_rec env e, + List.map (fun (s,e) -> s,tr_rec env e) sw, + tr_opt env d, + Location.none) + | Lstaticraise (i,es) -> + Lstaticraise (i,tr_recs env es) + | Lstaticcatch (e1,xs,e2) -> + Lstaticcatch (tr_rec env e1,xs,tr_rec env e2) + | Ltrywith (e1,x,e2) -> + Ltrywith (tr_rec env e1,x,tr_rec env e2) + | Lifthenelse (cond,ifso,ifnot) -> + Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot) + | Lsequence (e1,e2) -> + Lsequence (tr_rec env e1,tr_rec env e2) + | Lassign (x,e) -> + Lassign (x,tr_rec env e) + | Lsend (m,e1,e2,es,_loc) -> + Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Location.none) + | Lifused (id,e) -> Lifused (id,tr_rec env e) + | Lletrec _|Lfunction _ + | Lfor _ | Lwhile _ +(* Beware: (PR#6412) the event argument to Levent + may include cyclic structure of type Type.typexpr *) + | Levent _ -> + raise Not_simple + + and tr_recs env es = List.map (tr_rec env) es + + and tr_sw env sw = + { sw with + sw_consts = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_consts ; + sw_blocks = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_blocks ; + sw_failaction = tr_opt env sw.sw_failaction ; } + + and tr_opt env = function + | None -> None + | Some e -> Some (tr_rec env e) in + + try + Some (tr_rec Ident.empty e) + with Not_simple -> None + +(***************) + +let name_lambda strict arg fn = + match arg with + Lvar id -> fn id + | _ -> + let id = Ident.create_local "let" in + Llet(strict, Pgenval, id, arg, fn id) + +let name_lambda_list args fn = + let rec name_list names = function + [] -> fn (List.rev names) + | (Lvar _ as arg) :: rem -> + name_list (arg :: names) rem + | arg :: rem -> + let id = Ident.create_local "let" in + Llet(Strict, Pgenval, id, arg, name_list (Lvar id :: names) rem) in + name_list [] args + + +let iter_opt f = function + | None -> () + | Some e -> f e + +let shallow_iter ~tail ~non_tail:f = function + Lvar _ + | Lconst _ -> () + | Lapply{ap_func = fn; ap_args = args} -> + f fn; List.iter f args + | Lfunction{body} -> + f body + | Llet(_str, _k, _id, arg, body) -> + f arg; tail body + | Lletrec(decl, body) -> + tail body; + List.iter (fun (_id, exp) -> f exp) decl + | Lprim (Pidentity, [l], _) -> + tail l + | Lprim (Psequand, [l1; l2], _) + | Lprim (Psequor, [l1; l2], _) -> + f l1; + tail l2 + | Lprim(_p, args, _loc) -> + List.iter f args + | Lswitch(arg, sw,_) -> + f arg; + List.iter (fun (_key, case) -> tail case) sw.sw_consts; + List.iter (fun (_key, case) -> tail case) sw.sw_blocks; + iter_opt tail sw.sw_failaction + | Lstringswitch (arg,cases,default,_) -> + f arg ; + List.iter (fun (_,act) -> tail act) cases ; + iter_opt tail default + | Lstaticraise (_,args) -> + List.iter f args + | Lstaticcatch(e1, _, e2) -> + tail e1; tail e2 + | Ltrywith(e1, _, e2) -> + f e1; tail e2 + | Lifthenelse(e1, e2, e3) -> + f e1; tail e2; tail e3 + | Lsequence(e1, e2) -> + f e1; tail e2 + | Lwhile(e1, e2) -> + f e1; f e2 + | Lfor(_v, e1, e2, _dir, e3) -> + f e1; f e2; f e3 + | Lassign(_, e) -> + f e + | Lsend (_k, met, obj, args, _) -> + List.iter f (met::obj::args) + | Levent (e, _evt) -> + tail e + | Lifused (_v, e) -> + tail e + +let iter_head_constructor f l = + shallow_iter ~tail:f ~non_tail:f l + +let rec free_variables = function + | Lvar id -> Ident.Set.singleton id + | Lconst _ -> Ident.Set.empty + | Lapply{ap_func = fn; ap_args = args} -> + free_variables_list (free_variables fn) args + | Lfunction{body; params} -> + Ident.Set.diff (free_variables body) + (Ident.Set.of_list (List.map fst params)) + | Llet(_str, _k, id, arg, body) -> + Ident.Set.union + (free_variables arg) + (Ident.Set.remove id (free_variables body)) + | Lletrec(decl, body) -> + let set = free_variables_list (free_variables body) (List.map snd decl) in + Ident.Set.diff set (Ident.Set.of_list (List.map fst decl)) + | Lprim(_p, args, _loc) -> + free_variables_list Ident.Set.empty args + | Lswitch(arg, sw,_) -> + let set = + free_variables_list + (free_variables_list (free_variables arg) + (List.map snd sw.sw_consts)) + (List.map snd sw.sw_blocks) + in + begin match sw.sw_failaction with + | None -> set + | Some failaction -> Ident.Set.union set (free_variables failaction) + end + | Lstringswitch (arg,cases,default,_) -> + let set = + free_variables_list (free_variables arg) + (List.map snd cases) + in + begin match default with + | None -> set + | Some default -> Ident.Set.union set (free_variables default) + end + | Lstaticraise (_,args) -> + free_variables_list Ident.Set.empty args + | Lstaticcatch(body, (_, params), handler) -> + Ident.Set.union + (Ident.Set.diff + (free_variables handler) + (Ident.Set.of_list (List.map fst params))) + (free_variables body) + | Ltrywith(body, param, handler) -> + Ident.Set.union + (Ident.Set.remove + param + (free_variables handler)) + (free_variables body) + | Lifthenelse(e1, e2, e3) -> + Ident.Set.union + (Ident.Set.union (free_variables e1) (free_variables e2)) + (free_variables e3) + | Lsequence(e1, e2) -> + Ident.Set.union (free_variables e1) (free_variables e2) + | Lwhile(e1, e2) -> + Ident.Set.union (free_variables e1) (free_variables e2) + | Lfor(v, lo, hi, _dir, body) -> + let set = Ident.Set.union (free_variables lo) (free_variables hi) in + Ident.Set.union set (Ident.Set.remove v (free_variables body)) + | Lassign(id, e) -> + Ident.Set.add id (free_variables e) + | Lsend (_k, met, obj, args, _) -> + free_variables_list + (Ident.Set.union (free_variables met) (free_variables obj)) + args + | Levent (lam, _evt) -> + free_variables lam + | Lifused (_v, e) -> + (* Shouldn't v be considered a free variable ? *) + free_variables e + +and free_variables_list set exprs = + List.fold_left (fun set expr -> Ident.Set.union (free_variables expr) set) + set exprs + +(* Check if an action has a "when" guard *) +let raise_count = ref 0 + +let next_raise_count () = + incr raise_count ; + !raise_count + +(* Anticipated staticraise, for guards *) +let staticfail = Lstaticraise (0,[]) + +let rec is_guarded = function + | Lifthenelse(_cond, _body, Lstaticraise (0,[])) -> true + | Llet(_str, _k, _id, _lam, body) -> is_guarded body + | Levent(lam, _ev) -> is_guarded lam + | _ -> false + +let rec patch_guarded patch = function + | Lifthenelse (cond, body, Lstaticraise (0,[])) -> + Lifthenelse (cond, body, patch) + | Llet(str, k, id, lam, body) -> + Llet (str, k, id, lam, patch_guarded patch body) + | Levent(lam, ev) -> + Levent (patch_guarded patch lam, ev) + | _ -> fatal_error "Lambda.patch_guarded" + +(* Translate an access path *) + +let rec transl_address loc = function + | Env.Aident id -> + if Ident.global id + then Lprim(Pgetglobal id, [], loc) + else Lvar id + | Env.Adot(addr, pos) -> + Lprim(Pfield pos, [transl_address loc addr], loc) + +let transl_path find loc env path = + match find path env with + | exception Not_found -> + fatal_error ("Cannot find address for: " ^ (Path.name path)) + | addr -> transl_address loc addr + +(* Translation of identifiers *) + +let transl_module_path loc env path = + transl_path Env.find_module_address loc env path + +let transl_value_path loc env path = + transl_path Env.find_value_address loc env path + +let transl_extension_path loc env path = + transl_path Env.find_constructor_address loc env path + +let transl_class_path loc env path = + transl_path Env.find_class_address loc env path + +let transl_prim mod_name name = + let pers = Ident.create_persistent mod_name in + let env = Env.add_persistent_structure pers Env.empty in + let lid = Longident.Ldot (Longident.Lident mod_name, name) in + match Env.lookup_value lid env with + | path, _ -> transl_value_path Location.none env path + | exception Not_found -> + fatal_error ("Primitive " ^ name ^ " not found.") + +(* Compile a sequence of expressions *) + +let rec make_sequence fn = function + [] -> lambda_unit + | [x] -> fn x + | x::rem -> + let lam = fn x in Lsequence(lam, make_sequence fn rem) + +(* Apply a substitution to a lambda-term. + Assumes that the image of the substitution is out of reach + of the bound variables of the lambda-term (no capture). *) + +let subst update_env s lam = + let rec subst s lam = + let remove_list l s = + List.fold_left (fun s (id, _kind) -> Ident.Map.remove id s) s l + in + let module M = Ident.Map in + match lam with + | Lvar id as l -> + begin try Ident.Map.find id s with Not_found -> l end + | Lconst _ as l -> l + | Lapply ap -> + Lapply{ap with ap_func = subst s ap.ap_func; + ap_args = subst_list s ap.ap_args} + | Lfunction lf -> + let s = + List.fold_right + (fun (id, _) s -> Ident.Map.remove id s) + lf.params s + in + Lfunction {lf with body = subst s lf.body} + | Llet(str, k, id, arg, body) -> + Llet(str, k, id, subst s arg, subst (Ident.Map.remove id s) body) + | Lletrec(decl, body) -> + let s = + List.fold_left (fun s (id, _) -> Ident.Map.remove id s) + s decl + in + Lletrec(List.map (subst_decl s) decl, subst s body) + | Lprim(p, args, loc) -> Lprim(p, subst_list s args, loc) + | Lswitch(arg, sw, loc) -> + Lswitch(subst s arg, + {sw with sw_consts = List.map (subst_case s) sw.sw_consts; + sw_blocks = List.map (subst_case s) sw.sw_blocks; + sw_failaction = subst_opt s sw.sw_failaction; }, + loc) + | Lstringswitch (arg,cases,default,loc) -> + Lstringswitch + (subst s arg,List.map (subst_strcase s) cases,subst_opt s default,loc) + | Lstaticraise (i,args) -> Lstaticraise (i, subst_list s args) + | Lstaticcatch(body, (id, params), handler) -> + Lstaticcatch(subst s body, (id, params), + subst (remove_list params s) handler) + | Ltrywith(body, exn, handler) -> + Ltrywith(subst s body, exn, subst (Ident.Map.remove exn s) handler) + | Lifthenelse(e1, e2, e3) -> Lifthenelse(subst s e1, subst s e2, subst s e3) + | Lsequence(e1, e2) -> Lsequence(subst s e1, subst s e2) + | Lwhile(e1, e2) -> Lwhile(subst s e1, subst s e2) + | Lfor(v, lo, hi, dir, body) -> + Lfor(v, subst s lo, subst s hi, dir, + subst (Ident.Map.remove v s) body) + | Lassign(id, e) -> + assert(not (Ident.Map.mem id s)); + Lassign(id, subst s e) + | Lsend (k, met, obj, args, loc) -> + Lsend (k, subst s met, subst s obj, subst_list s args, loc) + | Levent (lam, evt) -> + let lev_env = + Ident.Map.fold (fun id _ env -> + match Env.find_value (Path.Pident id) evt.lev_env with + | exception Not_found -> env + | vd -> update_env id vd env + ) s evt.lev_env + in + Levent (subst s lam, { evt with lev_env }) + | Lifused (v, e) -> Lifused (v, subst s e) + and subst_list s l = List.map (subst s) l + and subst_decl s (id, exp) = (id, subst s exp) + and subst_case s (key, case) = (key, subst s case) + and subst_strcase s (key, case) = (key, subst s case) + and subst_opt s = function + | None -> None + | Some e -> Some (subst s e) + in + subst s lam + +let rename idmap lam = + let update_env oldid vd env = + let newid = Ident.Map.find oldid idmap in + Env.add_value newid vd env + in + let s = Ident.Map.map (fun new_id -> Lvar new_id) idmap in + subst update_env s lam + +let shallow_map f = function + | Lvar _ + | Lconst _ as lam -> lam + | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall; + ap_inlined; ap_specialised } -> + Lapply { + ap_func = f ap_func; + ap_args = List.map f ap_args; + ap_loc; + ap_should_be_tailcall; + ap_inlined; + ap_specialised; + } + | Lfunction { kind; params; return; body; attr; loc; } -> + Lfunction { kind; params; return; body = f body; attr; loc; } + | Llet (str, k, v, e1, e2) -> + Llet (str, k, v, f e1, f e2) + | Lletrec (idel, e2) -> + Lletrec (List.map (fun (v, e) -> (v, f e)) idel, f e2) + | Lprim (p, el, loc) -> + Lprim (p, List.map f el, loc) + | Lswitch (e, sw, loc) -> + Lswitch (f e, + { sw_numconsts = sw.sw_numconsts; + sw_consts = List.map (fun (n, e) -> (n, f e)) sw.sw_consts; + sw_numblocks = sw.sw_numblocks; + sw_blocks = List.map (fun (n, e) -> (n, f e)) sw.sw_blocks; + sw_failaction = Misc.may_map f sw.sw_failaction; + }, + loc) + | Lstringswitch (e, sw, default, loc) -> + Lstringswitch ( + f e, + List.map (fun (s, e) -> (s, f e)) sw, + Misc.may_map f default, + loc) + | Lstaticraise (i, args) -> + Lstaticraise (i, List.map f args) + | Lstaticcatch (body, id, handler) -> + Lstaticcatch (f body, id, f handler) + | Ltrywith (e1, v, e2) -> + Ltrywith (f e1, v, f e2) + | Lifthenelse (e1, e2, e3) -> + Lifthenelse (f e1, f e2, f e3) + | Lsequence (e1, e2) -> + Lsequence (f e1, f e2) + | Lwhile (e1, e2) -> + Lwhile (f e1, f e2) + | Lfor (v, e1, e2, dir, e3) -> + Lfor (v, f e1, f e2, dir, f e3) + | Lassign (v, e) -> + Lassign (v, f e) + | Lsend (k, m, o, el, loc) -> + Lsend (k, f m, f o, List.map f el, loc) + | Levent (l, ev) -> + Levent (f l, ev) + | Lifused (v, e) -> + Lifused (v, f e) + +let map f = + let rec g lam = f (shallow_map g lam) in + g + +(* To let-bind expressions to variables *) + +let bind_with_value_kind str (var, kind) exp body = + match exp with + Lvar var' when Ident.same var var' -> body + | _ -> Llet(str, kind, var, exp, body) + +let bind str var exp body = + bind_with_value_kind str (var, Pgenval) exp body + +let negate_integer_comparison = function + | Ceq -> Cne + | Cne -> Ceq + | Clt -> Cge + | Cle -> Cgt + | Cgt -> Cle + | Cge -> Clt + +let swap_integer_comparison = function + | Ceq -> Ceq + | Cne -> Cne + | Clt -> Cgt + | Cle -> Cge + | Cgt -> Clt + | Cge -> Cle + +let negate_float_comparison = function + | CFeq -> CFneq + | CFneq -> CFeq + | CFlt -> CFnlt + | CFnlt -> CFlt + | CFgt -> CFngt + | CFngt -> CFgt + | CFle -> CFnle + | CFnle -> CFle + | CFge -> CFnge + | CFnge -> CFge + +let swap_float_comparison = function + | CFeq -> CFeq + | CFneq -> CFneq + | CFlt -> CFgt + | CFnlt -> CFngt + | CFle -> CFge + | CFnle -> CFnge + | CFgt -> CFlt + | CFngt -> CFnlt + | CFge -> CFle + | CFnge -> CFnle + +let raise_kind = function + | Raise_regular -> "raise" + | Raise_reraise -> "reraise" + | Raise_notrace -> "raise_notrace" + +let merge_inline_attributes attr1 attr2 = + match attr1, attr2 with + | Default_inline, _ -> Some attr2 + | _, Default_inline -> Some attr1 + | _, _ -> + if attr1 = attr2 then Some attr1 + else None + +let function_is_curried func = + match func.kind with + | Curried -> true + | Tupled -> false + +let reset () = + raise_count := 0 diff --git a/lambda/lambda.mli b/lambda/lambda.mli new file mode 100644 index 00000000..f79ee0c7 --- /dev/null +++ b/lambda/lambda.mli @@ -0,0 +1,428 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* The "lambda" intermediate code *) + +open Asttypes + +type compile_time_constant = + | Big_endian + | Word_size + | Int_size + | Max_wosize + | Ostype_unix + | Ostype_win32 + | Ostype_cygwin + | Backend_type + +type immediate_or_pointer = + | Immediate + | Pointer + +type initialization_or_assignment = + | Assignment + (* Initialization of in heap values, like [caml_initialize] C primitive. The + field should not have been read before and initialization should happen + only once. *) + | Heap_initialization + (* Initialization of roots only. Compiles to a simple store. + No checks are done to preserve GC invariants. *) + | Root_initialization + +type is_safe = + | Safe + | Unsafe + +type primitive = + | Pidentity + | Pbytes_to_string + | Pbytes_of_string + | Pignore + | Prevapply + | Pdirapply + (* Globals *) + | Pgetglobal of Ident.t + | Psetglobal of Ident.t + (* Operations on heap blocks *) + | Pmakeblock of int * mutable_flag * block_shape + | Pfield of int + | Pfield_computed + | Psetfield of int * immediate_or_pointer * initialization_or_assignment + | Psetfield_computed of immediate_or_pointer * initialization_or_assignment + | Pfloatfield of int + | Psetfloatfield of int * initialization_or_assignment + | Pduprecord of Types.record_representation * int + (* External call *) + | Pccall of Primitive.description + (* Exceptions *) + | Praise of raise_kind + (* Boolean operations *) + | Psequand | Psequor | Pnot + (* Integer operations *) + | Pnegint | Paddint | Psubint | Pmulint + | Pdivint of is_safe | Pmodint of is_safe + | Pandint | Porint | Pxorint + | Plslint | Plsrint | Pasrint + | Pintcomp of integer_comparison + | Poffsetint of int + | Poffsetref of int + (* Float operations *) + | Pintoffloat | Pfloatofint + | Pnegfloat | Pabsfloat + | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat + | Pfloatcomp of float_comparison + (* String operations *) + | Pstringlength | Pstringrefu | Pstringrefs + | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets + (* Array operations *) + | Pmakearray of array_kind * mutable_flag + | Pduparray of array_kind * mutable_flag + (** For [Pduparray], the argument must be an immutable array. + The arguments of [Pduparray] give the kind and mutability of the + array being *produced* by the duplication. *) + | Parraylength of array_kind + | Parrayrefu of array_kind + | Parraysetu of array_kind + | Parrayrefs of array_kind + | Parraysets of array_kind + (* Test if the argument is a block or an immediate integer *) + | Pisint + (* Test if the (integer) argument is outside an interval *) + | Pisout + (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *) + | Pbintofint of boxed_integer + | Pintofbint of boxed_integer + | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*) + | Pnegbint of boxed_integer + | Paddbint of boxed_integer + | Psubbint of boxed_integer + | Pmulbint of boxed_integer + | Pdivbint of { size : boxed_integer; is_safe : is_safe } + | Pmodbint of { size : boxed_integer; is_safe : is_safe } + | Pandbint of boxed_integer + | Porbint of boxed_integer + | Pxorbint of boxed_integer + | Plslbint of boxed_integer + | Plsrbint of boxed_integer + | Pasrbint of boxed_integer + | Pbintcomp of boxed_integer * integer_comparison + (* Operations on Bigarrays: (unsafe, #dimensions, kind, layout) *) + | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout + | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout + (* size of the nth dimension of a Bigarray *) + | Pbigarraydim of int + (* load/set 16,32,64 bits from a string: (unsafe)*) + | Pstring_load_16 of bool + | Pstring_load_32 of bool + | Pstring_load_64 of bool + | Pbytes_load_16 of bool + | Pbytes_load_32 of bool + | Pbytes_load_64 of bool + | Pbytes_set_16 of bool + | Pbytes_set_32 of bool + | Pbytes_set_64 of bool + (* load/set 16,32,64 bits from a + (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *) + | Pbigstring_load_16 of bool + | Pbigstring_load_32 of bool + | Pbigstring_load_64 of bool + | Pbigstring_set_16 of bool + | Pbigstring_set_32 of bool + | Pbigstring_set_64 of bool + (* Compile time constants *) + | Pctconst of compile_time_constant + (* byte swap *) + | Pbswap16 + | Pbbswap of boxed_integer + (* Integer to external pointer *) + | Pint_as_pointer + (* Inhibition of optimisation *) + | Popaque + +and integer_comparison = + Ceq | Cne | Clt | Cgt | Cle | Cge + +and float_comparison = + CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge + +and array_kind = + Pgenarray | Paddrarray | Pintarray | Pfloatarray + +and value_kind = + Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval + +and block_shape = + value_kind list option + +and boxed_integer = Primitive.boxed_integer = + Pnativeint | Pint32 | Pint64 + +and bigarray_kind = + Pbigarray_unknown + | Pbigarray_float32 | Pbigarray_float64 + | Pbigarray_sint8 | Pbigarray_uint8 + | Pbigarray_sint16 | Pbigarray_uint16 + | Pbigarray_int32 | Pbigarray_int64 + | Pbigarray_caml_int | Pbigarray_native_int + | Pbigarray_complex32 | Pbigarray_complex64 + +and bigarray_layout = + Pbigarray_unknown_layout + | Pbigarray_c_layout + | Pbigarray_fortran_layout + +and raise_kind = + | Raise_regular + | Raise_reraise + | Raise_notrace + +val equal_primitive : primitive -> primitive -> bool + +val equal_value_kind : value_kind -> value_kind -> bool + +val equal_boxed_integer : boxed_integer -> boxed_integer -> bool + +type structured_constant = + Const_base of constant + | Const_pointer of int + | Const_block of int * structured_constant list + | Const_float_array of string list + | Const_immstring of string + +type inline_attribute = + | Always_inline (* [@inline] or [@inline always] *) + | Never_inline (* [@inline never] *) + | Unroll of int (* [@unroll x] *) + | Default_inline (* no [@inline] attribute *) + +val equal_inline_attribute : inline_attribute -> inline_attribute -> bool + +type specialise_attribute = + | Always_specialise (* [@specialise] or [@specialise always] *) + | Never_specialise (* [@specialise never] *) + | Default_specialise (* no [@specialise] attribute *) + +val equal_specialise_attribute + : specialise_attribute + -> specialise_attribute + -> bool + +type local_attribute = + | Always_local (* [@local] or [@local always] *) + | Never_local (* [@local never] *) + | Default_local (* [@local maybe] or no [@local] attribute *) + +type function_kind = Curried | Tupled + +type let_kind = Strict | Alias | StrictOpt | Variable +(* Meaning of kinds for let x = e in e': + Strict: e may have side-effects; always evaluate e first + (If e is a simple expression, e.g. a variable or constant, + we may still substitute e'[x/e].) + Alias: e is pure, we can substitute e'[x/e] if x has 0 or 1 occurrences + in e' + StrictOpt: e does not have side-effects, but depend on the store; + we can discard e if x does not appear in e' + Variable: the variable x is assigned later in e' + *) + +type meth_kind = Self | Public | Cached + +val equal_meth_kind : meth_kind -> meth_kind -> bool + +type shared_code = (int * int) list (* stack size -> code label *) + +type function_attribute = { + inline : inline_attribute; + specialise : specialise_attribute; + local: local_attribute; + is_a_functor: bool; + stub: bool; +} + +type lambda = + Lvar of Ident.t + | Lconst of structured_constant + | Lapply of lambda_apply + | Lfunction of lfunction + | Llet of let_kind * value_kind * Ident.t * lambda * lambda + | Lletrec of (Ident.t * lambda) list * lambda + | Lprim of primitive * lambda list * Location.t + | Lswitch of lambda * lambda_switch * Location.t +(* switch on strings, clauses are sorted by string order, + strings are pairwise distinct *) + | Lstringswitch of + lambda * (string * lambda) list * lambda option * Location.t + | Lstaticraise of int * lambda list + | Lstaticcatch of lambda * (int * (Ident.t * value_kind) list) * lambda + | Ltrywith of lambda * Ident.t * lambda + | Lifthenelse of lambda * lambda * lambda + | Lsequence of lambda * lambda + | Lwhile of lambda * lambda + | Lfor of Ident.t * lambda * lambda * direction_flag * lambda + | Lassign of Ident.t * lambda + | Lsend of meth_kind * lambda * lambda * lambda list * Location.t + | Levent of lambda * lambda_event + | Lifused of Ident.t * lambda + +and lfunction = + { kind: function_kind; + params: (Ident.t * value_kind) list; + return: value_kind; + body: lambda; + attr: function_attribute; (* specified with [@inline] attribute *) + loc : Location.t; } + +and lambda_apply = + { ap_func : lambda; + ap_args : lambda list; + ap_loc : Location.t; + ap_should_be_tailcall : bool; (* true if [@tailcall] was specified *) + ap_inlined : inline_attribute; (* specified with the [@inlined] attribute *) + ap_specialised : specialise_attribute; } + +and lambda_switch = + { sw_numconsts: int; (* Number of integer cases *) + sw_consts: (int * lambda) list; (* Integer cases *) + sw_numblocks: int; (* Number of tag block cases *) + sw_blocks: (int * lambda) list; (* Tag block cases *) + sw_failaction : lambda option} (* Action to take if failure *) +and lambda_event = + { lev_loc: Location.t; + lev_kind: lambda_event_kind; + lev_repr: int ref option; + lev_env: Env.t } + +and lambda_event_kind = + Lev_before + | Lev_after of Types.type_expr + | Lev_function + | Lev_pseudo + | Lev_module_definition of Ident.t + +type program = + { module_ident : Ident.t; + main_module_block_size : int; + required_globals : Ident.Set.t; (* Modules whose initializer side effects + must occur before [code]. *) + code : lambda } +(* Lambda code for the middle-end. + * In the closure case the code is a sequence of assignments to a + preallocated block of size [main_module_block_size] using + (Setfield(Getglobal(module_ident))). The size is used to preallocate + the block. + * In the flambda case the code is an expression returning a block + value of size [main_module_block_size]. The size is used to build + the module root as an initialize_symbol + Initialize_symbol(module_name, 0, + [getfield 0; ...; getfield (main_module_block_size - 1)]) +*) + +(* Sharing key *) +val make_key: lambda -> lambda option + +val const_unit: structured_constant +val lambda_unit: lambda +val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda +val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda + +val iter_head_constructor: (lambda -> unit) -> lambda -> unit +(** [iter_head_constructor f lam] apply [f] to only the first level of + sub expressions of [lam]. It does not recursively traverse the + expression. +*) + +val shallow_iter: + tail:(lambda -> unit) -> + non_tail:(lambda -> unit) -> + lambda -> unit +(** Same as [iter_head_constructor], but use a different callback for + sub-terms which are in tail position or not. *) + +val transl_prim: string -> string -> lambda +(** Translate a value from a persistent module. For instance: + + {[ + transl_internal_value "CamlinternalLazy" "force" + ]} +*) + +val free_variables: lambda -> Ident.Set.t + +val transl_module_path: Location.t -> Env.t -> Path.t -> lambda +val transl_value_path: Location.t -> Env.t -> Path.t -> lambda +val transl_extension_path: Location.t -> Env.t -> Path.t -> lambda +val transl_class_path: Location.t -> Env.t -> Path.t -> lambda + +val make_sequence: ('a -> lambda) -> 'a list -> lambda + +val subst: (Ident.t -> Types.value_description -> Env.t -> Env.t) -> + lambda Ident.Map.t -> lambda -> lambda +(** [subst env_update_fun s lt] applies a substitution [s] to the lambda-term + [lt]. + + Assumes that the image of the substitution is out of reach + of the bound variables of the lambda-term (no capture). + + [env_update_fun] is used to refresh the environment contained in debug + events. *) + +val rename : Ident.t Ident.Map.t -> lambda -> lambda +(** A version of [subst] specialized for the case where we're just renaming + idents. *) + +val map : (lambda -> lambda) -> lambda -> lambda + (** Bottom-up rewriting, applying the function on + each node from the leaves to the root. *) + +val shallow_map : (lambda -> lambda) -> lambda -> lambda + (** Rewrite each immediate sub-term with the function. *) + +val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda +val bind_with_value_kind: + let_kind -> (Ident.t * value_kind) -> lambda -> lambda -> lambda + +val negate_integer_comparison : integer_comparison -> integer_comparison +val swap_integer_comparison : integer_comparison -> integer_comparison + +val negate_float_comparison : float_comparison -> float_comparison +val swap_float_comparison : float_comparison -> float_comparison + +val default_function_attribute : function_attribute +val default_stub_attribute : function_attribute + +val function_is_curried : lfunction -> bool + +(***********************) +(* For static failures *) +(***********************) + +(* Get a new static failure ident *) +val next_raise_count : unit -> int + +val staticfail : lambda (* Anticipated static failure *) + +(* Check anticipated failure, substitute its final value *) +val is_guarded: lambda -> bool +val patch_guarded : lambda -> lambda -> lambda + +val raise_kind: raise_kind -> string + +val merge_inline_attributes + : inline_attribute + -> inline_attribute + -> inline_attribute option + +val reset: unit -> unit diff --git a/lambda/matching.ml b/lambda/matching.ml new file mode 100644 index 00000000..0b31ecbc --- /dev/null +++ b/lambda/matching.ml @@ -0,0 +1,3240 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Compilation of pattern matching *) + +open Misc +open Asttypes +open Types +open Typedtree +open Lambda +open Parmatch +open Printf +open Printpat + + +let dbg = false + +(* See Peyton-Jones, ``The Implementation of functional programming + languages'', chapter 5. *) +(* + Well, it was true at the beginning of the world. + Now, see Lefessant-Maranget ``Optimizing Pattern-Matching'' ICFP'2001 +*) + +(* + Compatibility predicate that considers potential rebindings of constructors + of an extension type. + + "may_compat p q" returns false when p and q never admit a common instance; + returns true when they may have a common instance. +*) + +module MayCompat = + Parmatch.Compat (struct let equal = Types.may_equal_constr end) +let may_compat = MayCompat.compat +and may_compats = MayCompat.compats + +(* + Many functions on the various data structures of the algorithm : + - Pattern matrices. + - Default environments: mapping from matrices to exit numbers. + - Contexts: matrices whose column are partitioned into + left and right. + - Jump summaries: mapping from exit numbers to contexts +*) + + +let string_of_lam lam = + Printlambda.lambda Format.str_formatter lam ; + Format.flush_str_formatter () + +let all_record_args lbls = match lbls with +| (_,{lbl_all=lbl_all},_)::_ -> + let t = + Array.map + (fun lbl -> mknoloc (Longident.Lident "?temp?"), lbl,omega) + lbl_all in + List.iter + (fun ((_, lbl,_) as x) -> t.(lbl.lbl_pos) <- x) + lbls ; + Array.to_list t +| _ -> fatal_error "Parmatch.all_record_args" + +type matrix = pattern list list + +let add_omega_column pss = List.map (fun ps -> omega::ps) pss + +type ctx = {left:pattern list ; right:pattern list} + +let pretty_ctx ctx = + List.iter + (fun {left=left ; right=right} -> + Format.eprintf "LEFT:%a RIGHT:%a\n" pretty_line left pretty_line right) + ctx + +let le_ctx c1 c2 = + le_pats c1.left c2.left && + le_pats c1.right c2.right + +let lshift {left=left ; right=right} = match right with +| x::xs -> {left=x::left ; right=xs} +| _ -> assert false + +let lforget {left=left ; right=right} = match right with +| _::xs -> {left=omega::left ; right=xs} +| _ -> assert false + +let rec small_enough n = function + | [] -> true + | _::rem -> + if n <= 0 then false + else small_enough (n-1) rem + +let ctx_lshift ctx = + if small_enough (!Clflags.match_context_rows - 1) ctx then + List.map lshift ctx + else (* Context pruning *) begin + get_mins le_ctx (List.map lforget ctx) + end + +let rshift {left=left ; right=right} = match left with +| p::ps -> {left=ps ; right=p::right} +| _ -> assert false + +let ctx_rshift ctx = List.map rshift ctx + +let rec nchars n ps = + if n <= 0 then [],ps + else match ps with + | p::rem -> + let chars, cdrs = nchars (n-1) rem in + p::chars,cdrs + | _ -> assert false + +let rshift_num n {left=left ; right=right} = + let shifted,left = nchars n left in + {left=left ; right = shifted@right} + +let ctx_rshift_num n ctx = List.map (rshift_num n) ctx + +(* Recombination of contexts (eg: (_,_)::p1::p2::rem -> (p1,p2)::rem) + All mutable fields are replaced by '_', since side-effects in + guards can alter these fields *) + +let combine {left=left ; right=right} = match left with +| p::ps -> {left=ps ; right=set_args_erase_mutable p right} +| _ -> assert false + +let ctx_combine ctx = List.map combine ctx + +let ncols = function + | [] -> 0 + | ps::_ -> List.length ps + + +exception NoMatch +exception OrPat + +let filter_matrix matcher pss = + + let rec filter_rec = function + | (p::ps)::rem -> + begin match p.pat_desc with + | Tpat_alias (p,_,_) -> + filter_rec ((p::ps)::rem) + | Tpat_var _ -> + filter_rec ((omega::ps)::rem) + | _ -> + begin + let rem = filter_rec rem in + try + matcher p ps::rem + with + | NoMatch -> rem + | OrPat -> + match p.pat_desc with + | Tpat_or (p1,p2,_) -> filter_rec [(p1::ps) ;(p2::ps)]@rem + | _ -> assert false + end + end + | [] -> [] + | _ -> + pretty_matrix Format.err_formatter pss ; + fatal_error "Matching.filter_matrix" in + filter_rec pss + +let make_default matcher env = + let rec make_rec = function + | [] -> [] + | ([[]],i)::_ -> [[[]],i] + | (pss,i)::rem -> + let rem = make_rec rem in + match filter_matrix matcher pss with + | [] -> rem + | ([]::_) -> ([[]],i)::rem + | pss -> (pss,i)::rem in + make_rec env + +let ctx_matcher p = + let p = normalize_pat p in + match p.pat_desc with + | Tpat_construct (_, cstr,omegas) -> + (fun q rem -> match q.pat_desc with + | Tpat_construct (_, cstr',args) +(* NB: may_constr_equal considers (potential) constructor rebinding *) + when Types.may_equal_constr cstr cstr' -> + p,args@rem + | Tpat_any -> p,omegas @ rem + | _ -> raise NoMatch) + | Tpat_constant cst -> + (fun q rem -> match q.pat_desc with + | Tpat_constant cst' when const_compare cst cst' = 0 -> + p,rem + | Tpat_any -> p,rem + | _ -> raise NoMatch) + | Tpat_variant (lab,Some omega,_) -> + (fun q rem -> match q.pat_desc with + | Tpat_variant (lab',Some arg,_) when lab=lab' -> + p,arg::rem + | Tpat_any -> p,omega::rem + | _ -> raise NoMatch) + | Tpat_variant (lab,None,_) -> + (fun q rem -> match q.pat_desc with + | Tpat_variant (lab',None,_) when lab=lab' -> + p,rem + | Tpat_any -> p,rem + | _ -> raise NoMatch) + | Tpat_array omegas -> + let len = List.length omegas in + (fun q rem -> match q.pat_desc with + | Tpat_array args when List.length args = len -> p,args @ rem + | Tpat_any -> p, omegas @ rem + | _ -> raise NoMatch) + | Tpat_tuple omegas -> + let len = List.length omegas in + (fun q rem -> match q.pat_desc with + | Tpat_tuple args when List.length args = len -> p,args @ rem + | Tpat_any -> p, omegas @ rem + | _ -> raise NoMatch) + | Tpat_record (((_, lbl, _) :: _) as l,_) -> (* Records are normalized *) + let len = Array.length lbl.lbl_all in + (fun q rem -> match q.pat_desc with + | Tpat_record (((_, lbl', _) :: _) as l',_) + when Array.length lbl'.lbl_all = len -> + let l' = all_record_args l' in + p, List.fold_right (fun (_, _,p) r -> p::r) l' rem + | Tpat_any -> p,List.fold_right (fun (_, _,p) r -> p::r) l rem + | _ -> raise NoMatch) + | Tpat_lazy omega -> + (fun q rem -> match q.pat_desc with + | Tpat_lazy arg -> p, (arg::rem) + | Tpat_any -> p, (omega::rem) + | _ -> raise NoMatch) + | _ -> fatal_error "Matching.ctx_matcher" + + + + +let filter_ctx q ctx = + + let matcher = ctx_matcher q in + + let rec filter_rec = function + | ({right=p::ps} as l)::rem -> + begin match p.pat_desc with + | Tpat_or (p1,p2,_) -> + filter_rec ({l with right=p1::ps}::{l with right=p2::ps}::rem) + | Tpat_alias (p,_,_) -> + filter_rec ({l with right=p::ps}::rem) + | Tpat_var _ -> + filter_rec ({l with right=omega::ps}::rem) + | _ -> + begin let rem = filter_rec rem in + try + let to_left, right = matcher p ps in + {left=to_left::l.left ; right=right}::rem + with + | NoMatch -> rem + end + end + | [] -> [] + | _ -> fatal_error "Matching.filter_ctx" in + + filter_rec ctx + +let select_columns pss ctx = + let n = ncols pss in + List.fold_right + (fun ps r -> + List.fold_right + (fun {left=left ; right=right} r -> + let transfert, right = nchars n right in + try + {left = lubs transfert ps @ left ; right=right}::r + with + | Empty -> r) + ctx r) + pss [] + +let ctx_lub p ctx = + List.fold_right + (fun {left=left ; right=right} r -> + match right with + | q::rem -> + begin try + {left=left ; right = lub p q::rem}::r + with + | Empty -> r + end + | _ -> fatal_error "Matching.ctx_lub") + ctx [] + +let ctx_match ctx pss = + List.exists + (fun {right=qs} -> List.exists (fun ps -> may_compats qs ps) pss) + ctx + +type jumps = (int * ctx list) list + +let pretty_jumps (env : jumps) = match env with +| [] -> () +| _ -> + List.iter + (fun (i,ctx) -> + Printf.fprintf stderr "jump for %d\n" i ; + pretty_ctx ctx) + env + + +let rec jumps_extract i = function + | [] -> [],[] + | (j,pss) as x::rem as all -> + if i=j then pss,rem + else if j < i then [],all + else + let r,rem = jumps_extract i rem in + r,(x::rem) + +let rec jumps_remove i = function + | [] -> [] + | (j,_)::rem when i=j -> rem + | x::rem -> x::jumps_remove i rem + +let jumps_empty = [] +and jumps_is_empty = function + | [] -> true + | _ -> false + +let jumps_singleton i = function + | [] -> [] + | ctx -> [i,ctx] + +let jumps_add i pss jumps = match pss with +| [] -> jumps +| _ -> + let rec add = function + | [] -> [i,pss] + | (j,qss) as x::rem as all -> + if j > i then x::add rem + else if j < i then (i,pss)::all + else (i,(get_mins le_ctx (pss@qss)))::rem in + add jumps + + +let rec jumps_union (env1:(int*ctx list)list) env2 = match env1,env2 with +| [],_ -> env2 +| _,[] -> env1 +| ((i1,pss1) as x1::rem1), ((i2,pss2) as x2::rem2) -> + if i1=i2 then + (i1,get_mins le_ctx (pss1@pss2))::jumps_union rem1 rem2 + else if i1 > i2 then + x1::jumps_union rem1 env2 + else + x2::jumps_union env1 rem2 + + +let rec merge = function + | env1::env2::rem -> jumps_union env1 env2::merge rem + | envs -> envs + +let rec jumps_unions envs = match envs with + | [] -> [] + | [env] -> env + | _ -> jumps_unions (merge envs) + +let jumps_map f env = + List.map + (fun (i,pss) -> i,f pss) + env + +(* Pattern matching before any compilation *) + +type pattern_matching = + { mutable cases : (pattern list * lambda) list; + args : (lambda * let_kind) list ; + default : (matrix * int) list} + +(* Pattern matching after application of both the or-pat rule and the + mixture rule *) + +type pm_or_compiled = + {body : pattern_matching ; + handlers : + (matrix * int * (Ident.t * Lambda.value_kind) list * pattern_matching) + list; + or_matrix : matrix ; } + +type pm_half_compiled = + | PmOr of pm_or_compiled + | PmVar of pm_var_compiled + | Pm of pattern_matching + +and pm_var_compiled = + {inside : pm_half_compiled ; var_arg : lambda ; } + +type pm_half_compiled_info = + {me : pm_half_compiled ; + matrix : matrix ; + top_default : (matrix * int) list ; } + +let pretty_cases cases = + List.iter + (fun (ps,_l) -> + List.iter + (fun p -> Format.eprintf " %a%!" top_pretty p) + ps ; + Format.eprintf "\n") + cases + +let pretty_def def = + Format.eprintf "+++++ Defaults +++++\n" ; + List.iter + (fun (pss,i) -> Format.eprintf "Matrix for %d\n%a" i pretty_matrix pss) + def ; + Format.eprintf "+++++++++++++++++++++\n" + +let pretty_pm pm = + pretty_cases pm.cases ; + if pm.default <> [] then + pretty_def pm.default + + +let rec pretty_precompiled = function + | Pm pm -> + Format.eprintf "++++ PM ++++\n" ; + pretty_pm pm + | PmVar x -> + Format.eprintf "++++ VAR ++++\n" ; + pretty_precompiled x.inside + | PmOr x -> + Format.eprintf "++++ OR ++++\n" ; + pretty_pm x.body ; + pretty_matrix Format.err_formatter x.or_matrix ; + List.iter + (fun (_,i,_,pm) -> + eprintf "++ Handler %d ++\n" i ; + pretty_pm pm) + x.handlers + +let pretty_precompiled_res first nexts = + pretty_precompiled first ; + List.iter + (fun (e, pmh) -> + eprintf "** DEFAULT %d **\n" e ; + pretty_precompiled pmh) + nexts + + + +(* Identifying some semantically equivalent lambda-expressions, + Our goal here is also to + find alpha-equivalent (simple) terms *) + +(* However, as shown by PR#6359 such sharing may hinders the + lambda-code invariant that all bound idents are unique, + when switches are compiled to test sequences. + The definitive fix is the systematic introduction of exit/catch + in case action sharing is present. +*) + + +module StoreExp = + Switch.Store + (struct + type t = lambda + type key = lambda + let compare_key = Stdlib.compare + let make_key = Lambda.make_key + end) + + +let make_exit i = Lstaticraise (i,[]) + +(* Introduce a catch, if worth it *) +let make_catch d k = match d with +| Lstaticraise (_,[]) -> k d +| _ -> + let e = next_raise_count () in + Lstaticcatch (k (make_exit e),(e,[]),d) + +(* Introduce a catch, if worth it, delayed version *) +let rec as_simple_exit = function + | Lstaticraise (i,[]) -> Some i + | Llet (Alias,_k,_,_,e) -> as_simple_exit e + | _ -> None + + +let make_catch_delayed handler = match as_simple_exit handler with +| Some i -> i,(fun act -> act) +| None -> + let i = next_raise_count () in +(* + Printf.eprintf "SHARE LAMBDA: %i\n%s\n" i (string_of_lam handler); +*) + i, + (fun body -> match body with + | Lstaticraise (j,_) -> + if i=j then handler else body + | _ -> Lstaticcatch (body,(i,[]),handler)) + + +let raw_action l = + match make_key l with | Some l -> l | None -> l + + +let tr_raw act = match make_key act with +| Some act -> act +| None -> raise Exit + +let same_actions = function + | [] -> None + | [_,act] -> Some act + | (_,act0) :: rem -> + try + let raw_act0 = tr_raw act0 in + let rec s_rec = function + | [] -> Some act0 + | (_,act)::rem -> + if raw_act0 = tr_raw act then + s_rec rem + else + None in + s_rec rem + with + | Exit -> None + + +(* Test for swapping two clauses *) + +let up_ok_action act1 act2 = + try + let raw1 = tr_raw act1 + and raw2 = tr_raw act2 in + raw1 = raw2 + with + | Exit -> false + +let up_ok (ps,act_p) l = + List.for_all + (fun (qs,act_q) -> + up_ok_action act_p act_q || not (may_compats ps qs)) + l + +(* + The simplify function normalizes the first column of the match + - records are expanded so that they possess all fields + - aliases are removed and replaced by bindings in actions. + However or-patterns are simplified differently, + - aliases are not removed + - or-patterns (_|p) are changed into _ +*) + +exception Var of pattern + +let simplify_or p = + let rec simpl_rec p = match p with + | {pat_desc = Tpat_any|Tpat_var _} -> raise (Var p) + | {pat_desc = Tpat_alias (q,id,s)} -> + begin try + {p with pat_desc = Tpat_alias (simpl_rec q,id,s)} + with + | Var q -> raise (Var {p with pat_desc = Tpat_alias (q,id,s)}) + end + | {pat_desc = Tpat_or (p1,p2,o)} -> + let q1 = simpl_rec p1 in + begin try + let q2 = simpl_rec p2 in + {p with pat_desc = Tpat_or (q1, q2, o)} + with + | Var q2 -> raise (Var {p with pat_desc = Tpat_or (q1, q2, o)}) + end + | {pat_desc = Tpat_record (lbls,closed)} -> + let all_lbls = all_record_args lbls in + {p with pat_desc=Tpat_record (all_lbls, closed)} + | _ -> p in + try + simpl_rec p + with + | Var p -> p + +let simplify_cases args cls = match args with +| [] -> assert false +| (arg,_)::_ -> + let rec simplify = function + | [] -> [] + | ((pat :: patl, action) as cl) :: rem -> + begin match pat.pat_desc with + | Tpat_var (id, _) -> + let k = Typeopt.value_kind pat.pat_env pat.pat_type in + (omega :: patl, bind_with_value_kind Alias (id, k) arg action) :: + simplify rem + | Tpat_any -> + cl :: simplify rem + | Tpat_alias(p, id,_) -> + let k = Typeopt.value_kind pat.pat_env pat.pat_type in + simplify ((p :: patl, + bind_with_value_kind Alias (id, k) arg action) :: rem) + | Tpat_record ([],_) -> + (omega :: patl, action):: + simplify rem + | Tpat_record (lbls, closed) -> + let all_lbls = all_record_args lbls in + let full_pat = + {pat with pat_desc=Tpat_record (all_lbls, closed)} in + (full_pat::patl,action):: + simplify rem + | Tpat_or _ -> + let pat_simple = simplify_or pat in + begin match pat_simple.pat_desc with + | Tpat_or _ -> + (pat_simple :: patl, action) :: + simplify rem + | _ -> + simplify ((pat_simple::patl,action) :: rem) + end + | _ -> cl :: simplify rem + end + | _ -> assert false in + + simplify cls + + + +(* Once matchings are simplified one can easily find + their nature *) + +let rec what_is_cases cases = match cases with +| ({pat_desc=Tpat_any} :: _, _) :: rem -> what_is_cases rem +| (({pat_desc=(Tpat_var _|Tpat_or (_,_,_)|Tpat_alias (_,_,_))}::_),_)::_ + -> assert false (* applies to simplified matchings only *) +| (p::_,_)::_ -> p +| [] -> omega +| _ -> assert false + + + +(* A few operations on default environments *) +let as_matrix cases = get_mins le_pats (List.map (fun (ps,_) -> ps) cases) + +let cons_default matrix raise_num default = + match matrix with + | [] -> default + | _ -> (matrix,raise_num)::default + +let default_compat p def = + List.fold_right + (fun (pss,i) r -> + let qss = + List.fold_right + (fun qs r -> match qs with + | q::rem when may_compat p q -> rem::r + | _ -> r) + pss [] in + match qss with + | [] -> r + | _ -> (qss,i)::r) + def [] + +(* Or-pattern expansion, variables are a complication w.r.t. the article *) + +exception Cannot_flatten + +let mk_alpha_env arg aliases ids = + List.map + (fun id -> id, + if List.mem id aliases then + match arg with + | Some v -> v + | _ -> raise Cannot_flatten + else + Ident.create_local (Ident.name id)) + ids + +let rec explode_or_pat arg patl mk_action rem vars aliases = function + | {pat_desc = Tpat_or (p1,p2,_)} -> + explode_or_pat + arg patl mk_action + (explode_or_pat arg patl mk_action rem vars aliases p2) + vars aliases p1 + | {pat_desc = Tpat_alias (p,id, _)} -> + explode_or_pat arg patl mk_action rem vars (id::aliases) p + | {pat_desc = Tpat_var (x, _)} -> + let env = mk_alpha_env arg (x::aliases) vars in + (omega::patl,mk_action (List.map snd env))::rem + | p -> + let env = mk_alpha_env arg aliases vars in + (alpha_pat env p::patl,mk_action (List.map snd env))::rem + +let pm_free_variables {cases=cases} = + List.fold_right + (fun (_,act) r -> Ident.Set.union (free_variables act) r) + cases Ident.Set.empty + + +(* Basic grouping predicates *) +let pat_as_constr = function + | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr + | _ -> fatal_error "Matching.pat_as_constr" + +let group_const_int = function + | {pat_desc= Tpat_constant Const_int _ } -> true + | _ -> false + +let group_const_char = function + | {pat_desc= Tpat_constant Const_char _ } -> true + | _ -> false + +let group_const_string = function + | {pat_desc= Tpat_constant Const_string _ } -> true + | _ -> false + +let group_const_float = function + | {pat_desc= Tpat_constant Const_float _ } -> true + | _ -> false + +let group_const_int32 = function + | {pat_desc= Tpat_constant Const_int32 _ } -> true + | _ -> false + +let group_const_int64 = function + | {pat_desc= Tpat_constant Const_int64 _ } -> true + | _ -> false + +let group_const_nativeint = function + | {pat_desc= Tpat_constant Const_nativeint _ } -> true + | _ -> false + +and group_constructor = function + | {pat_desc = Tpat_construct (_,_,_)} -> true + | _ -> false + +and group_variant = function + | {pat_desc = Tpat_variant (_, _, _)} -> true + | _ -> false + +and group_var = function + | {pat_desc=Tpat_any} -> true + | _ -> false + +and group_tuple = function + | {pat_desc = (Tpat_tuple _|Tpat_any)} -> true + | _ -> false + +and group_record = function + | {pat_desc = (Tpat_record _|Tpat_any)} -> true + | _ -> false + +and group_array = function + | {pat_desc=Tpat_array _} -> true + | _ -> false + +and group_lazy = function + | {pat_desc = Tpat_lazy _} -> true + | _ -> false + +let get_group p = match p.pat_desc with +| Tpat_any -> group_var +| Tpat_constant Const_int _ -> group_const_int +| Tpat_constant Const_char _ -> group_const_char +| Tpat_constant Const_string _ -> group_const_string +| Tpat_constant Const_float _ -> group_const_float +| Tpat_constant Const_int32 _ -> group_const_int32 +| Tpat_constant Const_int64 _ -> group_const_int64 +| Tpat_constant Const_nativeint _ -> group_const_nativeint +| Tpat_construct _ -> group_constructor +| Tpat_tuple _ -> group_tuple +| Tpat_record _ -> group_record +| Tpat_array _ -> group_array +| Tpat_variant (_,_,_) -> group_variant +| Tpat_lazy _ -> group_lazy +| _ -> fatal_error "Matching.get_group" + + + +let is_or p = match p.pat_desc with +| Tpat_or _ -> true +| _ -> false + +(* Conditions for appending to the Or matrix *) +let conda p q = not (may_compat p q) +and condb act ps qs = not (is_guarded act) && Parmatch.le_pats qs ps + +let or_ok p ps l = + List.for_all + (function + | ({pat_desc=Tpat_or _} as q::qs,act) -> + conda p q || condb act ps qs + | _ -> true) + l + +(* Insert or append a pattern in the Or matrix *) + +let equiv_pat p q = le_pat p q && le_pat q p + +let rec get_equiv p l = match l with + | (q::_,_) as cl::rem -> + if equiv_pat p q then + let others,rem = get_equiv p rem in + cl::others,rem + else + [],l + | _ -> [],l + + +let insert_or_append p ps act ors no = + let rec attempt seen = function + | (q::qs,act_q) as cl::rem -> + if is_or q then begin + if may_compat p q then + if + Typedtree.pat_bound_idents p = [] && + Typedtree.pat_bound_idents q = [] && + equiv_pat p q + then (* attempt insert, for equivalent orpats with no variables *) + let _, not_e = get_equiv q rem in + if + or_ok p ps not_e && (* check append condition for head of O *) + List.for_all (* check insert condition for tail of O *) + (fun cl -> match cl with + | (q::_,_) -> not (may_compat p q) + | _ -> assert false) + seen + then (* insert *) + List.rev_append seen ((p::ps,act)::cl::rem), no + else (* fail to insert or append *) + ors,(p::ps,act)::no + else if condb act_q ps qs then (* check condition (b) for append *) + attempt (cl::seen) rem + else + ors,(p::ps,act)::no + else (* p # q, go on with append/insert *) + attempt (cl::seen) rem + end else (* q is not an or-pat, go on with append/insert *) + attempt (cl::seen) rem + | _ -> (* [] in fact *) + (p::ps,act)::ors,no in (* success in appending *) + attempt [] ors + +(* Reconstruct default information from half_compiled pm list *) + +let rec rebuild_matrix pmh = match pmh with + | Pm pm -> as_matrix pm.cases + | PmOr {or_matrix=m} -> m + | PmVar x -> add_omega_column (rebuild_matrix x.inside) + +let rec rebuild_default nexts def = match nexts with +| [] -> def +| (e, pmh)::rem -> + (add_omega_column (rebuild_matrix pmh), e):: + rebuild_default rem def + +let rebuild_nexts arg nexts k = + List.fold_right + (fun (e, pm) k -> (e, PmVar {inside=pm ; var_arg=arg})::k) + nexts k + + +(* + Split a matching. + Splitting is first directed by or-patterns, then by + tests (e.g. constructors)/variable transitions. + + The approach is greedy, every split function attempts to + raise rows as much as possible in the top matrix, + then splitting applies again to the remaining rows. + + Some precompilation of or-patterns and + variable pattern occurs. Mostly this means that bindings + are performed now, being replaced by let-bindings + in actions (cf. simplify_cases). + + Additionally, if the match argument is a variable, matchings whose + first column is made of variables only are split further + (cf. precompile_var). + +*) + + +let rec split_or argo cls args def = + + let cls = simplify_cases args cls in + + let rec do_split before ors no = function + | [] -> + cons_next + (List.rev before) (List.rev ors) (List.rev no) + | ((p::ps,act) as cl)::rem -> + if up_ok cl no then + if is_or p then + let ors, no = insert_or_append p ps act ors no in + do_split before ors no rem + else begin + if up_ok cl ors then + do_split (cl::before) ors no rem + else if or_ok p ps ors then + do_split before (cl::ors) no rem + else + do_split before ors (cl::no) rem + end + else + do_split before ors (cl::no) rem + | _ -> assert false + + and cons_next yes yesor = function + | [] -> + precompile_or argo yes yesor args def [] + | rem -> + let {me=next ; matrix=matrix ; top_default=def},nexts = + do_split [] [] [] rem in + let idef = next_raise_count () in + precompile_or + argo yes yesor args + (cons_default matrix idef def) + ((idef,next)::nexts) in + + do_split [] [] [] cls + +(* Ultra-naive splitting, close to semantics, used for extension, + as potential rebind prevents any kind of optimisation *) + +and split_naive cls args def k = + + let rec split_exc cstr0 yes = function + | [] -> + let yes = List.rev yes in + { me = Pm {cases=yes; args=args; default=def;} ; + matrix = as_matrix yes ; + top_default=def}, + k + | (p::_,_ as cl)::rem -> + if group_constructor p then + let cstr = pat_as_constr p in + if cstr = cstr0 then split_exc cstr0 (cl::yes) rem + else + let yes = List.rev yes in + let {me=next ; matrix=matrix ; top_default=def}, nexts = + split_exc cstr [cl] rem in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + { me = Pm {cases=yes; args=args; default=def} ; + matrix = as_matrix yes ; + top_default = def; }, + (idef,next)::nexts + else + let yes = List.rev yes in + let {me=next ; matrix=matrix ; top_default=def}, nexts = + split_noexc [cl] rem in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + { me = Pm {cases=yes; args=args; default=def} ; + matrix = as_matrix yes ; + top_default = def; }, + (idef,next)::nexts + | _ -> assert false + + and split_noexc yes = function + | [] -> precompile_var args (List.rev yes) def k + | (p::_,_ as cl)::rem -> + if group_constructor p then + let yes= List.rev yes in + let {me=next; matrix=matrix; top_default=def;},nexts = + split_exc (pat_as_constr p) [cl] rem in + let idef = next_raise_count () in + precompile_var + args yes + (cons_default matrix idef def) + ((idef,next)::nexts) + else split_noexc (cl::yes) rem + | _ -> assert false in + + match cls with + | [] -> assert false + | (p::_,_ as cl)::rem -> + if group_constructor p then + split_exc (pat_as_constr p) [cl] rem + else + split_noexc [cl] rem + | _ -> assert false + +and split_constr cls args def k = + let ex_pat = what_is_cases cls in + match ex_pat.pat_desc with + | Tpat_any -> precompile_var args cls def k + | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> + split_naive cls args def k + | _ -> + + let group = get_group ex_pat in + + let rec split_ex yes no = function + | [] -> + let yes = List.rev yes and no = List.rev no in + begin match no with + | [] -> + {me = Pm {cases=yes ; args=args ; default=def} ; + matrix = as_matrix yes ; + top_default = def}, + k + | cl::rem -> + begin match yes with + | [] -> + (* Could not success in raising up a constr matching up *) + split_noex [cl] [] rem + | _ -> + let {me=next ; matrix=matrix ; top_default=def}, nexts = + split_noex [cl] [] rem in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + {me = Pm {cases=yes ; args=args ; default=def} ; + matrix = as_matrix yes ; + top_default = def }, + (idef, next)::nexts + end + end + | (p::_,_) as cl::rem -> + if group p && up_ok cl no then + split_ex (cl::yes) no rem + else + split_ex yes (cl::no) rem + | _ -> assert false + + and split_noex yes no = function + | [] -> + let yes = List.rev yes and no = List.rev no in + begin match no with + | [] -> precompile_var args yes def k + | cl::rem -> + let {me=next ; matrix=matrix ; top_default=def}, nexts = + split_ex [cl] [] rem in + let idef = next_raise_count () in + precompile_var + args yes + (cons_default matrix idef def) + ((idef,next)::nexts) + end + | [ps,_ as cl] + when List.for_all group_var ps && yes <> [] -> + (* This enables an extra division in some frequent cases : + last row is made of variables only *) + split_noex yes (cl::no) [] + | (p::_,_) as cl::rem -> + if not (group p) && up_ok cl no then + split_noex (cl::yes) no rem + else + split_noex yes (cl::no) rem + | _ -> assert false in + + match cls with + | ((p::_,_) as cl)::rem -> + if group p then split_ex [cl] [] rem + else split_noex [cl] [] rem + | _ -> assert false + +and precompile_var args cls def k = match args with +| [] -> assert false +| _::((Lvar v as av,_) as arg)::rargs -> + begin match cls with + | [_] -> (* as split as it can *) + dont_precompile_var args cls def k + | _ -> +(* Precompile *) + let var_cls = + List.map + (fun (ps,act) -> match ps with + | _::ps -> ps,act | _ -> assert false) + cls + and var_def = make_default (fun _ rem -> rem) def in + let {me=first ; matrix=matrix}, nexts = + split_or (Some v) var_cls (arg::rargs) var_def in + +(* Compute top information *) + match nexts with + | [] -> (* If you need *) + dont_precompile_var args cls def k + | _ -> + let rfirst = + {me = PmVar {inside=first ; var_arg = av} ; + matrix = add_omega_column matrix ; + top_default = rebuild_default nexts def ; } + and rnexts = rebuild_nexts av nexts k in + rfirst, rnexts + end +| _ -> + dont_precompile_var args cls def k + +and dont_precompile_var args cls def k = + {me = Pm {cases = cls ; args = args ; default = def } ; + matrix=as_matrix cls ; + top_default=def},k + +and precompile_or argo cls ors args def k = match ors with +| [] -> split_constr cls args def k +| _ -> + let rec do_cases = function + | ({pat_desc=Tpat_or _} as orp::patl, action)::rem -> + let others,rem = get_equiv orp rem in + let orpm = + {cases = + (patl, action):: + List.map + (function + | (_::ps,action) -> ps,action + | _ -> assert false) + others ; + args = (match args with _::r -> r | _ -> assert false) ; + default = default_compat orp def} in + let pm_fv = pm_free_variables orpm in + let vars = + Typedtree.pat_bound_idents_full orp + |> List.filter (fun (id, _, _) -> Ident.Set.mem id pm_fv) + |> List.map (fun (id,_,ty) -> id,Typeopt.value_kind orp.pat_env ty) + in + let or_num = next_raise_count () in + let new_patl = Parmatch.omega_list patl in + + let mk_new_action vs = + Lstaticraise + (or_num, List.map (fun v -> Lvar v) vs) in + + let body,handlers = do_cases rem in + explode_or_pat + argo new_patl mk_new_action body (List.map fst vars) [] orp, + let mat = [[orp]] in + ((mat, or_num, vars , orpm):: handlers) + | cl::rem -> + let new_ord,new_to_catch = do_cases rem in + cl::new_ord,new_to_catch + | [] -> [],[] in + + let end_body, handlers = do_cases ors in + let matrix = as_matrix (cls@ors) + and body = {cases=cls@end_body ; args=args ; default=def} in + {me = PmOr {body=body ; handlers=handlers ; or_matrix=matrix} ; + matrix=matrix ; + top_default=def}, + k + +let split_precompile argo pm = + let {me=next}, nexts = split_or argo pm.cases pm.args pm.default in + if dbg && (nexts <> [] || (match next with PmOr _ -> true | _ -> false)) + then begin + Format.eprintf "** SPLIT **\n" ; + pretty_pm pm ; + pretty_precompiled_res next nexts + end ; + next, nexts + + +(* General divide functions *) + +let add_line patl_action pm = pm.cases <- patl_action :: pm.cases; pm + +type cell = + {pm : pattern_matching ; + ctx : ctx list ; + pat : pattern} + +let add make_matching_fun division eq_key key patl_action args = + try + let (_,cell) = List.find (fun (k,_) -> eq_key key k) division in + cell.pm.cases <- patl_action :: cell.pm.cases; + division + with Not_found -> + let cell = make_matching_fun args in + cell.pm.cases <- [patl_action] ; + (key, cell) :: division + + +let divide make eq_key get_key get_args ctx pm = + + let rec divide_rec = function + | (p::patl,action) :: rem -> + let this_match = divide_rec rem in + add + (make p pm.default ctx) + this_match eq_key (get_key p) (get_args p patl,action) pm.args + | _ -> [] in + + divide_rec pm.cases + + +let divide_line make_ctx make get_args pat ctx pm = + let rec divide_rec = function + | (p::patl,action) :: rem -> + let this_match = divide_rec rem in + add_line (get_args p patl, action) this_match + | _ -> make pm.default pm.args in + + {pm = divide_rec pm.cases ; + ctx=make_ctx ctx ; + pat=pat} + + + +(* Then come various functions, + There is one set of functions per matching style + (constants, constructors etc.) + + - matcher functions are arguments to make_default (for default handlers) + They may raise NoMatch or OrPat and perform the full + matching (selection + arguments). + + + - get_args and get_key are for the compiled matrices, note that + selection and getting arguments are separated. + + - make_ _matching combines the previous functions for producing + new ``pattern_matching'' records. +*) + + + +let rec matcher_const cst p rem = match p.pat_desc with +| Tpat_or (p1,p2,_) -> + begin try + matcher_const cst p1 rem with + | NoMatch -> matcher_const cst p2 rem + end +| Tpat_constant c1 when const_compare c1 cst = 0 -> rem +| Tpat_any -> rem +| _ -> raise NoMatch + +let get_key_constant caller = function + | {pat_desc= Tpat_constant cst} -> cst + | p -> + Format.eprintf "BAD: %s" caller ; + pretty_pat p ; + assert false + +let get_args_constant _ rem = rem + +let make_constant_matching p def ctx = function + [] -> fatal_error "Matching.make_constant_matching" + | (_ :: argl) -> + let def = + make_default + (matcher_const (get_key_constant "make" p)) def + and ctx = + filter_ctx p ctx in + {pm = {cases = []; args = argl ; default = def} ; + ctx = ctx ; + pat = normalize_pat p} + + + + +let divide_constant ctx m = + divide + make_constant_matching + (fun c d -> const_compare c d = 0) (get_key_constant "divide") + get_args_constant + ctx m + +(* Matching against a constructor *) + + +let make_field_args loc binding_kind arg first_pos last_pos argl = + let rec make_args pos = + if pos > last_pos + then argl + else (Lprim(Pfield pos, [arg], loc), binding_kind) :: make_args (pos + 1) + in make_args first_pos + +let get_key_constr = function + | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr.cstr_tag + | _ -> assert false + +let get_args_constr p rem = match p with +| {pat_desc=Tpat_construct (_, _, args)} -> args @ rem +| _ -> assert false + +(* NB: matcher_constr applies to default matrices. + + In that context, matching by constructors of extensible + types degrades to arity checking, due to potential rebinding. + This comparison is performed by Types.may_equal_constr. +*) + +let matcher_constr cstr = match cstr.cstr_arity with +| 0 -> + let rec matcher_rec q rem = match q.pat_desc with + | Tpat_or (p1,p2,_) -> + begin + try matcher_rec p1 rem + with NoMatch -> matcher_rec p2 rem + end + | Tpat_construct (_, cstr',[]) + when Types.may_equal_constr cstr cstr' -> rem + | Tpat_any -> rem + | _ -> raise NoMatch in + matcher_rec +| 1 -> + let rec matcher_rec q rem = match q.pat_desc with + | Tpat_or (p1,p2,_) -> + let r1 = try Some (matcher_rec p1 rem) with NoMatch -> None + and r2 = try Some (matcher_rec p2 rem) with NoMatch -> None in + begin match r1,r2 with + | None, None -> raise NoMatch + | Some r1, None -> r1 + | None, Some r2 -> r2 + | Some (a1::_), Some (a2::_) -> + {a1 with + pat_loc = Location.none ; + pat_desc = Tpat_or (a1, a2, None)}:: + rem + | _, _ -> assert false + end + | Tpat_construct (_, cstr', [arg]) + when Types.may_equal_constr cstr cstr' -> arg::rem + | Tpat_any -> omega::rem + | _ -> raise NoMatch in + matcher_rec +| _ -> + fun q rem -> match q.pat_desc with + | Tpat_or (_,_,_) -> raise OrPat + | Tpat_construct (_,cstr',args) + when Types.may_equal_constr cstr cstr' -> args @ rem + | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem + | _ -> raise NoMatch + +let make_constr_matching p def ctx = function + [] -> fatal_error "Matching.make_constr_matching" + | ((arg, _mut) :: argl) -> + let cstr = pat_as_constr p in + let newargs = + if cstr.cstr_inlined <> None then + (arg, Alias) :: argl + else match cstr.cstr_tag with + Cstr_constant _ | Cstr_block _ -> + make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl + | Cstr_unboxed -> (arg, Alias) :: argl + | Cstr_extension _ -> + make_field_args p.pat_loc Alias arg 1 cstr.cstr_arity argl in + {pm= + {cases = []; args = newargs; + default = make_default (matcher_constr cstr) def} ; + ctx = filter_ctx p ctx ; + pat=normalize_pat p} + + +let divide_constructor ctx pm = + divide + make_constr_matching + (=) get_key_constr get_args_constr + ctx pm + +(* Matching against a variant *) + +let rec matcher_variant_const lab p rem = match p.pat_desc with +| Tpat_or (p1, p2, _) -> + begin + try + matcher_variant_const lab p1 rem + with + | NoMatch -> matcher_variant_const lab p2 rem + end +| Tpat_variant (lab1,_,_) when lab1=lab -> rem +| Tpat_any -> rem +| _ -> raise NoMatch + + +let make_variant_matching_constant p lab def ctx = function + [] -> fatal_error "Matching.make_variant_matching_constant" + | (_ :: argl) -> + let def = make_default (matcher_variant_const lab) def + and ctx = filter_ctx p ctx in + {pm={ cases = []; args = argl ; default=def} ; + ctx=ctx ; + pat = normalize_pat p} + +let matcher_variant_nonconst lab p rem = match p.pat_desc with +| Tpat_or (_,_,_) -> raise OrPat +| Tpat_variant (lab1,Some arg,_) when lab1=lab -> arg::rem +| Tpat_any -> omega::rem +| _ -> raise NoMatch + + +let make_variant_matching_nonconst p lab def ctx = function + [] -> fatal_error "Matching.make_variant_matching_nonconst" + | ((arg, _mut) :: argl) -> + let def = make_default (matcher_variant_nonconst lab) def + and ctx = filter_ctx p ctx in + {pm= + {cases = []; args = (Lprim(Pfield 1, [arg], p.pat_loc), Alias) :: argl; + default=def} ; + ctx=ctx ; + pat = normalize_pat p} + +let divide_variant row ctx {cases = cl; args = al; default=def} = + let row = Btype.row_repr row in + let rec divide = function + ({pat_desc = Tpat_variant(lab, pato, _)} as p:: patl, action) :: rem -> + let variants = divide rem in + if try Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent + with Not_found -> true + then + variants + else begin + let tag = Btype.hash_variant lab in + match pato with + None -> + add (make_variant_matching_constant p lab def ctx) variants + (=) (Cstr_constant tag) (patl, action) al + | Some pat -> + add (make_variant_matching_nonconst p lab def ctx) variants + (=) (Cstr_block tag) (pat :: patl, action) al + end + | _ -> [] + in + divide cl + +(* + Three ``no-test'' cases + *) + +(* Matching against a variable *) + +let get_args_var _ rem = rem + + +let make_var_matching def = function + | [] -> fatal_error "Matching.make_var_matching" + | _::argl -> + {cases=[] ; + args = argl ; + default= make_default get_args_var def} + +let divide_var ctx pm = + divide_line ctx_lshift make_var_matching get_args_var omega ctx pm + +(* Matching and forcing a lazy value *) + +let get_arg_lazy p rem = match p with +| {pat_desc = Tpat_any} -> omega :: rem +| {pat_desc = Tpat_lazy arg} -> arg :: rem +| _ -> assert false + +let matcher_lazy p rem = match p.pat_desc with +| Tpat_or (_,_,_) -> raise OrPat +| Tpat_any +| Tpat_var _ -> omega :: rem +| Tpat_lazy arg -> arg :: rem +| _ -> raise NoMatch + +(* Inlining the tag tests before calling the primitive that works on + lazy blocks. This is also used in translcore.ml. + No other call than Obj.tag when the value has been forced before. +*) + +let prim_obj_tag = + Primitive.simple ~name:"caml_obj_tag" ~arity:1 ~alloc:false + +let get_mod_field modname field = + lazy ( + let mod_ident = Ident.create_persistent modname in + let env = Env.add_persistent_structure mod_ident Env.initial_safe_string in + match Env.open_pers_signature modname env with + | exception Not_found -> fatal_error ("Module "^modname^" unavailable.") + | env -> begin + match Env.lookup_value (Longident.Lident field) env with + | exception Not_found -> + fatal_error ("Primitive "^modname^"."^field^" not found.") + | (path, _) -> transl_value_path Location.none env path + end + ) + +let code_force_lazy_block = + get_mod_field "CamlinternalLazy" "force_lazy_block" +let code_force_lazy = + get_mod_field "CamlinternalLazy" "force" +;; + +(* inline_lazy_force inlines the beginning of the code of Lazy.force. When + the value argument is tagged as: + - forward, take field 0 + - lazy, call the primitive that forces (without testing again the tag) + - anything else, return it + + Using Lswitch below relies on the fact that the GC does not shortcut + Forward(val_out_of_heap). +*) + +let inline_lazy_force_cond arg loc = + let idarg = Ident.create_local "lzarg" in + let varg = Lvar idarg in + let tag = Ident.create_local "tag" in + let force_fun = Lazy.force code_force_lazy_block in + Llet(Strict, Pgenval, idarg, arg, + Llet(Alias, Pgenval, tag, Lprim(Pccall prim_obj_tag, [varg], loc), + Lifthenelse( + (* if (tag == Obj.forward_tag) then varg.(0) else ... *) + Lprim(Pintcomp Ceq, + [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))], + loc), + Lprim(Pfield 0, [varg], loc), + Lifthenelse( + (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *) + Lprim(Pintcomp Ceq, + [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))], + loc), + Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=force_fun; + ap_args=[varg]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}, + (* ... arg *) + varg)))) + +let inline_lazy_force_switch arg loc = + let idarg = Ident.create_local "lzarg" in + let varg = Lvar idarg in + let force_fun = Lazy.force code_force_lazy_block in + Llet(Strict, Pgenval, idarg, arg, + Lifthenelse( + Lprim(Pisint, [varg], loc), varg, + (Lswitch + (varg, + { sw_numconsts = 0; sw_consts = []; + sw_numblocks = 256; (* PR#6033 - tag ranges from 0 to 255 *) + sw_blocks = + [ (Obj.forward_tag, Lprim(Pfield 0, [varg], loc)); + (Obj.lazy_tag, + Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=force_fun; + ap_args=[varg]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}) ]; + sw_failaction = Some varg }, loc )))) + +let inline_lazy_force arg loc = + if !Clflags.afl_instrument then + (* Disable inlining optimisation if AFL instrumentation active, + so that the GC forwarding optimisation is not visible in the + instrumentation output. + (see https://github.com/stedolan/crowbar/issues/14) *) + Lapply{ap_should_be_tailcall = false; + ap_loc=loc; + ap_func=Lazy.force code_force_lazy; + ap_args=[arg]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} + else + if !Clflags.native_code then + (* Lswitch generates compact and efficient native code *) + inline_lazy_force_switch arg loc + else + (* generating bytecode: Lswitch would generate too many rather big + tables (~ 250 elts); conditionals are better *) + inline_lazy_force_cond arg loc + +let make_lazy_matching def = function + [] -> fatal_error "Matching.make_lazy_matching" + | (arg,_mut) :: argl -> + { cases = []; + args = + (inline_lazy_force arg Location.none, Strict) :: argl; + default = make_default matcher_lazy def } + +let divide_lazy p ctx pm = + divide_line + (filter_ctx p) + make_lazy_matching + get_arg_lazy + p ctx pm + +(* Matching against a tuple pattern *) + + +let get_args_tuple arity p rem = match p with +| {pat_desc = Tpat_any} -> omegas arity @ rem +| {pat_desc = Tpat_tuple args} -> + args @ rem +| _ -> assert false + +let matcher_tuple arity p rem = match p.pat_desc with +| Tpat_or (_,_,_) -> raise OrPat +| Tpat_any +| Tpat_var _ -> omegas arity @ rem +| Tpat_tuple args when List.length args = arity -> args @ rem +| _ -> raise NoMatch + +let make_tuple_matching loc arity def = function + [] -> fatal_error "Matching.make_tuple_matching" + | (arg, _mut) :: argl -> + let rec make_args pos = + if pos >= arity + then argl + else (Lprim(Pfield pos, [arg], loc), Alias) :: make_args (pos + 1) in + {cases = []; args = make_args 0 ; + default=make_default (matcher_tuple arity) def} + + +let divide_tuple arity p ctx pm = + divide_line + (filter_ctx p) + (make_tuple_matching p.pat_loc arity) + (get_args_tuple arity) p ctx pm + +(* Matching against a record pattern *) + + +let record_matching_line num_fields lbl_pat_list = + let patv = Array.make num_fields omega in + List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; + Array.to_list patv + +let get_args_record num_fields p rem = match p with +| {pat_desc=Tpat_any} -> + record_matching_line num_fields [] @ rem +| {pat_desc=Tpat_record (lbl_pat_list,_)} -> + record_matching_line num_fields lbl_pat_list @ rem +| _ -> assert false + +let matcher_record num_fields p rem = match p.pat_desc with +| Tpat_or (_,_,_) -> raise OrPat +| Tpat_any +| Tpat_var _ -> + record_matching_line num_fields [] @ rem +| Tpat_record ([], _) when num_fields = 0 -> rem +| Tpat_record ((_, lbl, _) :: _ as lbl_pat_list, _) + when Array.length lbl.lbl_all = num_fields -> + record_matching_line num_fields lbl_pat_list @ rem +| _ -> raise NoMatch + +let make_record_matching loc all_labels def = function + [] -> fatal_error "Matching.make_record_matching" + | ((arg, _mut) :: argl) -> + let rec make_args pos = + if pos >= Array.length all_labels then argl else begin + let lbl = all_labels.(pos) in + let access = + match lbl.lbl_repres with + | Record_regular | Record_inlined _ -> + Lprim (Pfield lbl.lbl_pos, [arg], loc) + | Record_unboxed _ -> arg + | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [arg], loc) + | Record_extension _ -> Lprim (Pfield (lbl.lbl_pos + 1), [arg], loc) + in + let str = + match lbl.lbl_mut with + Immutable -> Alias + | Mutable -> StrictOpt in + (access, str) :: make_args(pos + 1) + end in + let nfields = Array.length all_labels in + let def= make_default (matcher_record nfields) def in + {cases = []; args = make_args 0 ; default = def} + + +let divide_record all_labels p ctx pm = + let get_args = get_args_record (Array.length all_labels) in + divide_line + (filter_ctx p) + (make_record_matching p.pat_loc all_labels) + get_args + p ctx pm + +(* Matching against an array pattern *) + +let get_key_array = function + | {pat_desc=Tpat_array patl} -> List.length patl + | _ -> assert false + +let get_args_array p rem = match p with +| {pat_desc=Tpat_array patl} -> patl@rem +| _ -> assert false + +let matcher_array len p rem = match p.pat_desc with +| Tpat_or (_,_,_) -> raise OrPat +| Tpat_array args when List.length args=len -> args @ rem +| Tpat_any -> Parmatch.omegas len @ rem +| _ -> raise NoMatch + +let make_array_matching kind p def ctx = function + | [] -> fatal_error "Matching.make_array_matching" + | ((arg, _mut) :: argl) -> + let len = get_key_array p in + let rec make_args pos = + if pos >= len + then argl + else (Lprim(Parrayrefu kind, + [arg; Lconst(Const_base(Const_int pos))], + p.pat_loc), + StrictOpt) :: make_args (pos + 1) in + let def = make_default (matcher_array len) def + and ctx = filter_ctx p ctx in + {pm={cases = []; args = make_args 0 ; default = def} ; + ctx=ctx ; + pat = normalize_pat p} + +let divide_array kind ctx pm = + divide + (make_array_matching kind) + (=) get_key_array get_args_array ctx pm + + +(* + Specific string test sequence + Will be called by the bytecode compiler, from bytegen.ml. + The strategy is first dichotomic search (we perform 3-way tests + with compare_string), then sequence of equality tests + when there are less then T=strings_test_threshold static strings to match. + + Increasing T entails (slightly) less code, decreasing T + (slightly) favors runtime speed. + T=8 looks a decent tradeoff. +*) + +(* Utilities *) + +let strings_test_threshold = 8 + +let prim_string_notequal = + Pccall(Primitive.simple + ~name:"caml_string_notequal" + ~arity:2 + ~alloc:false) + +let prim_string_compare = + Pccall(Primitive.simple + ~name:"caml_string_compare" + ~arity:2 + ~alloc:false) + +let bind_sw arg k = match arg with +| Lvar _ -> k arg +| _ -> + let id = Ident.create_local "switch" in + Llet (Strict,Pgenval,id,arg,k (Lvar id)) + + +(* Sequential equality tests *) + +let make_string_test_sequence loc arg sw d = + let d,sw = match d with + | None -> + begin match sw with + | (_,d)::sw -> d,sw + | [] -> assert false + end + | Some d -> d,sw in + bind_sw arg + (fun arg -> + List.fold_right + (fun (s,lam) k -> + Lifthenelse + (Lprim + (prim_string_notequal, + [arg; Lconst (Const_immstring s)], loc), + k,lam)) + sw d) + +let rec split k xs = match xs with +| [] -> assert false +| x0::xs -> + if k <= 1 then [],x0,xs + else + let xs,y0,ys = split (k-2) xs in + x0::xs,y0,ys + +let zero_lam = Lconst (Const_base (Const_int 0)) + +let tree_way_test loc arg lt eq gt = + Lifthenelse + (Lprim (Pintcomp Clt,[arg;zero_lam], loc),lt, + Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg], loc),gt,eq)) + +(* Dichotomic tree *) + + +let rec do_make_string_test_tree loc arg sw delta d = + let len = List.length sw in + if len <= strings_test_threshold+delta then + make_string_test_sequence loc arg sw d + else + let lt,(s,act),gt = split len sw in + bind_sw + (Lprim + (prim_string_compare, + [arg; Lconst (Const_immstring s)], loc)) + (fun r -> + tree_way_test loc r + (do_make_string_test_tree loc arg lt delta d) + act + (do_make_string_test_tree loc arg gt delta d)) + +(* Entry point *) +let expand_stringswitch loc arg sw d = match d with +| None -> + bind_sw arg + (fun arg -> do_make_string_test_tree loc arg sw 0 None) +| Some e -> + bind_sw arg + (fun arg -> + make_catch e + (fun d -> do_make_string_test_tree loc arg sw 1 (Some d))) + +(**********************) +(* Generic test trees *) +(**********************) + +(* Sharing *) + +(* Add handler, if shared *) +let handle_shared () = + let hs = ref (fun x -> x) in + let handle_shared act = match act with + | Switch.Single act -> act + | Switch.Shared act -> + let i,h = make_catch_delayed act in + let ohs = !hs in + hs := (fun act -> h (ohs act)) ; + make_exit i in + hs,handle_shared + + +let share_actions_tree sw d = + let store = StoreExp.mk_store () in +(* Default action is always shared *) + let d = + match d with + | None -> None + | Some d -> Some (store.Switch.act_store_shared () d) in +(* Store all other actions *) + let sw = + List.map (fun (cst,act) -> cst,store.Switch.act_store () act) sw in + +(* Retrieve all actions, including potential default *) + let acts = store.Switch.act_get_shared () in + +(* Array of actual actions *) + let hs,handle_shared = handle_shared () in + let acts = Array.map handle_shared acts in + +(* Reconstruct default and switch list *) + let d = match d with + | None -> None + | Some d -> Some (acts.(d)) in + let sw = List.map (fun (cst,j) -> cst,acts.(j)) sw in + !hs,sw,d + +(* Note: dichotomic search requires sorted input with no duplicates *) +let rec uniq_lambda_list sw = match sw with + | []|[_] -> sw + | (c1,_ as p1)::((c2,_)::sw2 as sw1) -> + if const_compare c1 c2 = 0 then uniq_lambda_list (p1::sw2) + else p1::uniq_lambda_list sw1 + +let sort_lambda_list l = + let l = + List.stable_sort (fun (x,_) (y,_) -> const_compare x y) l in + uniq_lambda_list l + +let rec cut n l = + if n = 0 then [],l + else match l with + [] -> raise (Invalid_argument "cut") + | a::l -> let l1,l2 = cut (n-1) l in a::l1, l2 + +let rec do_tests_fail loc fail tst arg = function + | [] -> fail + | (c, act)::rem -> + Lifthenelse + (Lprim (tst, [arg ; Lconst (Const_base c)], loc), + do_tests_fail loc fail tst arg rem, + act) + +let rec do_tests_nofail loc tst arg = function + | [] -> fatal_error "Matching.do_tests_nofail" + | [_,act] -> act + | (c,act)::rem -> + Lifthenelse + (Lprim (tst, [arg ; Lconst (Const_base c)], loc), + do_tests_nofail loc tst arg rem, + act) + +let make_test_sequence loc fail tst lt_tst arg const_lambda_list = + let const_lambda_list = sort_lambda_list const_lambda_list in + let hs,const_lambda_list,fail = + share_actions_tree const_lambda_list fail in + + let rec make_test_sequence const_lambda_list = + if List.length const_lambda_list >= 4 && lt_tst <> Pignore then + split_sequence const_lambda_list + else match fail with + | None -> do_tests_nofail loc tst arg const_lambda_list + | Some fail -> do_tests_fail loc fail tst arg const_lambda_list + + and split_sequence const_lambda_list = + let list1, list2 = + cut (List.length const_lambda_list / 2) const_lambda_list in + Lifthenelse(Lprim(lt_tst, + [arg; Lconst(Const_base (fst(List.hd list2)))], + loc), + make_test_sequence list1, make_test_sequence list2) + in + hs (make_test_sequence const_lambda_list) + + +module SArg = struct + type primitive = Lambda.primitive + + let eqint = Pintcomp Ceq + let neint = Pintcomp Cne + let leint = Pintcomp Cle + let ltint = Pintcomp Clt + let geint = Pintcomp Cge + let gtint = Pintcomp Cgt + + type act = Lambda.lambda + + let make_prim p args = Lprim (p,args,Location.none) + let make_offset arg n = match n with + | 0 -> arg + | _ -> Lprim (Poffsetint n,[arg],Location.none) + + let bind arg body = + let newvar,newarg = match arg with + | Lvar v -> v,arg + | _ -> + let newvar = Ident.create_local "switcher" in + newvar,Lvar newvar in + bind Alias newvar arg (body newarg) + let make_const i = Lconst (Const_base (Const_int i)) + let make_isout h arg = Lprim (Pisout, [h ; arg],Location.none) + let make_isin h arg = Lprim (Pnot,[make_isout h arg],Location.none) + let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) + let make_switch loc arg cases acts = + let l = ref [] in + for i = Array.length cases-1 downto 0 do + l := (i,acts.(cases.(i))) :: !l + done ; + Lswitch(arg, + {sw_numconsts = Array.length cases ; sw_consts = !l ; + sw_numblocks = 0 ; sw_blocks = [] ; + sw_failaction = None}, loc) + let make_catch = make_catch_delayed + let make_exit = make_exit + +end + +(* Action sharing for Lswitch argument *) +let share_actions_sw sw = +(* Attempt sharing on all actions *) + let store = StoreExp.mk_store () in + let fail = match sw.sw_failaction with + | None -> None + | Some fail -> + (* Fail is translated to exit, whatever happens *) + Some (store.Switch.act_store_shared () fail) in + let consts = + List.map + (fun (i,e) -> i,store.Switch.act_store () e) + sw.sw_consts + and blocks = + List.map + (fun (i,e) -> i,store.Switch.act_store () e) + sw.sw_blocks in + let acts = store.Switch.act_get_shared () in + let hs,handle_shared = handle_shared () in + let acts = Array.map handle_shared acts in + let fail = match fail with + | None -> None + | Some fail -> Some (acts.(fail)) in + !hs, + { sw with + sw_consts = List.map (fun (i,j) -> i,acts.(j)) consts ; + sw_blocks = List.map (fun (i,j) -> i,acts.(j)) blocks ; + sw_failaction = fail; } + +(* Reintroduce fail action in switch argument, + for the sake of avoiding carrying over huge switches *) + +let reintroduce_fail sw = match sw.sw_failaction with +| None -> + let t = Hashtbl.create 17 in + let seen (_,l) = match as_simple_exit l with + | Some i -> + let old = try Hashtbl.find t i with Not_found -> 0 in + Hashtbl.replace t i (old+1) + | None -> () in + List.iter seen sw.sw_consts ; + List.iter seen sw.sw_blocks ; + let i_max = ref (-1) + and max = ref (-1) in + Hashtbl.iter + (fun i c -> + if c > !max then begin + i_max := i ; + max := c + end) t ; + if !max >= 3 then + let default = !i_max in + let remove = + List.filter + (fun (_,lam) -> match as_simple_exit lam with + | Some j -> j <> default + | None -> true) in + {sw with + sw_consts = remove sw.sw_consts ; + sw_blocks = remove sw.sw_blocks ; + sw_failaction = Some (make_exit default)} + else sw +| Some _ -> sw + + +module Switcher = Switch.Make(SArg) +open Switch + +let rec last def = function + | [] -> def + | [x,_] -> x + | _::rem -> last def rem + +let get_edges low high l = match l with +| [] -> low, high +| (x,_)::_ -> x, last high l + + +let as_interval_canfail fail low high l = + let store = StoreExp.mk_store () in + + let do_store _tag act = + + let i = store.act_store () act in +(* + eprintf "STORE [%s] %i %s\n" tag i (string_of_lam act) ; +*) + i in + + let rec nofail_rec cur_low cur_high cur_act = function + | [] -> + if cur_high = high then + [cur_low,cur_high,cur_act] + else + [(cur_low,cur_high,cur_act) ; (cur_high+1,high, 0)] + | ((i,act_i)::rem) as all -> + let act_index = do_store "NO" act_i in + if cur_high+1= i then + if act_index=cur_act then + nofail_rec cur_low i cur_act rem + else if act_index=0 then + (cur_low,i-1, cur_act)::fail_rec i i rem + else + (cur_low, i-1, cur_act)::nofail_rec i i act_index rem + else if act_index = 0 then + (cur_low, cur_high, cur_act):: + fail_rec (cur_high+1) (cur_high+1) all + else + (cur_low, cur_high, cur_act):: + (cur_high+1,i-1,0):: + nofail_rec i i act_index rem + + and fail_rec cur_low cur_high = function + | [] -> [(cur_low, cur_high, 0)] + | (i,act_i)::rem -> + let index = do_store "YES" act_i in + if index=0 then fail_rec cur_low i rem + else + (cur_low,i-1,0):: + nofail_rec i i index rem in + + let init_rec = function + | [] -> [low,high,0] + | (i,act_i)::rem -> + let index = do_store "INIT" act_i in + if index=0 then + fail_rec low i rem + else + if low < i then + (low,i-1,0)::nofail_rec i i index rem + else + nofail_rec i i index rem in + + assert (do_store "FAIL" fail = 0) ; (* fail has action index 0 *) + let r = init_rec l in + Array.of_list r, store + +let as_interval_nofail l = + let store = StoreExp.mk_store () in + let rec some_hole = function + | []|[_] -> false + | (i,_)::((j,_)::_ as rem) -> + j > i+1 || some_hole rem in + let rec i_rec cur_low cur_high cur_act = function + | [] -> + [cur_low, cur_high, cur_act] + | (i,act)::rem -> + let act_index = store.act_store () act in + if act_index = cur_act then + i_rec cur_low i cur_act rem + else + (cur_low, cur_high, cur_act):: + i_rec i i act_index rem in + let inters = match l with + | (i,act)::rem -> + let act_index = + (* In case there is some hole and that a switch is emitted, + action 0 will be used as the action of unreachable + cases (cf. switch.ml, make_switch). + Hence, this action will be shared *) + if some_hole rem then + store.act_store_shared () act + else + store.act_store () act in + assert (act_index = 0) ; + i_rec i i act_index rem + | _ -> assert false in + + Array.of_list inters, store + + +let sort_int_lambda_list l = + List.sort + (fun (i1,_) (i2,_) -> + if i1 < i2 then -1 + else if i2 < i1 then 1 + else 0) + l + +let as_interval fail low high l = + let l = sort_int_lambda_list l in + get_edges low high l, + (match fail with + | None -> as_interval_nofail l + | Some act -> as_interval_canfail act low high l) + +let call_switcher loc fail arg low high int_lambda_list = + let edges, (cases, actions) = + as_interval fail low high int_lambda_list in + Switcher.zyva loc edges arg cases actions + + +let rec list_as_pat = function + | [] -> fatal_error "Matching.list_as_pat" + | [pat] -> pat + | pat::rem -> + {pat with pat_desc = Tpat_or (pat,list_as_pat rem,None)} + + +let complete_pats_constrs = function + | p::_ as pats -> + List.map + (pat_of_constr p) + (complete_constrs p (List.map get_key_constr pats)) + | _ -> assert false + + +(* + Following two ``failaction'' function compute n, the trap handler + to jump to in case of failure of elementary tests +*) + +let mk_failaction_neg partial ctx def = match partial with +| Partial -> + begin match def with + | (_,idef)::_ -> + Some (Lstaticraise (idef,[])),jumps_singleton idef ctx + | [] -> + (* Act as Total, this means + If no appropriate default matrix exists, + then this switch cannot fail *) + None, jumps_empty + end +| Total -> + None, jumps_empty + + + +(* In line with the article and simpler than before *) +let mk_failaction_pos partial seen ctx defs = + if dbg then begin + Format.eprintf "**POS**\n" ; + pretty_def defs ; + () + end ; + let rec scan_def env to_test defs = match to_test,defs with + | ([],_)|(_,[]) -> + List.fold_left + (fun (klist,jumps) (pats,i)-> + let action = Lstaticraise (i,[]) in + let klist = + List.fold_right + (fun pat r -> (get_key_constr pat,action)::r) + pats klist + and jumps = + jumps_add i (ctx_lub (list_as_pat pats) ctx) jumps in + klist,jumps) + ([],jumps_empty) env + | _,(pss,idef)::rem -> + let now, later = + List.partition + (fun (_p,p_ctx) -> ctx_match p_ctx pss) to_test in + match now with + | [] -> scan_def env to_test rem + | _ -> scan_def ((List.map fst now,idef)::env) later rem in + + let fail_pats = complete_pats_constrs seen in + if List.length fail_pats < !Clflags.match_context_rows then begin + let fail,jmps = + scan_def + [] + (List.map + (fun pat -> pat, ctx_lub pat ctx) + fail_pats) + defs in + if dbg then begin + eprintf "POSITIVE JUMPS [%i]:\n" (List.length fail_pats); + pretty_jumps jmps + end ; + None,fail,jmps + end else begin (* Too many non-matched constructors -> reduced information *) + if dbg then eprintf "POS->NEG!!!\n%!" ; + let fail,jumps = mk_failaction_neg partial ctx defs in + if dbg then + eprintf "FAIL: %s\n" + (match fail with + | None -> "" + | Some lam -> string_of_lam lam) ; + fail,[],jumps + end + +let combine_constant loc arg cst partial ctx def + (const_lambda_list, total, _pats) = + let fail, local_jumps = + mk_failaction_neg partial ctx def in + let lambda1 = + match cst with + | Const_int _ -> + let int_lambda_list = + List.map (function Const_int n, l -> n,l | _ -> assert false) + const_lambda_list in + call_switcher loc fail arg min_int max_int int_lambda_list + | Const_char _ -> + let int_lambda_list = + List.map (function Const_char c, l -> (Char.code c, l) + | _ -> assert false) + const_lambda_list in + call_switcher loc fail arg 0 255 int_lambda_list + | Const_string _ -> +(* Note as the bytecode compiler may resort to dichotomic search, + the clauses of stringswitch are sorted with duplicates removed. + This partly applies to the native code compiler, which requires + no duplicates *) + let const_lambda_list = sort_lambda_list const_lambda_list in + let sw = + List.map + (fun (c,act) -> match c with + | Const_string (s,_) -> s,act + | _ -> assert false) + const_lambda_list in + let hs,sw,fail = share_actions_tree sw fail in + hs (Lstringswitch (arg,sw,fail,loc)) + | Const_float _ -> + make_test_sequence loc + fail + (Pfloatcomp CFneq) (Pfloatcomp CFlt) + arg const_lambda_list + | Const_int32 _ -> + make_test_sequence loc + fail + (Pbintcomp(Pint32, Cne)) (Pbintcomp(Pint32, Clt)) + arg const_lambda_list + | Const_int64 _ -> + make_test_sequence loc + fail + (Pbintcomp(Pint64, Cne)) (Pbintcomp(Pint64, Clt)) + arg const_lambda_list + | Const_nativeint _ -> + make_test_sequence loc + fail + (Pbintcomp(Pnativeint, Cne)) (Pbintcomp(Pnativeint, Clt)) + arg const_lambda_list + in lambda1,jumps_union local_jumps total + + + +let split_cases tag_lambda_list = + let rec split_rec = function + [] -> ([], []) + | (cstr, act) :: rem -> + let (consts, nonconsts) = split_rec rem in + match cstr with + Cstr_constant n -> ((n, act) :: consts, nonconsts) + | Cstr_block n -> (consts, (n, act) :: nonconsts) + | Cstr_unboxed -> (consts, (0, act) :: nonconsts) + | Cstr_extension _ -> assert false in + let const, nonconst = split_rec tag_lambda_list in + sort_int_lambda_list const, + sort_int_lambda_list nonconst + +let split_extension_cases tag_lambda_list = + let rec split_rec = function + [] -> ([], []) + | (cstr, act) :: rem -> + let (consts, nonconsts) = split_rec rem in + match cstr with + Cstr_extension(path, true) -> ((path, act) :: consts, nonconsts) + | Cstr_extension(path, false) -> (consts, (path, act) :: nonconsts) + | _ -> assert false in + split_rec tag_lambda_list + + +let combine_constructor loc arg ex_pat cstr partial ctx def + (tag_lambda_list, total1, pats) = + if cstr.cstr_consts < 0 then begin + (* Special cases for extensions *) + let fail, local_jumps = + mk_failaction_neg partial ctx def in + let lambda1 = + let consts, nonconsts = split_extension_cases tag_lambda_list in + let default, consts, nonconsts = + match fail with + | None -> + begin match consts, nonconsts with + | _, (_, act)::rem -> act, consts, rem + | (_, act)::rem, _ -> act, rem, nonconsts + | _ -> assert false + end + | Some fail -> fail, consts, nonconsts in + let nonconst_lambda = + match nonconsts with + [] -> default + | _ -> + let tag = Ident.create_local "tag" in + let tests = + List.fold_right + (fun (path, act) rem -> + let ext = transl_extension_path loc ex_pat.pat_env path in + Lifthenelse(Lprim(Pintcomp Ceq, [Lvar tag; ext], loc), + act, rem)) + nonconsts + default + in + Llet(Alias, Pgenval,tag, Lprim(Pfield 0, [arg], loc), tests) + in + List.fold_right + (fun (path, act) rem -> + let ext = transl_extension_path loc ex_pat.pat_env path in + Lifthenelse(Lprim(Pintcomp Ceq, [arg; ext], loc), + act, rem)) + consts + nonconst_lambda + in + lambda1, jumps_union local_jumps total1 + end else begin + (* Regular concrete type *) + let ncases = List.length tag_lambda_list + and nconstrs = cstr.cstr_consts + cstr.cstr_nonconsts in + let sig_complete = ncases = nconstrs in + let fail_opt,fails,local_jumps = + if sig_complete then None,[],jumps_empty + else + mk_failaction_pos partial pats ctx def in + + let tag_lambda_list = fails @ tag_lambda_list in + let (consts, nonconsts) = split_cases tag_lambda_list in + let lambda1 = + match fail_opt,same_actions tag_lambda_list with + | None,Some act -> act (* Identical actions, no failure *) + | _ -> + match + (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) + with + | (1, 1, [0, act1], [0, act2]) -> + (* Typically, match on lists, will avoid isint primitive in that + case *) + Lifthenelse(arg, act2, act1) + | (n,0,_,[]) -> (* The type defines constant constructors only *) + call_switcher loc fail_opt arg 0 (n-1) consts + | (n, _, _, _) -> + let act0 = + (* = Some act when all non-const constructors match to act *) + match fail_opt,nonconsts with + | Some a,[] -> Some a + | Some _,_ -> + if List.length nonconsts = cstr.cstr_nonconsts then + same_actions nonconsts + else None + | None,_ -> same_actions nonconsts in + match act0 with + | Some act -> + Lifthenelse + (Lprim (Pisint, [arg], loc), + call_switcher loc + fail_opt arg + 0 (n-1) consts, + act) +(* Emit a switch, as bytecode implements this sophisticated instruction *) + | None -> + let sw = + {sw_numconsts = cstr.cstr_consts; sw_consts = consts; + sw_numblocks = cstr.cstr_nonconsts; sw_blocks = nonconsts; + sw_failaction = fail_opt} in + let hs,sw = share_actions_sw sw in + let sw = reintroduce_fail sw in + hs (Lswitch (arg,sw,loc)) in + lambda1, jumps_union local_jumps total1 + end + +let make_test_sequence_variant_constant fail arg int_lambda_list = + let _, (cases, actions) = + as_interval fail min_int max_int int_lambda_list in + Switcher.test_sequence arg cases actions + +let call_switcher_variant_constant loc fail arg int_lambda_list = + call_switcher loc fail arg min_int max_int int_lambda_list + + +let call_switcher_variant_constr loc fail arg int_lambda_list = + let v = Ident.create_local "variant" in + Llet(Alias, Pgenval, v, Lprim(Pfield 0, [arg], loc), + call_switcher loc + fail (Lvar v) min_int max_int int_lambda_list) + +let combine_variant loc row arg partial ctx def + (tag_lambda_list, total1, _pats) = + let row = Btype.row_repr row in + let num_constr = ref 0 in + if row.row_closed then + List.iter + (fun (_, f) -> + match Btype.row_field_repr f with + Rabsent | Reither(true, _::_, _, _) -> () + | _ -> incr num_constr) + row.row_fields + else + num_constr := max_int; + let test_int_or_block arg if_int if_block = + Lifthenelse(Lprim (Pisint, [arg], loc), if_int, if_block) in + let sig_complete = List.length tag_lambda_list = !num_constr + and one_action = same_actions tag_lambda_list in + let fail, local_jumps = + if + sig_complete || (match partial with Total -> true | _ -> false) + then + None, jumps_empty + else + mk_failaction_neg partial ctx def in + let (consts, nonconsts) = split_cases tag_lambda_list in + let lambda1 = match fail, one_action with + | None, Some act -> act + | _,_ -> + match (consts, nonconsts) with + | ([_, act1], [_, act2]) when fail=None -> + test_int_or_block arg act1 act2 + | (_, []) -> (* One can compare integers and pointers *) + make_test_sequence_variant_constant fail arg consts + | ([], _) -> + let lam = call_switcher_variant_constr loc + fail arg nonconsts in + (* One must not dereference integers *) + begin match fail with + | None -> lam + | Some fail -> test_int_or_block arg fail lam + end + | (_, _) -> + let lam_const = + call_switcher_variant_constant loc + fail arg consts + and lam_nonconst = + call_switcher_variant_constr loc + fail arg nonconsts in + test_int_or_block arg lam_const lam_nonconst + in + lambda1, jumps_union local_jumps total1 + + +let combine_array loc arg kind partial ctx def + (len_lambda_list, total1, _pats) = + let fail, local_jumps = mk_failaction_neg partial ctx def in + let lambda1 = + let newvar = Ident.create_local "len" in + let switch = + call_switcher loc + fail (Lvar newvar) + 0 max_int len_lambda_list in + bind + Alias newvar (Lprim(Parraylength kind, [arg], loc)) switch in + lambda1, jumps_union local_jumps total1 + +(* Insertion of debugging events *) + +let rec event_branch repr lam = + begin match lam, repr with + (_, None) -> + lam + | (Levent(lam', ev), Some r) -> + incr r; + Levent(lam', {lev_loc = ev.lev_loc; + lev_kind = ev.lev_kind; + lev_repr = repr; + lev_env = ev.lev_env}) + | (Llet(str, k, id, lam, body), _) -> + Llet(str, k, id, lam, event_branch repr body) + | Lstaticraise _,_ -> lam + | (_, Some _) -> + Printlambda.lambda Format.str_formatter lam ; + fatal_error + ("Matching.event_branch: "^Format.flush_str_formatter ()) + end + + +(* + This exception is raised when the compiler cannot produce code + because control cannot reach the compiled clause, + + Unused is raised initially in compile_test. + + compile_list (for compiling switch results) catch Unused + + comp_match_handlers (for compiling split matches) + may reraise Unused + + +*) + +exception Unused + +let compile_list compile_fun division = + + let rec c_rec totals = function + | [] -> [], jumps_unions totals, [] + | (key, cell) :: rem -> + begin match cell.ctx with + | [] -> c_rec totals rem + | _ -> + try + let (lambda1, total1) = compile_fun cell.ctx cell.pm in + let c_rem, total, new_pats = + c_rec + (jumps_map ctx_combine total1::totals) rem in + ((key,lambda1)::c_rem), total, (cell.pat::new_pats) + with + | Unused -> c_rec totals rem + end in + c_rec [] division + + +let compile_orhandlers compile_fun lambda1 total1 ctx to_catch = + let rec do_rec r total_r = function + | [] -> r,total_r + | (mat,i,vars,pm)::rem -> + begin try + let ctx = select_columns mat ctx in + let handler_i, total_i = + compile_fun ctx pm in + match raw_action r with + | Lstaticraise (j,args) -> + if i=j then + List.fold_right2 (bind_with_value_kind Alias) + vars args handler_i, + jumps_map (ctx_rshift_num (ncols mat)) total_i + else + do_rec r total_r rem + | _ -> + do_rec + (Lstaticcatch (r,(i,vars), handler_i)) + (jumps_union + (jumps_remove i total_r) + (jumps_map (ctx_rshift_num (ncols mat)) total_i)) + rem + with + | Unused -> + do_rec (Lstaticcatch (r, (i,vars), lambda_unit)) total_r rem + end in + do_rec lambda1 total1 to_catch + + +let compile_test compile_fun partial divide combine ctx to_match = + let division = divide ctx to_match in + let c_div = compile_list compile_fun division in + match c_div with + | [],_,_ -> + begin match mk_failaction_neg partial ctx to_match.default with + | None,_ -> raise Unused + | Some l,total -> l,total + end + | _ -> + combine ctx to_match.default c_div + +(* Attempt to avoid some useless bindings by lowering them *) + +(* Approximation of v present in lam *) +let rec approx_present v = function + | Lconst _ -> false + | Lstaticraise (_,args) -> + List.exists (fun lam -> approx_present v lam) args + | Lprim (_,args,_) -> + List.exists (fun lam -> approx_present v lam) args + | Llet (Alias, _k, _, l1, l2) -> + approx_present v l1 || approx_present v l2 + | Lvar vv -> Ident.same v vv + | _ -> true + +let rec lower_bind v arg lam = match lam with +| Lifthenelse (cond, ifso, ifnot) -> + let pcond = approx_present v cond + and pso = approx_present v ifso + and pnot = approx_present v ifnot in + begin match pcond, pso, pnot with + | false, false, false -> lam + | false, true, false -> + Lifthenelse (cond, lower_bind v arg ifso, ifnot) + | false, false, true -> + Lifthenelse (cond, ifso, lower_bind v arg ifnot) + | _,_,_ -> bind Alias v arg lam + end +| Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as sw), loc) + when not (approx_present v ls) -> + Lswitch (ls, {sw with sw_consts = [i,lower_bind v arg act]}, loc) +| Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw), loc) + when not (approx_present v ls) -> + Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]}, loc) +| Llet (Alias, k, vv, lv, l) -> + if approx_present v lv then + bind Alias v arg lam + else + Llet (Alias, k, vv, lv, lower_bind v arg l) +| _ -> + bind Alias v arg lam + +let bind_check str v arg lam = match str,arg with +| _, Lvar _ ->bind str v arg lam +| Alias,_ -> lower_bind v arg lam +| _,_ -> bind str v arg lam + +let comp_exit ctx m = match m.default with +| (_,i)::_ -> Lstaticraise (i,[]), jumps_singleton i ctx +| _ -> fatal_error "Matching.comp_exit" + + + +let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = + match next_matchs with + | [] -> comp_fun partial ctx arg first_match + | rem -> + let rec c_rec body total_body = function + | [] -> body, total_body + (* Hum, -1 means never taken + | (-1,pm)::rem -> c_rec body total_body rem *) + | (i,pm)::rem -> + let ctx_i,total_rem = jumps_extract i total_body in + begin match ctx_i with + | [] -> c_rec body total_body rem + | _ -> + try + let li,total_i = + comp_fun + (match rem with [] -> partial | _ -> Partial) + ctx_i arg pm in + c_rec + (Lstaticcatch (body,(i,[]),li)) + (jumps_union total_i total_rem) + rem + with + | Unused -> + c_rec (Lstaticcatch (body,(i,[]),lambda_unit)) + total_rem rem + end in + try + let first_lam,total = comp_fun Partial ctx arg first_match in + c_rec first_lam total rem + with Unused -> match next_matchs with + | [] -> raise Unused + | (_,x)::xs -> comp_match_handlers comp_fun partial ctx arg x xs + +(* To find reasonable names for variables *) + +let rec name_pattern default = function + (pat :: _, _) :: rem -> + begin match pat.pat_desc with + Tpat_var (id, _) -> id + | Tpat_alias(_, id, _) -> id + | _ -> name_pattern default rem + end + | _ -> Ident.create_local default + +let arg_to_var arg cls = match arg with +| Lvar v -> v,arg +| _ -> + let v = name_pattern "*match*" cls in + v,Lvar v + + +(* + The main compilation function. + Input: + repr=used for inserting debug events + partial=exhaustiveness information from Parmatch + ctx=a context + m=a pattern matching + + Output: a lambda term, a jump summary {..., exit number -> context, .. } +*) + +let rec compile_match repr partial ctx m = match m with +| { cases = []; args = [] } -> comp_exit ctx m +| { cases = ([], action) :: rem } -> + if is_guarded action then begin + let (lambda, total) = + compile_match None partial ctx { m with cases = rem } in + event_branch repr (patch_guarded lambda action), total + end else + (event_branch repr action, jumps_empty) +| { args = (arg, str)::argl } -> + let v,newarg = arg_to_var arg m.cases in + let first_match,rem = + split_precompile (Some v) + { m with args = (newarg, Alias) :: argl } in + let (lam, total) = + comp_match_handlers + ((if dbg then do_compile_matching_pr else do_compile_matching) repr) + partial ctx newarg first_match rem in + bind_check str v arg lam, total +| _ -> assert false + + +(* verbose version of do_compile_matching, for debug *) + +and do_compile_matching_pr repr partial ctx arg x = + Format.eprintf "COMPILE: %s\nMATCH\n" + (match partial with Partial -> "Partial" | Total -> "Total") ; + pretty_precompiled x ; + Format.eprintf "CTX\n" ; + pretty_ctx ctx ; + let (_, jumps) as r = do_compile_matching repr partial ctx arg x in + Format.eprintf "JUMPS\n" ; + pretty_jumps jumps ; + r + +and do_compile_matching repr partial ctx arg pmh = match pmh with +| Pm pm -> + let pat = what_is_cases pm.cases in + begin match pat.pat_desc with + | Tpat_any -> + compile_no_test + divide_var ctx_rshift repr partial ctx pm + | Tpat_tuple patl -> + compile_no_test + (divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine + repr partial ctx pm + | Tpat_record ((_, lbl,_)::_,_) -> + compile_no_test + (divide_record lbl.lbl_all (normalize_pat pat)) + ctx_combine repr partial ctx pm + | Tpat_constant cst -> + compile_test + (compile_match repr partial) partial + divide_constant + (combine_constant pat.pat_loc arg cst partial) + ctx pm + | Tpat_construct (_, cstr, _) -> + compile_test + (compile_match repr partial) partial + divide_constructor + (combine_constructor pat.pat_loc arg pat cstr partial) + ctx pm + | Tpat_array _ -> + let kind = Typeopt.array_pattern_kind pat in + compile_test (compile_match repr partial) partial + (divide_array kind) (combine_array pat.pat_loc arg kind partial) + ctx pm + | Tpat_lazy _ -> + compile_no_test + (divide_lazy (normalize_pat pat)) + ctx_combine repr partial ctx pm + | Tpat_variant(_, _, row) -> + compile_test (compile_match repr partial) partial + (divide_variant !row) + (combine_variant pat.pat_loc !row arg partial) + ctx pm + | _ -> assert false + end +| PmVar {inside=pmh ; var_arg=arg} -> + let lam, total = + do_compile_matching repr partial (ctx_lshift ctx) arg pmh in + lam, jumps_map ctx_rshift total +| PmOr {body=body ; handlers=handlers} -> + let lam, total = compile_match repr partial ctx body in + compile_orhandlers (compile_match repr partial) lam total ctx handlers + +and compile_no_test divide up_ctx repr partial ctx to_match = + let {pm=this_match ; ctx=this_ctx } = divide ctx to_match in + let lambda,total = compile_match repr partial this_ctx this_match in + lambda, jumps_map up_ctx total + + + + +(* The entry points *) + +(* + If there is a guard in a matching or a lazy pattern, + then set exhaustiveness info to Partial. + (because of side effects, assume the worst). + + Notice that exhaustiveness information is trusted by the compiler, + that is, a match flagged as Total should not fail at runtime. + More specifically, for instance if match y with x::_ -> x is flagged + total (as it happens during JoCaml compilation) then y cannot be [] + at runtime. As a consequence, the static Total exhaustiveness information + have to be downgraded to Partial, in the dubious cases where guards + or lazy pattern execute arbitrary code that may perform side effects + and change the subject values. +LM: + Lazy pattern was PR#5992, initial patch by lpw25. + I have generalized the patch, so as to also find mutable fields. +*) + +let find_in_pat pred = + let rec find_rec p = + pred p.pat_desc || + begin match p.pat_desc with + | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p -> + find_rec p + | Tpat_tuple ps|Tpat_construct (_,_,ps) | Tpat_array ps -> + List.exists find_rec ps + | Tpat_record (lpats,_) -> + List.exists + (fun (_, _, p) -> find_rec p) + lpats + | Tpat_or (p,q,_) -> + find_rec p || find_rec q + | Tpat_constant _ | Tpat_var _ + | Tpat_any | Tpat_variant (_,None,_) -> false + | Tpat_exception _ -> assert false + end in + find_rec + +let is_lazy_pat = function + | Tpat_lazy _ -> true + | Tpat_alias _ | Tpat_variant _ | Tpat_record _ + | Tpat_tuple _|Tpat_construct _ | Tpat_array _ + | Tpat_or _ | Tpat_constant _ | Tpat_var _ | Tpat_any + -> false + | Tpat_exception _ -> assert false + +let is_lazy p = find_in_pat is_lazy_pat p + +let have_mutable_field p = match p with +| Tpat_record (lps,_) -> + List.exists + (fun (_,lbl,_) -> + match lbl.Types.lbl_mut with + | Mutable -> true + | Immutable -> false) + lps +| Tpat_alias _ | Tpat_variant _ | Tpat_lazy _ +| Tpat_tuple _|Tpat_construct _ | Tpat_array _ +| Tpat_or _ +| Tpat_constant _ | Tpat_var _ | Tpat_any + -> false +| Tpat_exception _ -> assert false + +let is_mutable p = find_in_pat have_mutable_field p + +(* Downgrade Total when + 1. Matching accesses some mutable fields; + 2. And there are guards or lazy patterns. +*) + +let check_partial is_mutable is_lazy pat_act_list = function + | Partial -> Partial + | Total -> + if + pat_act_list = [] || (* allow empty case list *) + List.exists + (fun (pats, lam) -> + is_mutable pats && (is_guarded lam || is_lazy pats)) + pat_act_list + then Partial + else Total + +let check_partial_list = + check_partial (List.exists is_mutable) (List.exists is_lazy) +let check_partial = check_partial is_mutable is_lazy + +(* have toplevel handler when appropriate *) + +let start_ctx n = [{left=[] ; right = omegas n}] + +let check_total total lambda i handler_fun = + if jumps_is_empty total then + lambda + else begin + Lstaticcatch(lambda, (i,[]), handler_fun()) + end + +let compile_matching repr handler_fun arg pat_act_list partial = + let partial = check_partial pat_act_list partial in + match partial with + | Partial -> + let raise_num = next_raise_count () in + let pm = + { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [arg, Strict] ; + default = [[[omega]],raise_num]} in + begin try + let (lambda, total) = compile_match repr partial (start_ctx 1) pm in + check_total total lambda raise_num handler_fun + with + | Unused -> assert false (* ; handler_fun() *) + end + | Total -> + let pm = + { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [arg, Strict] ; + default = []} in + let (lambda, total) = compile_match repr partial (start_ctx 1) pm in + assert (jumps_is_empty total) ; + lambda + + +let partial_function loc () = + let slot = + transl_extension_path loc + Env.initial_safe_string Predef.path_match_failure + in + let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in + Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable, None), + [slot; Lconst(Const_block(0, + [Const_base(Const_string (fname, None)); + Const_base(Const_int line); + Const_base(Const_int char)]))], loc)], loc) + +let for_function loc repr param pat_act_list partial = + compile_matching repr (partial_function loc) param pat_act_list partial + +(* In the following two cases, exhaustiveness info is not available! *) +let for_trywith param pat_act_list = + compile_matching None + (fun () -> Lprim(Praise Raise_reraise, [param], Location.none)) + param pat_act_list Partial + +let simple_for_let loc param pat body = + compile_matching None (partial_function loc) param [pat, body] Partial + + +(* Optimize binding of immediate tuples + + The goal of the implementation of 'for_let' below, which replaces + 'simple_for_let', is to avoid tuple allocation in cases such as + this one: + + let (x,y) = + let foo = ... in + if foo then (1, 2) else (3,4) + in bar + + The compiler easily optimizes the simple `let (x,y) = (1,2) in ...` + case (call to Matching.for_multiple_match from Translcore), but + didn't optimize situations where the rhs tuples are hidden under + a more complex context. + + The idea comes from Alain Frisch who suggested and implemented + the following compilation method, based on Lassign: + + let x = dummy in let y = dummy in + begin + let foo = ... in + if foo then + (let x1 = 1 in let y1 = 2 in x <- x1; y <- y1) + else + (let x2 = 3 in let y2 = 4 in x <- x2; y <- y2) + end; + bar + + The current implementation from Gabriel Scherer uses Lstaticcatch / + Lstaticraise instead: + + catch + let foo = ... in + if foo then + (let x1 = 1 in let y1 = 2 in exit x1 y1) + else + (let x2 = 3 in let y2 = 4 in exit x2 y2) + with x y -> + bar + + The catch/exit is used to avoid duplication of the let body ('bar' + in the example), on 'if' branches for example; it is useless for + linear contexts such as 'let', but we don't need to be careful to + generate nice code because Simplif will remove such useless + catch/exit. +*) + +let rec map_return f = function + | Llet (str, k, id, l1, l2) -> Llet (str, k, id, l1, map_return f l2) + | Lletrec (l1, l2) -> Lletrec (l1, map_return f l2) + | Lifthenelse (lcond, lthen, lelse) -> + Lifthenelse (lcond, map_return f lthen, map_return f lelse) + | Lsequence (l1, l2) -> Lsequence (l1, map_return f l2) + | Levent (l, ev) -> Levent (map_return f l, ev) + | Ltrywith (l1, id, l2) -> Ltrywith (map_return f l1, id, map_return f l2) + | Lstaticcatch (l1, b, l2) -> + Lstaticcatch (map_return f l1, b, map_return f l2) + | Lstaticraise _ | Lprim(Praise _, _, _) as l -> l + | l -> f l + +(* The 'opt' reference indicates if the optimization is worthy. + + It is shared by the different calls to 'assign_pat' performed from + 'map_return'. For example with the code + let (x, y) = if foo then z else (1,2) + the else-branch will activate the optimization for both branches. + + That means that the optimization is activated if *there exists* an + interesting tuple in one hole of the let-rhs context. We could + choose to activate it only if *all* holes are interesting. We made + that choice because being optimistic is extremely cheap (one static + exit/catch overhead in the "wrong cases"), while being pessimistic + can be costly (one unnecessary tuple allocation). +*) + +let assign_pat opt nraise catch_ids loc pat lam = + let rec collect acc pat lam = match pat.pat_desc, lam with + | Tpat_tuple patl, Lprim(Pmakeblock _, lams, _) -> + opt := true; + List.fold_left2 collect acc patl lams + | Tpat_tuple patl, Lconst(Const_block(_, scl)) -> + opt := true; + let collect_const acc pat sc = collect acc pat (Lconst sc) in + List.fold_left2 collect_const acc patl scl + | _ -> + (* pattern idents will be bound in staticcatch (let body), so we + refresh them here to guarantee binders uniqueness *) + let pat_ids = pat_bound_idents pat in + let fresh_ids = List.map (fun id -> id, Ident.rename id) pat_ids in + (fresh_ids, alpha_pat fresh_ids pat, lam) :: acc + in + + (* sublets were accumulated by 'collect' with the leftmost tuple + pattern at the bottom of the list; to respect right-to-left + evaluation order for tuples, we must evaluate sublets + top-to-bottom. To preserve tail-rec, we will fold_left the + reversed list. *) + let rev_sublets = List.rev (collect [] pat lam) in + let exit = + (* build an Ident.tbl to avoid quadratic refreshing costs *) + let add t (id, fresh_id) = Ident.add id fresh_id t in + let add_ids acc (ids, _pat, _lam) = List.fold_left add acc ids in + let tbl = List.fold_left add_ids Ident.empty rev_sublets in + let fresh_var id = Lvar (Ident.find_same id tbl) in + Lstaticraise(nraise, List.map fresh_var catch_ids) + in + let push_sublet code (_ids, pat, lam) = simple_for_let loc lam pat code in + List.fold_left push_sublet exit rev_sublets + +let for_let loc param pat body = + match pat.pat_desc with + | Tpat_any -> + (* This eliminates a useless variable (and stack slot in bytecode) + for "let _ = ...". See #6865. *) + Lsequence(param, body) + | Tpat_var (id, _) -> + (* fast path, and keep track of simple bindings to unboxable numbers *) + let k = Typeopt.value_kind pat.pat_env pat.pat_type in + Llet(Strict, k, id, param, body) + | _ -> + let opt = ref false in + let nraise = next_raise_count () in + let catch_ids = pat_bound_idents_full pat in + let ids_with_kinds = + List.map (fun (id, _, typ) -> id, Typeopt.value_kind pat.pat_env typ) + catch_ids + in + let ids = List.map (fun (id, _, _) -> id) catch_ids in + let bind = map_return (assign_pat opt nraise ids loc pat) param in + if !opt then Lstaticcatch(bind, (nraise, ids_with_kinds), body) + else simple_for_let loc param pat body + +(* Handling of tupled functions and matchings *) + +(* Easy case since variables are available *) +let for_tupled_function loc paraml pats_act_list partial = + let partial = check_partial_list pats_act_list partial in + let raise_num = next_raise_count () in + let omegas = [List.map (fun _ -> omega) paraml] in + let pm = + { cases = pats_act_list; + args = List.map (fun id -> (Lvar id, Strict)) paraml ; + default = [omegas,raise_num] + } in + try + let (lambda, total) = compile_match None partial + (start_ctx (List.length paraml)) pm in + check_total total lambda raise_num (partial_function loc) + with + | Unused -> partial_function loc () + + + +let flatten_pattern size p = match p.pat_desc with +| Tpat_tuple args -> args +| Tpat_any -> omegas size +| _ -> raise Cannot_flatten + +let rec flatten_pat_line size p k = match p.pat_desc with +| Tpat_any -> omegas size::k +| Tpat_tuple args -> args::k +| Tpat_or (p1,p2,_) -> flatten_pat_line size p1 (flatten_pat_line size p2 k) +| Tpat_alias (p,_,_) -> (* Note: if this 'as' pat is here, then this is a + useless binding, solves PR#3780 *) + flatten_pat_line size p k +| _ -> fatal_error "Matching.flatten_pat_line" + +let flatten_cases size cases = + List.map + (fun (ps,action) -> match ps with + | [p] -> flatten_pattern size p,action + | _ -> fatal_error "Matching.flatten_case") + cases + +let flatten_matrix size pss = + List.fold_right + (fun ps r -> match ps with + | [p] -> flatten_pat_line size p r + | _ -> fatal_error "Matching.flatten_matrix") + pss [] + +let flatten_def size def = + List.map + (fun (pss,i) -> flatten_matrix size pss,i) + def + +let flatten_pm size args pm = + {args = args ; cases = flatten_cases size pm.cases ; + default = flatten_def size pm.default} + + +let flatten_precompiled size args pmh = match pmh with +| Pm pm -> Pm (flatten_pm size args pm) +| PmOr {body=b ; handlers=hs ; or_matrix=m} -> + PmOr + {body=flatten_pm size args b ; + handlers= + List.map + (fun (mat,i,vars,pm) -> flatten_matrix size mat,i,vars,pm) + hs ; + or_matrix=flatten_matrix size m ;} +| PmVar _ -> assert false + +(* + compiled_flattened is a ``comp_fun'' argument to comp_match_handlers. + Hence it needs a fourth argument, which it ignores +*) + +let compile_flattened repr partial ctx _ pmh = match pmh with +| Pm pm -> compile_match repr partial ctx pm +| PmOr {body=b ; handlers=hs} -> + let lam, total = compile_match repr partial ctx b in + compile_orhandlers (compile_match repr partial) lam total ctx hs +| PmVar _ -> assert false + +let do_for_multiple_match loc paraml pat_act_list partial = + let repr = None in + let partial = check_partial pat_act_list partial in + let raise_num,pm1 = + match partial with + | Partial -> + let raise_num = next_raise_count () in + raise_num, + { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [Lprim(Pmakeblock(0, Immutable, None), paraml, loc), Strict]; + default = [[[omega]],raise_num] } + | _ -> + -1, + { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [Lprim(Pmakeblock(0, Immutable, None), paraml, loc), Strict]; + default = [] } in + + try + try +(* Once for checking that compilation is possible *) + let next, nexts = split_precompile None pm1 in + + let size = List.length paraml + and idl = List.map (fun _ -> Ident.create_local "*match*") paraml in + let args = List.map (fun id -> Lvar id, Alias) idl in + + let flat_next = flatten_precompiled size args next + and flat_nexts = + List.map + (fun (e,pm) -> e,flatten_precompiled size args pm) + nexts in + + let lam, total = + comp_match_handlers + (compile_flattened repr) + partial (start_ctx size) () flat_next flat_nexts in + List.fold_right2 (bind Strict) idl paraml + (match partial with + | Partial -> + check_total total lam raise_num (partial_function loc) + | Total -> + assert (jumps_is_empty total) ; + lam) + with Cannot_flatten -> + let (lambda, total) = compile_match None partial (start_ctx 1) pm1 in + begin match partial with + | Partial -> + check_total total lambda raise_num (partial_function loc) + | Total -> + assert (jumps_is_empty total) ; + lambda + end + with Unused -> + assert false (* ; partial_function loc () *) + +(* PR#4828: Believe it or not, the 'paraml' argument below + may not be side effect free. *) + +let param_to_var param = match param with +| Lvar v -> v,None +| _ -> Ident.create_local "*match*",Some param + +let bind_opt (v,eo) k = match eo with +| None -> k +| Some e -> Lambda.bind Strict v e k + +let for_multiple_match loc paraml pat_act_list partial = + let v_paraml = List.map param_to_var paraml in + let paraml = List.map (fun (v,_) -> Lvar v) v_paraml in + List.fold_right bind_opt v_paraml + (do_for_multiple_match loc paraml pat_act_list partial) diff --git a/lambda/matching.mli b/lambda/matching.mli new file mode 100644 index 00000000..f29901bd --- /dev/null +++ b/lambda/matching.mli @@ -0,0 +1,46 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Compilation of pattern-matching *) + +open Typedtree +open Lambda + + +(* Entry points to match compiler *) +val for_function: + Location.t -> int ref option -> lambda -> (pattern * lambda) list -> + partial -> lambda +val for_trywith: + lambda -> (pattern * lambda) list -> lambda +val for_let: + Location.t -> lambda -> pattern -> lambda -> lambda +val for_multiple_match: + Location.t -> lambda list -> (pattern * lambda) list -> partial -> + lambda + +val for_tupled_function: + Location.t -> Ident.t list -> (pattern list * lambda) list -> + partial -> lambda + +exception Cannot_flatten + +val flatten_pattern: int -> pattern -> pattern list + +(* Expand stringswitch to string test tree *) +val expand_stringswitch: + Location.t -> lambda -> (string * lambda) list -> lambda option -> lambda + +val inline_lazy_force : lambda -> Location.t -> lambda diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml new file mode 100644 index 00000000..e4bb26a6 --- /dev/null +++ b/lambda/printlambda.ml @@ -0,0 +1,648 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Format +open Asttypes +open Primitive +open Types +open Lambda + + +let rec struct_const ppf = function + | Const_base(Const_int n) -> fprintf ppf "%i" n + | Const_base(Const_char c) -> fprintf ppf "%C" c + | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s + | Const_immstring s -> fprintf ppf "#%S" s + | Const_base(Const_float f) -> fprintf ppf "%s" f + | Const_base(Const_int32 n) -> fprintf ppf "%lil" n + | Const_base(Const_int64 n) -> fprintf ppf "%LiL" n + | Const_base(Const_nativeint n) -> fprintf ppf "%nin" n + | Const_pointer n -> fprintf ppf "%ia" n + | Const_block(tag, []) -> + fprintf ppf "[%i]" tag + | Const_block(tag, sc1::scl) -> + let sconsts ppf scl = + List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in + fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl + | Const_float_array [] -> + fprintf ppf "[| |]" + | Const_float_array (f1 :: fl) -> + let floats ppf fl = + List.iter (fun f -> fprintf ppf "@ %s" f) fl in + fprintf ppf "@[<1>[|@[%s%a@]|]@]" f1 floats fl + +let array_kind = function + | Pgenarray -> "gen" + | Paddrarray -> "addr" + | Pintarray -> "int" + | Pfloatarray -> "float" + +let boxed_integer_name = function + | Pnativeint -> "nativeint" + | Pint32 -> "int32" + | Pint64 -> "int64" + +let value_kind ppf = function + | Pgenval -> () + | Pintval -> fprintf ppf "[int]" + | Pfloatval -> fprintf ppf "[float]" + | Pboxedintval bi -> fprintf ppf "[%s]" (boxed_integer_name bi) + +let return_kind ppf = function + | Pgenval -> () + | Pintval -> fprintf ppf ": int@ " + | Pfloatval -> fprintf ppf ": float@ " + | Pboxedintval bi -> fprintf ppf ": %s@ " (boxed_integer_name bi) + +let field_kind = function + | Pgenval -> "*" + | Pintval -> "int" + | Pfloatval -> "float" + | Pboxedintval bi -> boxed_integer_name bi + +let print_boxed_integer_conversion ppf bi1 bi2 = + fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1) + +let boxed_integer_mark name = function + | Pnativeint -> Printf.sprintf "Nativeint.%s" name + | Pint32 -> Printf.sprintf "Int32.%s" name + | Pint64 -> Printf.sprintf "Int64.%s" name + +let print_boxed_integer name ppf bi = + fprintf ppf "%s" (boxed_integer_mark name bi);; + +let print_bigarray name unsafe kind ppf layout = + fprintf ppf "Bigarray.%s[%s,%s]" + (if unsafe then "unsafe_"^ name else name) + (match kind with + | Pbigarray_unknown -> "generic" + | Pbigarray_float32 -> "float32" + | Pbigarray_float64 -> "float64" + | Pbigarray_sint8 -> "sint8" + | Pbigarray_uint8 -> "uint8" + | Pbigarray_sint16 -> "sint16" + | Pbigarray_uint16 -> "uint16" + | Pbigarray_int32 -> "int32" + | Pbigarray_int64 -> "int64" + | Pbigarray_caml_int -> "camlint" + | Pbigarray_native_int -> "nativeint" + | Pbigarray_complex32 -> "complex32" + | Pbigarray_complex64 -> "complex64") + (match layout with + | Pbigarray_unknown_layout -> "unknown" + | Pbigarray_c_layout -> "C" + | Pbigarray_fortran_layout -> "Fortran") + +let record_rep ppf r = + match r with + | Record_regular -> fprintf ppf "regular" + | Record_inlined i -> fprintf ppf "inlined(%i)" i + | Record_unboxed false -> fprintf ppf "unboxed" + | Record_unboxed true -> fprintf ppf "inlined(unboxed)" + | Record_float -> fprintf ppf "float" + | Record_extension path -> fprintf ppf "ext(%a)" Printtyp.path path +;; + +let block_shape ppf shape = match shape with + | None | Some [] -> () + | Some l when List.for_all ((=) Pgenval) l -> () + | Some [elt] -> + Format.fprintf ppf " (%s)" (field_kind elt) + | Some (h :: t) -> + Format.fprintf ppf " (%s" (field_kind h); + List.iter (fun elt -> + Format.fprintf ppf ",%s" (field_kind elt)) + t; + Format.fprintf ppf ")" + +let integer_comparison ppf = function + | Ceq -> fprintf ppf "==" + | Cne -> fprintf ppf "!=" + | Clt -> fprintf ppf "<" + | Cle -> fprintf ppf "<=" + | Cgt -> fprintf ppf ">" + | Cge -> fprintf ppf ">=" + +let float_comparison ppf = function + | CFeq -> fprintf ppf "==." + | CFneq -> fprintf ppf "!=." + | CFlt -> fprintf ppf "<." + | CFnlt -> fprintf ppf "!<." + | CFle -> fprintf ppf "<=." + | CFnle -> fprintf ppf "!<=." + | CFgt -> fprintf ppf ">." + | CFngt -> fprintf ppf "!>." + | CFge -> fprintf ppf ">=." + | CFnge -> fprintf ppf "!>=." + +let primitive ppf = function + | Pidentity -> fprintf ppf "id" + | Pbytes_to_string -> fprintf ppf "bytes_to_string" + | Pbytes_of_string -> fprintf ppf "bytes_of_string" + | Pignore -> fprintf ppf "ignore" + | Prevapply -> fprintf ppf "revapply" + | Pdirapply -> fprintf ppf "dirapply" + | Pgetglobal id -> fprintf ppf "global %a" Ident.print id + | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id + | Pmakeblock(tag, Immutable, shape) -> + fprintf ppf "makeblock %i%a" tag block_shape shape + | Pmakeblock(tag, Mutable, shape) -> + fprintf ppf "makemutable %i%a" tag block_shape shape + | Pfield n -> fprintf ppf "field %i" n + | Pfield_computed -> fprintf ppf "field_computed" + | Psetfield(n, ptr, init) -> + let instr = + match ptr with + | Pointer -> "ptr" + | Immediate -> "imm" + in + let init = + match init with + | Heap_initialization -> "(heap-init)" + | Root_initialization -> "(root-init)" + | Assignment -> "" + in + fprintf ppf "setfield_%s%s %i" instr init n + | Psetfield_computed (ptr, init) -> + let instr = + match ptr with + | Pointer -> "ptr" + | Immediate -> "imm" + in + let init = + match init with + | Heap_initialization -> "(heap-init)" + | Root_initialization -> "(root-init)" + | Assignment -> "" + in + fprintf ppf "setfield_%s%s_computed" instr init + | Pfloatfield n -> fprintf ppf "floatfield %i" n + | Psetfloatfield (n, init) -> + let init = + match init with + | Heap_initialization -> "(heap-init)" + | Root_initialization -> "(root-init)" + | Assignment -> "" + in + fprintf ppf "setfloatfield%s %i" init n + | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size + | Pccall p -> fprintf ppf "%s" p.prim_name + | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) + | Psequand -> fprintf ppf "&&" + | Psequor -> fprintf ppf "||" + | Pnot -> fprintf ppf "not" + | Pnegint -> fprintf ppf "~" + | Paddint -> fprintf ppf "+" + | Psubint -> fprintf ppf "-" + | Pmulint -> fprintf ppf "*" + | Pdivint Safe -> fprintf ppf "/" + | Pdivint Unsafe -> fprintf ppf "/u" + | Pmodint Safe -> fprintf ppf "mod" + | Pmodint Unsafe -> fprintf ppf "mod_unsafe" + | Pandint -> fprintf ppf "and" + | Porint -> fprintf ppf "or" + | Pxorint -> fprintf ppf "xor" + | Plslint -> fprintf ppf "lsl" + | Plsrint -> fprintf ppf "lsr" + | Pasrint -> fprintf ppf "asr" + | Pintcomp(cmp) -> integer_comparison ppf cmp + | Poffsetint n -> fprintf ppf "%i+" n + | Poffsetref n -> fprintf ppf "+:=%i"n + | Pintoffloat -> fprintf ppf "int_of_float" + | Pfloatofint -> fprintf ppf "float_of_int" + | Pnegfloat -> fprintf ppf "~." + | Pabsfloat -> fprintf ppf "abs." + | Paddfloat -> fprintf ppf "+." + | Psubfloat -> fprintf ppf "-." + | Pmulfloat -> fprintf ppf "*." + | Pdivfloat -> fprintf ppf "/." + | Pfloatcomp(cmp) -> float_comparison ppf cmp + | Pstringlength -> fprintf ppf "string.length" + | Pstringrefu -> fprintf ppf "string.unsafe_get" + | Pstringrefs -> fprintf ppf "string.get" + | Pbyteslength -> fprintf ppf "bytes.length" + | Pbytesrefu -> fprintf ppf "bytes.unsafe_get" + | Pbytessetu -> fprintf ppf "bytes.unsafe_set" + | Pbytesrefs -> fprintf ppf "bytes.get" + | Pbytessets -> fprintf ppf "bytes.set" + + | Parraylength k -> fprintf ppf "array.length[%s]" (array_kind k) + | Pmakearray (k, Mutable) -> fprintf ppf "makearray[%s]" (array_kind k) + | Pmakearray (k, Immutable) -> fprintf ppf "makearray_imm[%s]" (array_kind k) + | Pduparray (k, Mutable) -> fprintf ppf "duparray[%s]" (array_kind k) + | Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k) + | Parrayrefu k -> fprintf ppf "array.unsafe_get[%s]" (array_kind k) + | Parraysetu k -> fprintf ppf "array.unsafe_set[%s]" (array_kind k) + | Parrayrefs k -> fprintf ppf "array.get[%s]" (array_kind k) + | Parraysets k -> fprintf ppf "array.set[%s]" (array_kind k) + | Pctconst c -> + let const_name = match c with + | Big_endian -> "big_endian" + | Word_size -> "word_size" + | Int_size -> "int_size" + | Max_wosize -> "max_wosize" + | Ostype_unix -> "ostype_unix" + | Ostype_win32 -> "ostype_win32" + | Ostype_cygwin -> "ostype_cygwin" + | Backend_type -> "backend_type" in + fprintf ppf "sys.constant_%s" const_name + | Pisint -> fprintf ppf "isint" + | Pisout -> fprintf ppf "isout" + | Pbintofint bi -> print_boxed_integer "of_int" ppf bi + | Pintofbint bi -> print_boxed_integer "to_int" ppf bi + | Pcvtbint (bi1, bi2) -> print_boxed_integer_conversion ppf bi1 bi2 + | Pnegbint bi -> print_boxed_integer "neg" ppf bi + | Paddbint bi -> print_boxed_integer "add" ppf bi + | Psubbint bi -> print_boxed_integer "sub" ppf bi + | Pmulbint bi -> print_boxed_integer "mul" ppf bi + | Pdivbint { size = bi; is_safe = Safe } -> + print_boxed_integer "div" ppf bi + | Pdivbint { size = bi; is_safe = Unsafe } -> + print_boxed_integer "div_unsafe" ppf bi + | Pmodbint { size = bi; is_safe = Safe } -> + print_boxed_integer "mod" ppf bi + | Pmodbint { size = bi; is_safe = Unsafe } -> + print_boxed_integer "mod_unsafe" ppf bi + | Pandbint bi -> print_boxed_integer "and" ppf bi + | Porbint bi -> print_boxed_integer "or" ppf bi + | Pxorbint bi -> print_boxed_integer "xor" ppf bi + | Plslbint bi -> print_boxed_integer "lsl" ppf bi + | Plsrbint bi -> print_boxed_integer "lsr" ppf bi + | Pasrbint bi -> print_boxed_integer "asr" ppf bi + | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi + | Pbintcomp(bi, Cne) -> print_boxed_integer "!=" ppf bi + | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi + | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi + | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi + | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi + | Pbigarrayref(unsafe, _n, kind, layout) -> + print_bigarray "get" unsafe kind ppf layout + | Pbigarrayset(unsafe, _n, kind, layout) -> + print_bigarray "set" unsafe kind ppf layout + | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n + | Pstring_load_16(unsafe) -> + if unsafe then fprintf ppf "string.unsafe_get16" + else fprintf ppf "string.get16" + | Pstring_load_32(unsafe) -> + if unsafe then fprintf ppf "string.unsafe_get32" + else fprintf ppf "string.get32" + | Pstring_load_64(unsafe) -> + if unsafe then fprintf ppf "string.unsafe_get64" + else fprintf ppf "string.get64" + | Pbytes_load_16(unsafe) -> + if unsafe then fprintf ppf "bytes.unsafe_get16" + else fprintf ppf "bytes.get16" + | Pbytes_load_32(unsafe) -> + if unsafe then fprintf ppf "bytes.unsafe_get32" + else fprintf ppf "bytes.get32" + | Pbytes_load_64(unsafe) -> + if unsafe then fprintf ppf "bytes.unsafe_get64" + else fprintf ppf "bytes.get64" + | Pbytes_set_16(unsafe) -> + if unsafe then fprintf ppf "bytes.unsafe_set16" + else fprintf ppf "bytes.set16" + | Pbytes_set_32(unsafe) -> + if unsafe then fprintf ppf "bytes.unsafe_set32" + else fprintf ppf "bytes.set32" + | Pbytes_set_64(unsafe) -> + if unsafe then fprintf ppf "bytes.unsafe_set64" + else fprintf ppf "bytes.set64" + | Pbigstring_load_16(unsafe) -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_get16" + else fprintf ppf "bigarray.array1.get16" + | Pbigstring_load_32(unsafe) -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_get32" + else fprintf ppf "bigarray.array1.get32" + | Pbigstring_load_64(unsafe) -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_get64" + else fprintf ppf "bigarray.array1.get64" + | Pbigstring_set_16(unsafe) -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_set16" + else fprintf ppf "bigarray.array1.set16" + | Pbigstring_set_32(unsafe) -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_set32" + else fprintf ppf "bigarray.array1.set32" + | Pbigstring_set_64(unsafe) -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_set64" + else fprintf ppf "bigarray.array1.set64" + | Pbswap16 -> fprintf ppf "bswap16" + | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi + | Pint_as_pointer -> fprintf ppf "int_as_pointer" + | Popaque -> fprintf ppf "opaque" + +let name_of_primitive = function + | Pidentity -> "Pidentity" + | Pbytes_of_string -> "Pbytes_of_string" + | Pbytes_to_string -> "Pbytes_to_string" + | Pignore -> "Pignore" + | Prevapply -> "Prevapply" + | Pdirapply -> "Pdirapply" + | Pgetglobal _ -> "Pgetglobal" + | Psetglobal _ -> "Psetglobal" + | Pmakeblock _ -> "Pmakeblock" + | Pfield _ -> "Pfield" + | Pfield_computed -> "Pfield_computed" + | Psetfield _ -> "Psetfield" + | Psetfield_computed _ -> "Psetfield_computed" + | Pfloatfield _ -> "Pfloatfield" + | Psetfloatfield _ -> "Psetfloatfield" + | Pduprecord _ -> "Pduprecord" + | Pccall _ -> "Pccall" + | Praise _ -> "Praise" + | Psequand -> "Psequand" + | Psequor -> "Psequor" + | Pnot -> "Pnot" + | Pnegint -> "Pnegint" + | Paddint -> "Paddint" + | Psubint -> "Psubint" + | Pmulint -> "Pmulint" + | Pdivint _ -> "Pdivint" + | Pmodint _ -> "Pmodint" + | Pandint -> "Pandint" + | Porint -> "Porint" + | Pxorint -> "Pxorint" + | Plslint -> "Plslint" + | Plsrint -> "Plsrint" + | Pasrint -> "Pasrint" + | Pintcomp _ -> "Pintcomp" + | Poffsetint _ -> "Poffsetint" + | Poffsetref _ -> "Poffsetref" + | Pintoffloat -> "Pintoffloat" + | Pfloatofint -> "Pfloatofint" + | Pnegfloat -> "Pnegfloat" + | Pabsfloat -> "Pabsfloat" + | Paddfloat -> "Paddfloat" + | Psubfloat -> "Psubfloat" + | Pmulfloat -> "Pmulfloat" + | Pdivfloat -> "Pdivfloat" + | Pfloatcomp _ -> "Pfloatcomp" + | Pstringlength -> "Pstringlength" + | Pstringrefu -> "Pstringrefu" + | Pstringrefs -> "Pstringrefs" + | Pbyteslength -> "Pbyteslength" + | Pbytesrefu -> "Pbytesrefu" + | Pbytessetu -> "Pbytessetu" + | Pbytesrefs -> "Pbytesrefs" + | Pbytessets -> "Pbytessets" + | Parraylength _ -> "Parraylength" + | Pmakearray _ -> "Pmakearray" + | Pduparray _ -> "Pduparray" + | Parrayrefu _ -> "Parrayrefu" + | Parraysetu _ -> "Parraysetu" + | Parrayrefs _ -> "Parrayrefs" + | Parraysets _ -> "Parraysets" + | Pctconst _ -> "Pctconst" + | Pisint -> "Pisint" + | Pisout -> "Pisout" + | Pbintofint _ -> "Pbintofint" + | Pintofbint _ -> "Pintofbint" + | Pcvtbint _ -> "Pcvtbint" + | Pnegbint _ -> "Pnegbint" + | Paddbint _ -> "Paddbint" + | Psubbint _ -> "Psubbint" + | Pmulbint _ -> "Pmulbint" + | Pdivbint _ -> "Pdivbint" + | Pmodbint _ -> "Pmodbint" + | Pandbint _ -> "Pandbint" + | Porbint _ -> "Porbint" + | Pxorbint _ -> "Pxorbint" + | Plslbint _ -> "Plslbint" + | Plsrbint _ -> "Plsrbint" + | Pasrbint _ -> "Pasrbint" + | Pbintcomp _ -> "Pbintcomp" + | Pbigarrayref _ -> "Pbigarrayref" + | Pbigarrayset _ -> "Pbigarrayset" + | Pbigarraydim _ -> "Pbigarraydim" + | Pstring_load_16 _ -> "Pstring_load_16" + | Pstring_load_32 _ -> "Pstring_load_32" + | Pstring_load_64 _ -> "Pstring_load_64" + | Pbytes_load_16 _ -> "Pbytes_load_16" + | Pbytes_load_32 _ -> "Pbytes_load_32" + | Pbytes_load_64 _ -> "Pbytes_load_64" + | Pbytes_set_16 _ -> "Pbytes_set_16" + | Pbytes_set_32 _ -> "Pbytes_set_32" + | Pbytes_set_64 _ -> "Pbytes_set_64" + | Pbigstring_load_16 _ -> "Pbigstring_load_16" + | Pbigstring_load_32 _ -> "Pbigstring_load_32" + | Pbigstring_load_64 _ -> "Pbigstring_load_64" + | Pbigstring_set_16 _ -> "Pbigstring_set_16" + | Pbigstring_set_32 _ -> "Pbigstring_set_32" + | Pbigstring_set_64 _ -> "Pbigstring_set_64" + | Pbswap16 -> "Pbswap16" + | Pbbswap _ -> "Pbbswap" + | Pint_as_pointer -> "Pint_as_pointer" + | Popaque -> "Popaque" + +let function_attribute ppf { inline; specialise; local; is_a_functor; stub } = + if is_a_functor then + fprintf ppf "is_a_functor@ "; + if stub then + fprintf ppf "stub@ "; + begin match inline with + | Default_inline -> () + | Always_inline -> fprintf ppf "always_inline@ " + | Never_inline -> fprintf ppf "never_inline@ " + | Unroll i -> fprintf ppf "unroll(%i)@ " i + end; + begin match specialise with + | Default_specialise -> () + | Always_specialise -> fprintf ppf "always_specialise@ " + | Never_specialise -> fprintf ppf "never_specialise@ " + end; + begin match local with + | Default_local -> () + | Always_local -> fprintf ppf "always_local@ " + | Never_local -> fprintf ppf "never_local@ " + end + +let apply_tailcall_attribute ppf tailcall = + if tailcall then + fprintf ppf " @@tailcall" + +let apply_inlined_attribute ppf = function + | Default_inline -> () + | Always_inline -> fprintf ppf " always_inline" + | Never_inline -> fprintf ppf " never_inline" + | Unroll i -> fprintf ppf " never_inline(%i)" i + +let apply_specialised_attribute ppf = function + | Default_specialise -> () + | Always_specialise -> fprintf ppf " always_specialise" + | Never_specialise -> fprintf ppf " never_specialise" + +let rec lam ppf = function + | Lvar id -> + Ident.print ppf id + | Lconst cst -> + struct_const ppf cst + | Lapply ap -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(apply@ %a%a%a%a%a)@]" lam ap.ap_func lams ap.ap_args + apply_tailcall_attribute ap.ap_should_be_tailcall + apply_inlined_attribute ap.ap_inlined + apply_specialised_attribute ap.ap_specialised + | Lfunction{kind; params; return; body; attr} -> + let pr_params ppf params = + match kind with + | Curried -> + List.iter (fun (param, k) -> + fprintf ppf "@ %a%a" Ident.print param value_kind k) params + | Tupled -> + fprintf ppf " ("; + let first = ref true in + List.iter + (fun (param, k) -> + if !first then first := false else fprintf ppf ",@ "; + Ident.print ppf param; + value_kind ppf k) + params; + fprintf ppf ")" in + fprintf ppf "@[<2>(function%a@ %a%a%a)@]" pr_params params + function_attribute attr return_kind return lam body + | Llet(str, k, id, arg, body) -> + let kind = function + Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v" + in + let rec letbody = function + | Llet(str, k, id, arg, body) -> + fprintf ppf "@ @[<2>%a =%s%a@ %a@]" + Ident.print id (kind str) value_kind k lam arg; + letbody body + | expr -> expr in + fprintf ppf "@[<2>(let@ @[(@[<2>%a =%s%a@ %a@]" + Ident.print id (kind str) value_kind k lam arg; + let expr = letbody body in + fprintf ppf ")@]@ %a)@]" lam expr + | Lletrec(id_arg_list, body) -> + let bindings ppf id_arg_list = + let spc = ref false in + List.iter + (fun (id, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<2>%a@ %a@]" Ident.print id lam l) + id_arg_list in + fprintf ppf + "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body + | Lprim(prim, largs, _) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs + | Lswitch(larg, sw, _loc) -> + let switch ppf sw = + let spc = ref false in + List.iter + (fun (n, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case int %i:@ %a@]" n lam l) + sw.sw_consts; + List.iter + (fun (n, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case tag %i:@ %a@]" n lam l) + sw.sw_blocks ; + begin match sw.sw_failaction with + | None -> () + | Some l -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam l + end in + fprintf ppf + "@[<1>(%s %a@ @[%a@])@]" + (match sw.sw_failaction with None -> "switch*" | _ -> "switch") + lam larg switch sw + | Lstringswitch(arg, cases, default, _) -> + let switch ppf cases = + let spc = ref false in + List.iter + (fun (s, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) + cases; + begin match default with + | Some default -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam default + | None -> () + end in + fprintf ppf + "@[<1>(stringswitch %a@ @[%a@])@]" lam arg switch cases + | Lstaticraise (i, ls) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls; + | Lstaticcatch(lbody, (i, vars), lhandler) -> + fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" + lam lbody i + (fun ppf vars -> + List.iter + (fun (x, k) -> fprintf ppf " %a%a" Ident.print x value_kind k) + vars + ) + vars + lam lhandler + | Ltrywith(lbody, param, lhandler) -> + fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" + lam lbody Ident.print param lam lhandler + | Lifthenelse(lcond, lif, lelse) -> + fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse + | Lsequence(l1, l2) -> + fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 + | Lwhile(lcond, lbody) -> + fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody + | Lfor(param, lo, hi, dir, body) -> + fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" + Ident.print param lam lo + (match dir with Upto -> "to" | Downto -> "downto") + lam hi lam body + | Lassign(id, expr) -> + fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr + | Lsend (k, met, obj, largs, _) -> + let args ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + let kind = + if k = Self then "self" else if k = Cached then "cache" else "" in + fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs + | Levent(expr, ev) -> + let kind = + match ev.lev_kind with + | Lev_before -> "before" + | Lev_after _ -> "after" + | Lev_function -> "funct-body" + | Lev_pseudo -> "pseudo" + | Lev_module_definition ident -> + Format.asprintf "module-defn(%a)" Ident.print ident + in + fprintf ppf "@[<2>(%s %s(%i)%s:%i-%i@ %a)@]" kind + ev.lev_loc.Location.loc_start.Lexing.pos_fname + ev.lev_loc.Location.loc_start.Lexing.pos_lnum + (if ev.lev_loc.Location.loc_ghost then "" else "") + ev.lev_loc.Location.loc_start.Lexing.pos_cnum + ev.lev_loc.Location.loc_end.Lexing.pos_cnum + lam expr + | Lifused(id, expr) -> + fprintf ppf "@[<2>(ifused@ %a@ %a)@]" Ident.print id lam expr + +and sequence ppf = function + | Lsequence(l1, l2) -> + fprintf ppf "%a@ %a" sequence l1 sequence l2 + | l -> + lam ppf l + +let structured_constant = struct_const + +let lambda = lam + +let program ppf { code } = lambda ppf code diff --git a/lambda/printlambda.mli b/lambda/printlambda.mli new file mode 100644 index 00000000..7dab5229 --- /dev/null +++ b/lambda/printlambda.mli @@ -0,0 +1,32 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Lambda + +open Format + +val integer_comparison: formatter -> integer_comparison -> unit +val float_comparison: formatter -> float_comparison -> unit +val structured_constant: formatter -> structured_constant -> unit +val lambda: formatter -> lambda -> unit +val program: formatter -> program -> unit +val primitive: formatter -> primitive -> unit +val name_of_primitive : primitive -> string +val value_kind : formatter -> value_kind -> unit +val block_shape : formatter -> value_kind list option -> unit +val record_rep : formatter -> Types.record_representation -> unit +val print_bigarray : + string -> bool -> Lambda.bigarray_kind -> formatter -> + Lambda.bigarray_layout -> unit diff --git a/lambda/runtimedef.mli b/lambda/runtimedef.mli new file mode 100644 index 00000000..3baabb64 --- /dev/null +++ b/lambda/runtimedef.mli @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Values and functions known and/or provided by the runtime system *) + +val builtin_exceptions: string array +val builtin_primitives: string array diff --git a/lambda/simplif.ml b/lambda/simplif.ml new file mode 100644 index 00000000..2aa6e66a --- /dev/null +++ b/lambda/simplif.ml @@ -0,0 +1,855 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Elimination of useless Llet(Alias) bindings. + Also transform let-bound references into variables. *) + +open Asttypes +open Lambda + +(* To transform let-bound references into variables *) + +exception Real_reference + +let rec eliminate_ref id = function + Lvar v as lam -> + if Ident.same v id then raise Real_reference else lam + | Lconst _ as lam -> lam + | Lapply ap -> + Lapply{ap with ap_func = eliminate_ref id ap.ap_func; + ap_args = List.map (eliminate_ref id) ap.ap_args} + | Lfunction _ as lam -> + if Ident.Set.mem id (free_variables lam) + then raise Real_reference + else lam + | Llet(str, kind, v, e1, e2) -> + Llet(str, kind, v, eliminate_ref id e1, eliminate_ref id e2) + | Lletrec(idel, e2) -> + Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel, + eliminate_ref id e2) + | Lprim(Pfield 0, [Lvar v], _) when Ident.same v id -> + Lvar id + | Lprim(Psetfield(0, _, _), [Lvar v; e], _) when Ident.same v id -> + Lassign(id, eliminate_ref id e) + | Lprim(Poffsetref delta, [Lvar v], loc) when Ident.same v id -> + Lassign(id, Lprim(Poffsetint delta, [Lvar id], loc)) + | Lprim(p, el, loc) -> + Lprim(p, List.map (eliminate_ref id) el, loc) + | Lswitch(e, sw, loc) -> + Lswitch(eliminate_ref id e, + {sw_numconsts = sw.sw_numconsts; + sw_consts = + List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_consts; + sw_numblocks = sw.sw_numblocks; + sw_blocks = + List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks; + sw_failaction = + Misc.may_map (eliminate_ref id) sw.sw_failaction; }, + loc) + | Lstringswitch(e, sw, default, loc) -> + Lstringswitch + (eliminate_ref id e, + List.map (fun (s, e) -> (s, eliminate_ref id e)) sw, + Misc.may_map (eliminate_ref id) default, loc) + | Lstaticraise (i,args) -> + Lstaticraise (i,List.map (eliminate_ref id) args) + | Lstaticcatch(e1, i, e2) -> + Lstaticcatch(eliminate_ref id e1, i, eliminate_ref id e2) + | Ltrywith(e1, v, e2) -> + Ltrywith(eliminate_ref id e1, v, eliminate_ref id e2) + | Lifthenelse(e1, e2, e3) -> + Lifthenelse(eliminate_ref id e1, + eliminate_ref id e2, + eliminate_ref id e3) + | Lsequence(e1, e2) -> + Lsequence(eliminate_ref id e1, eliminate_ref id e2) + | Lwhile(e1, e2) -> + Lwhile(eliminate_ref id e1, eliminate_ref id e2) + | Lfor(v, e1, e2, dir, e3) -> + Lfor(v, eliminate_ref id e1, eliminate_ref id e2, + dir, eliminate_ref id e3) + | Lassign(v, e) -> + Lassign(v, eliminate_ref id e) + | Lsend(k, m, o, el, loc) -> + Lsend(k, eliminate_ref id m, eliminate_ref id o, + List.map (eliminate_ref id) el, loc) + | Levent(l, ev) -> + Levent(eliminate_ref id l, ev) + | Lifused(v, e) -> + Lifused(v, eliminate_ref id e) + +(* Simplification of exits *) + +type exit = { + mutable count: int; + mutable max_depth: int; +} + +let simplify_exits lam = + + (* Count occurrences of (exit n ...) statements *) + let exits = Hashtbl.create 17 in + + let try_depth = ref 0 in + + let get_exit i = + try Hashtbl.find exits i + with Not_found -> {count = 0; max_depth = 0} + + and incr_exit i nb d = + match Hashtbl.find_opt exits i with + | Some r -> + r.count <- r.count + nb; + r.max_depth <- max r.max_depth d + | None -> + let r = {count = nb; max_depth = d} in + Hashtbl.add exits i r + in + + let rec count = function + | (Lvar _| Lconst _) -> () + | Lapply ap -> count ap.ap_func; List.iter count ap.ap_args + | Lfunction {body} -> count body + | Llet(_str, _kind, _v, l1, l2) -> + count l2; count l1 + | Lletrec(bindings, body) -> + List.iter (fun (_v, l) -> count l) bindings; + count body + | Lprim(_p, ll, _) -> List.iter count ll + | Lswitch(l, sw, _loc) -> + count_default sw ; + count l; + List.iter (fun (_, l) -> count l) sw.sw_consts; + List.iter (fun (_, l) -> count l) sw.sw_blocks + | Lstringswitch(l, sw, d, _) -> + count l; + List.iter (fun (_, l) -> count l) sw; + begin match d with + | None -> () + | Some d -> match sw with + | []|[_] -> count d + | _ -> count d; count d (* default will get replicated *) + end + | Lstaticraise (i,ls) -> incr_exit i 1 !try_depth; List.iter count ls + | Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) -> + (* i will be replaced by j in l1, so each occurrence of i in l1 + increases j's ref count *) + count l1 ; + let ic = get_exit i in + incr_exit j ic.count (max !try_depth ic.max_depth) + | Lstaticcatch(l1, (i,_), l2) -> + count l1; + (* If l1 does not contain (exit i), + l2 will be removed, so don't count its exits *) + if (get_exit i).count > 0 then + count l2 + | Ltrywith(l1, _v, l2) -> incr try_depth; count l1; decr try_depth; count l2 + | Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3 + | Lsequence(l1, l2) -> count l1; count l2 + | Lwhile(l1, l2) -> count l1; count l2 + | Lfor(_, l1, l2, _dir, l3) -> count l1; count l2; count l3 + | Lassign(_v, l) -> count l + | Lsend(_k, m, o, ll, _) -> List.iter count (m::o::ll) + | Levent(l, _) -> count l + | Lifused(_v, l) -> count l + + and count_default sw = match sw.sw_failaction with + | None -> () + | Some al -> + let nconsts = List.length sw.sw_consts + and nblocks = List.length sw.sw_blocks in + if + nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks + then begin (* default action will occur twice in native code *) + count al ; count al + end else begin (* default action will occur once *) + assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ; + count al + end + in + count lam; + assert(!try_depth = 0); + + (* + Second pass simplify ``catch body with (i ...) handler'' + - if (exit i ...) does not occur in body, suppress catch + - if (exit i ...) occurs exactly once in body, + substitute it with handler + - If handler is a single variable, replace (exit i ..) with it + Note: + In ``catch body with (i x1 .. xn) handler'' + Substituted expression is + let y1 = x1 and ... yn = xn in + handler[x1 <- y1 ; ... ; xn <- yn] + For the sake of preserving the uniqueness of bound variables. + (No alpha conversion of ``handler'' is presently needed, since + substitution of several ``(exit i ...)'' + occurs only when ``handler'' is a variable.) + *) + + let subst = Hashtbl.create 17 in + + let rec simplif = function + | (Lvar _|Lconst _) as l -> l + | Lapply ap -> + Lapply{ap with ap_func = simplif ap.ap_func; + ap_args = List.map simplif ap.ap_args} + | Lfunction{kind; params; return; body = l; attr; loc} -> + Lfunction{kind; params; return; body = simplif l; attr; loc} + | Llet(str, kind, v, l1, l2) -> Llet(str, kind, v, simplif l1, simplif l2) + | Lletrec(bindings, body) -> + Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) + | Lprim(p, ll, loc) -> begin + let ll = List.map simplif ll in + match p, ll with + (* Simplify %revapply, for n-ary functions with n > 1 *) + | Prevapply, [x; Lapply ap] + | Prevapply, [x; Levent (Lapply ap,_)] -> + Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc} + | Prevapply, [x; f] -> Lapply {ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=f; + ap_args=[x]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} + + (* Simplify %apply, for n-ary functions with n > 1 *) + | Pdirapply, [Lapply ap; x] + | Pdirapply, [Levent (Lapply ap,_); x] -> + Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc} + | Pdirapply, [f; x] -> Lapply {ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=f; + ap_args=[x]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} + (* Simplify %identity *) + | Pidentity, [e] -> e + + (* Simplify Obj.with_tag *) + | Pccall { Primitive.prim_name = "caml_obj_with_tag"; _ }, + [Lconst (Const_base (Const_int tag)); + Lprim (Pmakeblock (_, mut, shape), fields, loc)] -> + Lprim (Pmakeblock(tag, mut, shape), fields, loc) + | Pccall { Primitive.prim_name = "caml_obj_with_tag"; _ }, + [Lconst (Const_base (Const_int tag)); + Lconst (Const_block (_, fields))] -> + Lconst (Const_block (tag, fields)) + + | _ -> Lprim(p, ll, loc) + end + | Lswitch(l, sw, loc) -> + let new_l = simplif l + and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts + and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks + and new_fail = Misc.may_map simplif sw.sw_failaction in + Lswitch + (new_l, + {sw with sw_consts = new_consts ; sw_blocks = new_blocks; + sw_failaction = new_fail}, + loc) + | Lstringswitch(l,sw,d,loc) -> + Lstringswitch + (simplif l,List.map (fun (s,l) -> s,simplif l) sw, + Misc.may_map simplif d,loc) + | Lstaticraise (i,[]) as l -> + begin try + let _,handler = Hashtbl.find subst i in + handler + with + | Not_found -> l + end + | Lstaticraise (i,ls) -> + let ls = List.map simplif ls in + begin try + let xs,handler = Hashtbl.find subst i in + let ys = List.map (fun (x, k) -> Ident.rename x, k) xs in + let env = + List.fold_right2 + (fun (x, _) (y, _) env -> Ident.Map.add x y env) + xs ys Ident.Map.empty + in + List.fold_right2 + (fun (y, kind) l r -> Llet (Strict, kind, y, l, r)) + ys ls (Lambda.rename env handler) + with + | Not_found -> Lstaticraise (i,ls) + end + | Lstaticcatch (l1,(i,[]),(Lstaticraise (_j,[]) as l2)) -> + Hashtbl.add subst i ([],simplif l2) ; + simplif l1 + | Lstaticcatch (l1,(i,xs),l2) -> + let {count; max_depth} = get_exit i in + if count = 0 then + (* Discard staticcatch: not matching exit *) + simplif l1 + else if count = 1 && max_depth <= !try_depth then begin + (* Inline handler if there is a single occurrence and it is not + nested within an inner try..with *) + assert(max_depth = !try_depth); + Hashtbl.add subst i (xs,simplif l2); + simplif l1 + end else + Lstaticcatch (simplif l1, (i,xs), simplif l2) + | Ltrywith(l1, v, l2) -> + incr try_depth; + let l1 = simplif l1 in + decr try_depth; + Ltrywith(l1, v, simplif l2) + | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3) + | Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2) + | Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2) + | Lfor(v, l1, l2, dir, l3) -> + Lfor(v, simplif l1, simplif l2, dir, simplif l3) + | Lassign(v, l) -> Lassign(v, simplif l) + | Lsend(k, m, o, ll, loc) -> + Lsend(k, simplif m, simplif o, List.map simplif ll, loc) + | Levent(l, ev) -> Levent(simplif l, ev) + | Lifused(v, l) -> Lifused (v,simplif l) + in + simplif lam + +(* Compile-time beta-reduction of functions immediately applied: + Lapply(Lfunction(Curried, params, body), args, loc) -> + let paramN = argN in ... let param1 = arg1 in body + Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock(args))], loc) -> + let paramN = argN in ... let param1 = arg1 in body + Assumes |args| = |params|. +*) + +let beta_reduce params body args = + List.fold_left2 (fun l (param, kind) arg -> Llet(Strict, kind, param, arg, l)) + body params args + +(* Simplification of lets *) + +let simplify_lets lam = + + (* Disable optimisations for bytecode compilation with -g flag *) + let optimize = !Clflags.native_code || not !Clflags.debug in + + (* First pass: count the occurrences of all let-bound identifiers *) + + let occ = (Hashtbl.create 83: (Ident.t, int ref) Hashtbl.t) in + (* The global table [occ] associates to each let-bound identifier + the number of its uses (as a reference): + - 0 if never used + - 1 if used exactly once in and not under a lambda or within a loop + - > 1 if used several times or under a lambda or within a loop. + The local table [bv] associates to each locally-let-bound variable + its reference count, as above. [bv] is enriched at let bindings + but emptied when crossing lambdas and loops. *) + + (* Current use count of a variable. *) + let count_var v = + try + !(Hashtbl.find occ v) + with Not_found -> + 0 + + (* Entering a [let]. Returns updated [bv]. *) + and bind_var bv v = + let r = ref 0 in + Hashtbl.add occ v r; + Ident.Map.add v r bv + + (* Record a use of a variable *) + and use_var bv v n = + try + let r = Ident.Map.find v bv in r := !r + n + with Not_found -> + (* v is not locally bound, therefore this is a use under a lambda + or within a loop. Increase use count by 2 -- enough so + that single-use optimizations will not apply. *) + try + let r = Hashtbl.find occ v in r := !r + 2 + with Not_found -> + (* Not a let-bound variable, ignore *) + () in + + let rec count bv = function + | Lconst _ -> () + | Lvar v -> + use_var bv v 1 + | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args} + when optimize && List.length params = List.length args -> + count bv (beta_reduce params body args) + | Lapply{ap_func = Lfunction{kind = Tupled; params; body}; + ap_args = [Lprim(Pmakeblock _, args, _)]} + when optimize && List.length params = List.length args -> + count bv (beta_reduce params body args) + | Lapply{ap_func = l1; ap_args = ll} -> + count bv l1; List.iter (count bv) ll + | Lfunction {body} -> + count Ident.Map.empty body + | Llet(_str, _k, v, Lvar w, l2) when optimize -> + (* v will be replaced by w in l2, so each occurrence of v in l2 + increases w's refcount *) + count (bind_var bv v) l2; + use_var bv w (count_var v) + | Llet(str, _kind, v, l1, l2) -> + count (bind_var bv v) l2; + (* If v is unused, l1 will be removed, so don't count its variables *) + if str = Strict || count_var v > 0 then count bv l1 + | Lletrec(bindings, body) -> + List.iter (fun (_v, l) -> count bv l) bindings; + count bv body + | Lprim(_p, ll, _) -> List.iter (count bv) ll + | Lswitch(l, sw, _loc) -> + count_default bv sw ; + count bv l; + List.iter (fun (_, l) -> count bv l) sw.sw_consts; + List.iter (fun (_, l) -> count bv l) sw.sw_blocks + | Lstringswitch(l, sw, d, _) -> + count bv l ; + List.iter (fun (_, l) -> count bv l) sw ; + begin match d with + | Some d -> + begin match sw with + | []|[_] -> count bv d + | _ -> count bv d ; count bv d + end + | None -> () + end + | Lstaticraise (_i,ls) -> List.iter (count bv) ls + | Lstaticcatch(l1, _, l2) -> count bv l1; count bv l2 + | Ltrywith(l1, _v, l2) -> count bv l1; count bv l2 + | Lifthenelse(l1, l2, l3) -> count bv l1; count bv l2; count bv l3 + | Lsequence(l1, l2) -> count bv l1; count bv l2 + | Lwhile(l1, l2) -> count Ident.Map.empty l1; count Ident.Map.empty l2 + | Lfor(_, l1, l2, _dir, l3) -> + count bv l1; count bv l2; count Ident.Map.empty l3 + | Lassign(_v, l) -> + (* Lalias-bound variables are never assigned, so don't increase + v's refcount *) + count bv l + | Lsend(_, m, o, ll, _) -> List.iter (count bv) (m::o::ll) + | Levent(l, _) -> count bv l + | Lifused(v, l) -> + if count_var v > 0 then count bv l + + and count_default bv sw = match sw.sw_failaction with + | None -> () + | Some al -> + let nconsts = List.length sw.sw_consts + and nblocks = List.length sw.sw_blocks in + if + nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks + then begin (* default action will occur twice in native code *) + count bv al ; count bv al + end else begin (* default action will occur once *) + assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ; + count bv al + end + in + count Ident.Map.empty lam; + + (* Second pass: remove Lalias bindings of unused variables, + and substitute the bindings of variables used exactly once. *) + + let subst = Hashtbl.create 83 in + +(* This (small) optimisation is always legal, it may uncover some + tail call later on. *) + + let mklet str kind v e1 e2 = match e2 with + | Lvar w when optimize && Ident.same v w -> e1 + | _ -> Llet (str, kind,v,e1,e2) in + + + let rec simplif = function + Lvar v as l -> + begin try + Hashtbl.find subst v + with Not_found -> + l + end + | Lconst _ as l -> l + | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args} + when optimize && List.length params = List.length args -> + simplif (beta_reduce params body args) + | Lapply{ap_func = Lfunction{kind = Tupled; params; body}; + ap_args = [Lprim(Pmakeblock _, args, _)]} + when optimize && List.length params = List.length args -> + simplif (beta_reduce params body args) + | Lapply ap -> Lapply {ap with ap_func = simplif ap.ap_func; + ap_args = List.map simplif ap.ap_args} + | Lfunction{kind; params; return=return1; body = l; attr; loc} -> + begin match simplif l with + Lfunction{kind=Curried; params=params'; return=return2; body; attr; loc} + when kind = Curried && optimize -> + (* The return type is the type of the value returned after + applying all the parameters to the function. The return + type of the merged function taking [params @ params'] as + parameters is the type returned after applying [params']. *) + let return = return2 in + Lfunction{kind; params = params @ params'; return; body; attr; loc} + | body -> + Lfunction{kind; params; return = return1; body; attr; loc} + end + | Llet(_str, _k, v, Lvar w, l2) when optimize -> + Hashtbl.add subst v (simplif (Lvar w)); + simplif l2 + | Llet(Strict, kind, v, + Lprim(Pmakeblock(0, Mutable, kind_ref) as prim, [linit], loc), lbody) + when optimize -> + let slinit = simplif linit in + let slbody = simplif lbody in + begin try + let kind = match kind_ref with + | None -> Pgenval + | Some [field_kind] -> field_kind + | Some _ -> assert false + in + mklet Variable kind v slinit (eliminate_ref v slbody) + with Real_reference -> + mklet Strict kind v (Lprim(prim, [slinit], loc)) slbody + end + | Llet(Alias, kind, v, l1, l2) -> + begin match count_var v with + 0 -> simplif l2 + | 1 when optimize -> Hashtbl.add subst v (simplif l1); simplif l2 + | _ -> Llet(Alias, kind, v, simplif l1, simplif l2) + end + | Llet(StrictOpt, kind, v, l1, l2) -> + begin match count_var v with + 0 -> simplif l2 + | _ -> mklet StrictOpt kind v (simplif l1) (simplif l2) + end + | Llet(str, kind, v, l1, l2) -> mklet str kind v (simplif l1) (simplif l2) + | Lletrec(bindings, body) -> + Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) + | Lprim(p, ll, loc) -> Lprim(p, List.map simplif ll, loc) + | Lswitch(l, sw, loc) -> + let new_l = simplif l + and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts + and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks + and new_fail = Misc.may_map simplif sw.sw_failaction in + Lswitch + (new_l, + {sw with sw_consts = new_consts ; sw_blocks = new_blocks; + sw_failaction = new_fail}, + loc) + | Lstringswitch (l,sw,d,loc) -> + Lstringswitch + (simplif l,List.map (fun (s,l) -> s,simplif l) sw, + Misc.may_map simplif d,loc) + | Lstaticraise (i,ls) -> + Lstaticraise (i, List.map simplif ls) + | Lstaticcatch(l1, (i,args), l2) -> + Lstaticcatch (simplif l1, (i,args), simplif l2) + | Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2) + | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3) + | Lsequence(Lifused(v, l1), l2) -> + if count_var v > 0 + then Lsequence(simplif l1, simplif l2) + else simplif l2 + | Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2) + | Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2) + | Lfor(v, l1, l2, dir, l3) -> + Lfor(v, simplif l1, simplif l2, dir, simplif l3) + | Lassign(v, l) -> Lassign(v, simplif l) + | Lsend(k, m, o, ll, loc) -> + Lsend(k, simplif m, simplif o, List.map simplif ll, loc) + | Levent(l, ev) -> Levent(simplif l, ev) + | Lifused(v, l) -> + if count_var v > 0 then simplif l else lambda_unit + in + simplif lam + +(* Tail call info in annotation files *) + +let is_tail_native_heuristic : (int -> bool) ref = + ref (fun _ -> true) + +let rec emit_tail_infos is_tail lambda = + let call_kind args = + if is_tail + && ((not !Clflags.native_code) + || (!is_tail_native_heuristic (List.length args))) + then Annot.Tail + else Annot.Stack in + match lambda with + | Lvar _ -> () + | Lconst _ -> () + | Lapply ap -> + if ap.ap_should_be_tailcall + && not is_tail + && Warnings.is_active Warnings.Expect_tailcall + then Location.prerr_warning ap.ap_loc Warnings.Expect_tailcall; + emit_tail_infos false ap.ap_func; + list_emit_tail_infos false ap.ap_args; + if !Clflags.annotations then + Stypes.record (Stypes.An_call (ap.ap_loc, call_kind ap.ap_args)) + | Lfunction {body = lam} -> + emit_tail_infos true lam + | Llet (_str, _k, _, lam, body) -> + emit_tail_infos false lam; + emit_tail_infos is_tail body + | Lletrec (bindings, body) -> + List.iter (fun (_, lam) -> emit_tail_infos false lam) bindings; + emit_tail_infos is_tail body + | Lprim (Pidentity, [arg], _) -> + emit_tail_infos is_tail arg + | Lprim ((Pbytes_to_string | Pbytes_of_string), [arg], _) -> + emit_tail_infos is_tail arg + | Lprim (Psequand, [arg1; arg2], _) + | Lprim (Psequor, [arg1; arg2], _) -> + emit_tail_infos false arg1; + emit_tail_infos is_tail arg2 + | Lprim (_, l, _) -> + list_emit_tail_infos false l + | Lswitch (lam, sw, _loc) -> + emit_tail_infos false lam; + list_emit_tail_infos_fun snd is_tail sw.sw_consts; + list_emit_tail_infos_fun snd is_tail sw.sw_blocks; + Misc.may (emit_tail_infos is_tail) sw.sw_failaction + | Lstringswitch (lam, sw, d, _) -> + emit_tail_infos false lam; + List.iter + (fun (_,lam) -> emit_tail_infos is_tail lam) + sw ; + Misc.may (emit_tail_infos is_tail) d + | Lstaticraise (_, l) -> + list_emit_tail_infos false l + | Lstaticcatch (body, _, handler) -> + emit_tail_infos is_tail body; + emit_tail_infos is_tail handler + | Ltrywith (body, _, handler) -> + emit_tail_infos false body; + emit_tail_infos is_tail handler + | Lifthenelse (cond, ifso, ifno) -> + emit_tail_infos false cond; + emit_tail_infos is_tail ifso; + emit_tail_infos is_tail ifno + | Lsequence (lam1, lam2) -> + emit_tail_infos false lam1; + emit_tail_infos is_tail lam2 + | Lwhile (cond, body) -> + emit_tail_infos false cond; + emit_tail_infos false body + | Lfor (_, low, high, _, body) -> + emit_tail_infos false low; + emit_tail_infos false high; + emit_tail_infos false body + | Lassign (_, lam) -> + emit_tail_infos false lam + | Lsend (_, meth, obj, args, loc) -> + emit_tail_infos false meth; + emit_tail_infos false obj; + list_emit_tail_infos false args; + if !Clflags.annotations then + Stypes.record (Stypes.An_call (loc, call_kind (obj :: args))); + | Levent (lam, _) -> + emit_tail_infos is_tail lam + | Lifused (_, lam) -> + emit_tail_infos is_tail lam +and list_emit_tail_infos_fun f is_tail = + List.iter (fun x -> emit_tail_infos is_tail (f x)) +and list_emit_tail_infos is_tail = + List.iter (emit_tail_infos is_tail) + +(* Split a function with default parameters into a wrapper and an + inner function. The wrapper fills in missing optional parameters + with their default value and tail-calls the inner function. The + wrapper can then hopefully be inlined on most call sites to avoid + the overhead associated with boxing an optional argument with a + 'Some' constructor, only to deconstruct it immediately in the + function's body. *) + +let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ~attr ~loc = + let rec aux map = function + | Llet(Strict, k, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when + Ident.name optparam = "*opt*" && List.mem_assoc optparam params + && not (List.mem_assoc optparam map) + -> + let wrapper_body, inner = aux ((optparam, id) :: map) rest in + Llet(Strict, k, id, def, wrapper_body), inner + | _ when map = [] -> raise Exit + | body -> + (* Check that those *opt* identifiers don't appear in the remaining + body. This should not appear, but let's be on the safe side. *) + let fv = Lambda.free_variables body in + List.iter (fun (id, _) -> if Ident.Set.mem id fv then raise Exit) map; + + let inner_id = Ident.create_local (Ident.name fun_id ^ "_inner") in + let map_param p = try List.assoc p map with Not_found -> p in + let args = List.map (fun (p, _) -> Lvar (map_param p)) params in + let wrapper_body = + Lapply { + ap_func = Lvar inner_id; + ap_args = args; + ap_loc = Location.none; + ap_should_be_tailcall = false; + ap_inlined = Default_inline; + ap_specialised = Default_specialise; + } + in + let inner_params = List.map map_param (List.map fst params) in + let new_ids = List.map Ident.rename inner_params in + let subst = + List.fold_left2 (fun s id new_id -> + Ident.Map.add id new_id s + ) Ident.Map.empty inner_params new_ids + in + let body = Lambda.rename subst body in + let inner_fun = + Lfunction { kind = Curried; + params = List.map (fun id -> id, Pgenval) new_ids; + return; body; attr; loc; } + in + (wrapper_body, (inner_id, inner_fun)) + in + try + let body, inner = aux [] body in + let attr = default_stub_attribute in + [(fun_id, Lfunction{kind; params; return; body; attr; loc}); inner] + with Exit -> + [(fun_id, Lfunction{kind; params; return; body; attr; loc})] + +(* Simplify local let-bound functions: if all occurrences are + fully-applied function calls in the same "tail scope", replace the + function by a staticcatch handler (on that scope). + + This handles as a special case functions used exactly once (in any + scope) for a full application. +*) + +type slot = + { + nargs: int; + mutable scope: lambda option; + } + +module LamTbl = Hashtbl.Make(struct + type t = lambda + let equal = (==) + let hash = Hashtbl.hash + end) + +let simplify_local_functions lam = + let slots = Hashtbl.create 16 in + let static_id = Hashtbl.create 16 in (* function id -> static id *) + let static = LamTbl.create 16 in (* scope -> static function on that scope *) + (* We keep track of the current "tail scope", identified + by the outermost lambda for which the the current lambda + is in tail position. *) + let current_scope = ref lam in + let check_static lf = + if lf.attr.local = Always_local then + Location.prerr_warning lf.loc + (Warnings.Inlining_impossible + "This function cannot be compiled into a static continuation") + in + let enabled = function + | {local = Always_local; _} + | {local = Default_local; inline = (Never_inline | Default_inline); _} + -> true + | {local = Default_local; inline = (Always_inline | Unroll _); _} + | {local = Never_local; _} + -> false + in + let rec tail = function + | Llet (_str, _kind, id, Lfunction lf, cont) + when Lambda.function_is_curried lf && enabled lf.attr -> + let r = {nargs=List.length lf.params; scope=None} in + Hashtbl.add slots id r; + tail cont; + begin match Hashtbl.find_opt slots id with + | Some {scope = Some scope; _} -> + let st = next_raise_count () in + let sc = + (* Do not move higher than current lambda *) + if scope == !current_scope then cont + else scope + in + Hashtbl.add static_id id st; + LamTbl.add static sc (st, lf); + (* The body of the function will become an handler + in that "scope". *) + with_scope ~scope lf.body + | _ -> + check_static lf; + (* note: if scope = None, the function is unused *) + non_tail lf.body + end + | Lapply {ap_func = Lvar id; ap_args; _} -> + begin match Hashtbl.find_opt slots id with + | Some {nargs; _} when nargs <> List.length ap_args -> + (* Wrong arity *) + Hashtbl.remove slots id + | Some {scope = Some scope; _} when scope != !current_scope -> + (* Different "tail scope" *) + Hashtbl.remove slots id + | Some ({scope = None; _} as slot) -> + (* First use of the function: remember the current tail scope *) + slot.scope <- Some !current_scope + | _ -> + () + end; + List.iter non_tail ap_args + | Lvar id -> + Hashtbl.remove slots id + | Lfunction lf as lam -> + check_static lf; + Lambda.shallow_iter ~tail ~non_tail lam + | lam -> + Lambda.shallow_iter ~tail ~non_tail lam + and non_tail lam = + with_scope ~scope:lam lam + and with_scope ~scope lam = + let old_scope = !current_scope in + current_scope := scope; + tail lam; + current_scope := old_scope + in + tail lam; + let rec rewrite lam0 = + let lam = + match lam0 with + | Llet (_, _, id, _, cont) when Hashtbl.mem static_id id -> + rewrite cont + | Lapply {ap_func = Lvar id; ap_args; _} when Hashtbl.mem static_id id -> + Lstaticraise (Hashtbl.find static_id id, List.map rewrite ap_args) + | lam -> + Lambda.shallow_map rewrite lam + in + List.fold_right + (fun (st, lf) lam -> + Lstaticcatch (lam, (st, lf.params), rewrite lf.body) + ) + (LamTbl.find_all static lam0) + lam + in + if LamTbl.length static = 0 then + lam + else + rewrite lam + +(* The entry point: + simplification + emission of tailcall annotations, if needed. *) + +let simplify_lambda lam = + let lam = + lam + |> (if !Clflags.native_code || not !Clflags.debug + then simplify_local_functions else Fun.id + ) + |> simplify_exits + |> simplify_lets + in + if !Clflags.annotations || Warnings.is_active Warnings.Expect_tailcall + then emit_tail_infos true lam; + lam diff --git a/lambda/simplif.mli b/lambda/simplif.mli new file mode 100644 index 00000000..d5ca210e --- /dev/null +++ b/lambda/simplif.mli @@ -0,0 +1,44 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Lambda simplification. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +(* Elimination of useless Llet(Alias) bindings. + Transformation of let-bound references into variables. + Simplification over staticraise/staticcatch constructs. + Generation of tail-call annotations if -annot is set. *) + +open Lambda + +val simplify_lambda: lambda -> lambda + +val split_default_wrapper + : id:Ident.t + -> kind:function_kind + -> params:(Ident.t * Lambda.value_kind) list + -> return:Lambda.value_kind + -> body:lambda + -> attr:function_attribute + -> loc:Location.t + -> (Ident.t * lambda) list + +(* To be filled by asmcomp/selectgen.ml *) +val is_tail_native_heuristic: (int -> bool) ref + (* # arguments -> can tailcall *) diff --git a/lambda/switch.ml b/lambda/switch.ml new file mode 100644 index 00000000..89bfe83a --- /dev/null +++ b/lambda/switch.ml @@ -0,0 +1,877 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + +type 'a shared = Shared of 'a | Single of 'a + +type ('a, 'ctx) t_store = + {act_get : unit -> 'a array ; + act_get_shared : unit -> 'a shared array ; + act_store : 'ctx -> 'a -> int ; + act_store_shared : 'ctx -> 'a -> int ; } + +exception Not_simple + +module type Stored = sig + type t + type key + val compare_key : key -> key -> int + val make_key : t -> key option +end + +module type CtxStored = sig + include Stored + type context + val make_key : context -> t -> key option +end + +module CtxStore(A:CtxStored) = struct + module AMap = + Map.Make(struct type t = A.key let compare = A.compare_key end) + + type intern = + { mutable map : (bool * int) AMap.t ; + mutable next : int ; + mutable acts : (bool * A.t) list; } + + let mk_store () = + let st = + { map = AMap.empty ; + next = 0 ; + acts = [] ; } in + + let add mustshare act = + let i = st.next in + st.acts <- (mustshare,act) :: st.acts ; + st.next <- i+1 ; + i in + + let store mustshare ctx act = match A.make_key ctx act with + | Some key -> + begin try + let (shared,i) = AMap.find key st.map in + if not shared then st.map <- AMap.add key (true,i) st.map ; + i + with Not_found -> + let i = add mustshare act in + st.map <- AMap.add key (mustshare,i) st.map ; + i + end + | None -> + add mustshare act + + and get () = Array.of_list (List.rev_map (fun (_,act) -> act) st.acts) + + and get_shared () = + let acts = + Array.of_list + (List.rev_map + (fun (shared,act) -> + if shared then Shared act else Single act) + st.acts) in + AMap.iter + (fun _ (shared,i) -> + if shared then match acts.(i) with + | Single act -> acts.(i) <- Shared act + | Shared _ -> ()) + st.map ; + acts in + {act_store = store false ; act_store_shared = store true ; + act_get = get; act_get_shared = get_shared; } +end + +module Store(A:Stored) = struct + module Me = + CtxStore + (struct + include A + type context = unit + let make_key () = A.make_key + end) + + let mk_store = Me.mk_store +end + + + +module type S = +sig + type primitive + val eqint : primitive + val neint : primitive + val leint : primitive + val ltint : primitive + val geint : primitive + val gtint : primitive + type act + + val bind : act -> (act -> act) -> act + val make_const : int -> act + val make_offset : act -> int -> act + val make_prim : primitive -> act list -> act + val make_isout : act -> act -> act + val make_isin : act -> act -> act + val make_if : act -> act -> act -> act + val make_switch : Location.t -> act -> int array -> act array -> act + val make_catch : act -> int * (act -> act) + val make_exit : int -> act +end + +(* The module will ``produce good code for the case statement'' *) +(* + Adaptation of + R.L. Berstein + ``Producing good code for the case statement'' + Software Practice and Experience, 15(10) (1985) + and + D.L. Spuler + ``Two-Way Comparison Search Trees, a Generalisation of Binary Search Trees + and Split Trees'' + ``Compiler Code Generation for Multiway Branch Statement as + a Static Search Problem'' + Technical Reports, James Cook University +*) +(* + Main adaptation is considering interval tests + (implemented as one addition + one unsigned test and branch) + which leads to exhaustive search for finding the optimal + test sequence in small cases and heuristics otherwise. +*) +module Make (Arg : S) = +struct + + type 'a inter = + {cases : (int * int * int) array ; + actions : 'a array} + + type 'a t_ctx = {off : int ; arg : 'a} + + let cut = ref 8 + and more_cut = ref 16 + +(* +let pint chan i = + if i = min_int then Printf.fprintf chan "-oo" + else if i=max_int then Printf.fprintf chan "oo" + else Printf.fprintf chan "%d" i + +let pcases chan cases = + for i =0 to Array.length cases-1 do + let l,h,act = cases.(i) in + if l=h then + Printf.fprintf chan "%d:%d " l act + else + Printf.fprintf chan "%a..%a:%d " pint l pint h act + done + +let prerr_inter i = Printf.fprintf stderr + "cases=%a" pcases i.cases +*) + + let get_act cases i = + let _,_,r = cases.(i) in + r + and get_low cases i = + let r,_,_ = cases.(i) in + r + + type ctests = { + mutable n : int ; + mutable ni : int ; + } + + let too_much = {n=max_int ; ni=max_int} + +(* +let ptests chan {n=n ; ni=ni} = + Printf.fprintf chan "{n=%d ; ni=%d}" n ni + +let pta chan t = + for i =0 to Array.length t-1 do + Printf.fprintf chan "%d: %a\n" i ptests t.(i) + done +*) + + let less_tests c1 c2 = + if c1.n < c2.n then + true + else if c1.n = c2.n then begin + if c1.ni < c2.ni then + true + else + false + end else + false + + and eq_tests c1 c2 = c1.n = c2.n && c1.ni=c2.ni + + let less2tests (c1,d1) (c2,d2) = + if eq_tests c1 c2 then + less_tests d1 d2 + else + less_tests c1 c2 + + let add_test t1 t2 = + t1.n <- t1.n + t2.n ; + t1.ni <- t1.ni + t2.ni ; + + type t_ret = Inter of int * int | Sep of int | No + +(* +let pret chan = function + | Inter (i,j)-> Printf.fprintf chan "Inter %d %d" i j + | Sep i -> Printf.fprintf chan "Sep %d" i + | No -> Printf.fprintf chan "No" +*) + + let coupe cases i = + let l,_,_ = cases.(i) in + l, + Array.sub cases 0 i, + Array.sub cases i (Array.length cases-i) + + + let case_append c1 c2 = + let len1 = Array.length c1 + and len2 = Array.length c2 in + match len1,len2 with + | 0,_ -> c2 + | _,0 -> c1 + | _,_ -> + let l1,h1,act1 = c1.(Array.length c1-1) + and l2,h2,act2 = c2.(0) in + if act1 = act2 then + let r = Array.make (len1+len2-1) c1.(0) in + for i = 0 to len1-2 do + r.(i) <- c1.(i) + done ; + + let l = + if len1-2 >= 0 then begin + let _,h,_ = r.(len1-2) in + if h+1 < l1 then + h+1 + else + l1 + end else + l1 + and h = + if 1 < len2-1 then begin + let l,_,_ = c2.(1) in + if h2+1 < l then + l-1 + else + h2 + end else + h2 in + r.(len1-1) <- (l,h,act1) ; + for i=1 to len2-1 do + r.(len1-1+i) <- c2.(i) + done ; + r + else if h1 > l1 then + let r = Array.make (len1+len2) c1.(0) in + for i = 0 to len1-2 do + r.(i) <- c1.(i) + done ; + r.(len1-1) <- (l1,l2-1,act1) ; + for i=0 to len2-1 do + r.(len1+i) <- c2.(i) + done ; + r + else if h2 > l2 then + let r = Array.make (len1+len2) c1.(0) in + for i = 0 to len1-1 do + r.(i) <- c1.(i) + done ; + r.(len1) <- (h1+1,h2,act2) ; + for i=1 to len2-1 do + r.(len1+i) <- c2.(i) + done ; + r + else + Array.append c1 c2 + + + let coupe_inter i j cases = + let lcases = Array.length cases in + let low,_,_ = cases.(i) + and _,high,_ = cases.(j) in + low,high, + Array.sub cases i (j-i+1), + case_append (Array.sub cases 0 i) (Array.sub cases (j+1) (lcases-(j+1))) + + type kind = Kvalue of int | Kinter of int | Kempty + +(* +let pkind chan = function + | Kvalue i ->Printf.fprintf chan "V%d" i + | Kinter i -> Printf.fprintf chan "I%d" i + | Kempty -> Printf.fprintf chan "E" + +let rec pkey chan = function + | [] -> () + | [k] -> pkind chan k + | k::rem -> + Printf.fprintf chan "%a %a" pkey rem pkind k +*) + + let t = Hashtbl.create 17 + + let make_key cases = + let seen = ref [] + and count = ref 0 in + let rec got_it act = function + | [] -> + seen := (act,!count):: !seen ; + let r = !count in + incr count ; + r + | (act0,index) :: rem -> + if act0 = act then + index + else + got_it act rem in + + let make_one l h act = + if l=h then + Kvalue (got_it act !seen) + else + Kinter (got_it act !seen) in + + let rec make_rec i pl = + if i < 0 then + [] + else + let l,h,act = cases.(i) in + if pl = h+1 then + make_one l h act::make_rec (i-1) l + else + Kempty::make_one l h act::make_rec (i-1) l in + + let l,h,act = cases.(Array.length cases-1) in + make_one l h act::make_rec (Array.length cases-2) l + + + let same_act t = + let len = Array.length t in + let a = get_act t (len-1) in + let rec do_rec i = + if i < 0 then true + else + let b = get_act t i in + b=a && do_rec (i-1) in + do_rec (len-2) + + +(* + Interval test x in [l,h] works by checking x-l in [0,h-l] + * This may be false for arithmetic modulo 2^31 + * Subtracting l may change the relative ordering of values + and invalid the invariant that matched values are given in + increasing order + + To avoid this, interval check is allowed only when the + integers indeed present in the whole case interval are + in [-2^16 ; 2^16] + + This condition is checked by zyva +*) + + let inter_limit = 1 lsl 16 + + let ok_inter = ref false + + let rec opt_count top cases = + let key = make_key cases in + try + Hashtbl.find t key + with + | Not_found -> + let r = + let lcases = Array.length cases in + match lcases with + | 0 -> assert false + | _ when same_act cases -> No, ({n=0; ni=0},{n=0; ni=0}) + | _ -> + if lcases < !cut then + enum top cases + else if lcases < !more_cut then + heuristic cases + else + divide cases in + Hashtbl.add t key r ; + r + + and divide cases = + let lcases = Array.length cases in + let m = lcases/2 in + let _,left,right = coupe cases m in + let ci = {n=1 ; ni=0} + and cm = {n=1 ; ni=0} + and _,(cml,cleft) = opt_count false left + and _,(cmr,cright) = opt_count false right in + add_test ci cleft ; + add_test ci cright ; + if less_tests cml cmr then + add_test cm cmr + else + add_test cm cml ; + Sep m,(cm, ci) + + and heuristic cases = + let lcases = Array.length cases in + + let sep,csep = divide cases + + and inter,cinter = + if !ok_inter then begin + let _,_,act0 = cases.(0) + and _,_,act1 = cases.(lcases-1) in + if act0 = act1 then begin + let low, high, inside, outside = coupe_inter 1 (lcases-2) cases in + let _,(cmi,cinside) = opt_count false inside + and _,(cmo,coutside) = opt_count false outside + and cmij = {n=1 ; ni=(if low=high then 0 else 1)} + and cij = {n=1 ; ni=(if low=high then 0 else 1)} in + add_test cij cinside ; + add_test cij coutside ; + if less_tests cmi cmo then + add_test cmij cmo + else + add_test cmij cmi ; + Inter (1,lcases-2),(cmij,cij) + end else + Inter (-1,-1),(too_much, too_much) + end else + Inter (-1,-1),(too_much, too_much) in + if less2tests csep cinter then + sep,csep + else + inter,cinter + + + and enum top cases = + let lcases = Array.length cases in + let lim, with_sep = + let best = ref (-1) and best_cost = ref (too_much,too_much) in + + for i = 1 to lcases-(1) do + let _,left,right = coupe cases i in + let ci = {n=1 ; ni=0} + and cm = {n=1 ; ni=0} + and _,(cml,cleft) = opt_count false left + and _,(cmr,cright) = opt_count false right in + add_test ci cleft ; + add_test ci cright ; + if less_tests cml cmr then + add_test cm cmr + else + add_test cm cml ; + + if + less2tests (cm,ci) !best_cost + then begin + if top then + Printf.fprintf stderr "Get it: %d\n" i ; + best := i ; + best_cost := (cm,ci) + end + done ; + !best, !best_cost in + + let ilow, ihigh, with_inter = + if not !ok_inter then + let rlow = ref (-1) and rhigh = ref (-1) + and best_cost= ref (too_much,too_much) in + for i=1 to lcases-2 do + let low, high, inside, outside = coupe_inter i i cases in + if low=high then begin + let _,(cmi,cinside) = opt_count false inside + and _,(cmo,coutside) = opt_count false outside + and cmij = {n=1 ; ni=0} + and cij = {n=1 ; ni=0} in + add_test cij cinside ; + add_test cij coutside ; + if less_tests cmi cmo then + add_test cmij cmo + else + add_test cmij cmi ; + if less2tests (cmij,cij) !best_cost then begin + rlow := i ; + rhigh := i ; + best_cost := (cmij,cij) + end + end + done ; + !rlow, !rhigh, !best_cost + else + let rlow = ref (-1) and rhigh = ref (-1) + and best_cost= ref (too_much,too_much) in + for i=1 to lcases-2 do + for j=i to lcases-2 do + let low, high, inside, outside = coupe_inter i j cases in + let _,(cmi,cinside) = opt_count false inside + and _,(cmo,coutside) = opt_count false outside + and cmij = {n=1 ; ni=(if low=high then 0 else 1)} + and cij = {n=1 ; ni=(if low=high then 0 else 1)} in + add_test cij cinside ; + add_test cij coutside ; + if less_tests cmi cmo then + add_test cmij cmo + else + add_test cmij cmi ; + if less2tests (cmij,cij) !best_cost then begin + rlow := i ; + rhigh := j ; + best_cost := (cmij,cij) + end + done + done ; + !rlow, !rhigh, !best_cost in + let r = ref (Inter (ilow,ihigh)) and rc = ref with_inter in + if less2tests with_sep !rc then begin + r := Sep lim ; rc := with_sep + end ; + !r, !rc + + let make_if_test test arg i ifso ifnot = + Arg.make_if + (Arg.make_prim test [arg ; Arg.make_const i]) + ifso ifnot + + let make_if_lt arg i ifso ifnot = match i with + | 1 -> + make_if_test Arg.leint arg 0 ifso ifnot + | _ -> + make_if_test Arg.ltint arg i ifso ifnot + + and make_if_ge arg i ifso ifnot = match i with + | 1 -> + make_if_test Arg.gtint arg 0 ifso ifnot + | _ -> + make_if_test Arg.geint arg i ifso ifnot + + and make_if_eq arg i ifso ifnot = + make_if_test Arg.eqint arg i ifso ifnot + + and make_if_ne arg i ifso ifnot = + make_if_test Arg.neint arg i ifso ifnot + + let do_make_if_out h arg ifso ifno = + Arg.make_if (Arg.make_isout h arg) ifso ifno + + let make_if_out ctx l d mk_ifso mk_ifno = match l with + | 0 -> + do_make_if_out + (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + | _ -> + Arg.bind + (Arg.make_offset ctx.arg (-l)) + (fun arg -> + let ctx = {off= (-l+ctx.off) ; arg=arg} in + do_make_if_out + (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) + + let do_make_if_in h arg ifso ifno = + Arg.make_if (Arg.make_isin h arg) ifso ifno + + let make_if_in ctx l d mk_ifso mk_ifno = match l with + | 0 -> + do_make_if_in + (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + | _ -> + Arg.bind + (Arg.make_offset ctx.arg (-l)) + (fun arg -> + let ctx = {off= (-l+ctx.off) ; arg=arg} in + do_make_if_in + (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) + + let rec c_test ctx ({cases=cases ; actions=actions} as s) = + let lcases = Array.length cases in + assert(lcases > 0) ; + if lcases = 1 then + actions.(get_act cases 0) ctx + + else begin + + let w,_c = opt_count false cases in +(* + Printf.fprintf stderr + "off=%d tactic=%a for %a\n" + ctx.off pret w pcases cases ; + *) + match w with + | No -> actions.(get_act cases 0) ctx + | Inter (i,j) -> + let low,high,inside, outside = coupe_inter i j cases in + let _,(cinside,_) = opt_count false inside + and _,(coutside,_) = opt_count false outside in + (* Costs are retrieved to put the code with more remaining tests + in the privileged (positive) branch of ``if'' *) + if low=high then begin + if less_tests coutside cinside then + make_if_eq + ctx.arg + (low+ctx.off) + (c_test ctx {s with cases=inside}) + (c_test ctx {s with cases=outside}) + else + make_if_ne + ctx.arg + (low+ctx.off) + (c_test ctx {s with cases=outside}) + (c_test ctx {s with cases=inside}) + end else begin + if less_tests coutside cinside then + make_if_in + ctx + (low+ctx.off) + (high-low) + (fun ctx -> c_test ctx {s with cases=inside}) + (fun ctx -> c_test ctx {s with cases=outside}) + else + make_if_out + ctx + (low+ctx.off) + (high-low) + (fun ctx -> c_test ctx {s with cases=outside}) + (fun ctx -> c_test ctx {s with cases=inside}) + end + | Sep i -> + let lim,left,right = coupe cases i in + let _,(cleft,_) = opt_count false left + and _,(cright,_) = opt_count false right in + let left = {s with cases=left} + and right = {s with cases=right} in + + if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then + make_if_ne + ctx.arg 0 + (c_test ctx right) (c_test ctx left) + else if less_tests cright cleft then + make_if_lt + ctx.arg (lim+ctx.off) + (c_test ctx left) (c_test ctx right) + else + make_if_ge + ctx.arg (lim+ctx.off) + (c_test ctx right) (c_test ctx left) + + end + + + (* Minimal density of switches *) + let theta = ref 0.33333 + + (* Minimal number of tests to make a switch *) + let switch_min = ref 3 + + (* Particular case 0, 1, 2 *) + let particular_case cases i j = + j-i = 2 && + (let l1,_h1,act1 = cases.(i) + and l2,_h2,_act2 = cases.(i+1) + and l3,h3,act3 = cases.(i+2) in + l1+1=l2 && l2+1=l3 && l3=h3 && + act1 <> act3) + + let approx_count cases i j = + let l = j-i+1 in + if l < !cut then + let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in + ntests + else + l-1 + + (* Sends back a boolean that says whether is switch is worth or not *) + + let dense {cases} i j = + if i=j then true + else + let l,_,_ = cases.(i) + and _,h,_ = cases.(j) in + let ntests = approx_count cases i j in +(* + (ntests+1) >= theta * (h-l+1) +*) + particular_case cases i j || + (ntests >= !switch_min && + float_of_int ntests +. 1.0 >= + !theta *. (float_of_int h -. float_of_int l +. 1.0)) + + (* Compute clusters by dynamic programming + Adaptation of the correction to Bernstein + ``Correction to `Producing Good Code for the Case Statement' '' + S.K. Kannan and T.A. Proebsting + Software Practice and Experience Vol. 24(2) 233 (Feb 1994) + *) + + let comp_clusters s = + let len = Array.length s.cases in + let min_clusters = Array.make len max_int + and k = Array.make len 0 in + let get_min i = if i < 0 then 0 else min_clusters.(i) in + + for i = 0 to len-1 do + for j = 0 to i do + if + dense s j i && + get_min (j-1) + 1 < min_clusters.(i) + then begin + k.(i) <- j ; + min_clusters.(i) <- get_min (j-1) + 1 + end + done ; + done ; + min_clusters.(len-1),k + + (* Assume j > i *) + let make_switch loc {cases=cases ; actions=actions} i j = + let ll,_,_ = cases.(i) + and _,hh,_ = cases.(j) in + let tbl = Array.make (hh-ll+1) 0 + and t = Hashtbl.create 17 + and index = ref 0 in + let get_index act = + try + Hashtbl.find t act + with + | Not_found -> + let i = !index in + incr index ; + Hashtbl.add t act i ; + i in + + for k=i to j do + let l,h,act = cases.(k) in + let index = get_index act in + for kk=l-ll to h-ll do + tbl.(kk) <- index + done + done ; + let acts = Array.make !index actions.(0) in + Hashtbl.iter + (fun act i -> acts.(i) <- actions.(act)) + t ; + (fun ctx -> + match -ll-ctx.off with + | 0 -> Arg.make_switch loc ctx.arg tbl acts + | _ -> + Arg.bind + (Arg.make_offset ctx.arg (-ll-ctx.off)) + (fun arg -> Arg.make_switch loc arg tbl acts)) + + + let make_clusters loc ({cases=cases ; actions=actions} as s) n_clusters k = + let len = Array.length cases in + let r = Array.make n_clusters (0,0,0) + and t = Hashtbl.create 17 + and index = ref 0 + and bidon = ref (Array.length actions) in + let get_index act = + try + let i,_ = Hashtbl.find t act in + i + with + | Not_found -> + let i = !index in + incr index ; + Hashtbl.add + t act + (i,(fun _ -> actions.(act))) ; + i + and add_index act = + let i = !index in + incr index ; + incr bidon ; + Hashtbl.add t !bidon (i,act) ; + i in + + let rec zyva j ir = + let i = k.(j) in + begin if i=j then + let l,h,act = cases.(i) in + r.(ir) <- (l,h,get_index act) + else (* assert i < j *) + let l,_,_ = cases.(i) + and _,h,_ = cases.(j) in + r.(ir) <- (l,h,add_index (make_switch loc s i j)) + end ; + if i > 0 then zyva (i-1) (ir-1) in + + zyva (len-1) (n_clusters-1) ; + let acts = Array.make !index (fun _ -> assert false) in + Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ; + {cases = r ; actions = acts} + ;; + + + let do_zyva loc (low,high) arg cases actions = + let old_ok = !ok_inter in + ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ; + if !ok_inter <> old_ok then Hashtbl.clear t ; + + let s = {cases=cases ; actions=actions} in + +(* + Printf.eprintf "ZYVA: %B [low=%i,high=%i]\n" !ok_inter low high ; + pcases stderr cases ; + prerr_endline "" ; +*) + let n_clusters,k = comp_clusters s in + let clusters = make_clusters loc s n_clusters k in + c_test {arg=arg ; off=0} clusters + + let abstract_shared actions = + let handlers = ref (fun x -> x) in + let actions = + Array.map + (fun act -> match act with + | Single act -> act + | Shared act -> + let i,h = Arg.make_catch act in + let oh = !handlers in + handlers := (fun act -> h (oh act)) ; + Arg.make_exit i) + actions in + !handlers,actions + + let zyva loc lh arg cases actions = + assert (Array.length cases > 0) ; + let actions = actions.act_get_shared () in + let hs,actions = abstract_shared actions in + hs (do_zyva loc lh arg cases actions) + + and test_sequence arg cases actions = + assert (Array.length cases > 0) ; + let actions = actions.act_get_shared () in + let hs,actions = abstract_shared actions in + let old_ok = !ok_inter in + ok_inter := false ; + if !ok_inter <> old_ok then Hashtbl.clear t ; + let s = + {cases=cases ; + actions=Array.map (fun act -> (fun _ -> act)) actions} in +(* + Printf.eprintf "SEQUENCE: %B\n" !ok_inter ; + pcases stderr cases ; + prerr_endline "" ; +*) + hs (c_test {arg=arg ; off=0} s) + ;; + +end diff --git a/lambda/switch.mli b/lambda/switch.mli new file mode 100644 index 00000000..b4058c17 --- /dev/null +++ b/lambda/switch.mli @@ -0,0 +1,129 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* + This module transforms generic switches in combinations + of if tests and switches. +*) + +(* For detecting action sharing, object style *) + +(* Store for actions in object style: + act_store : store an action, returns index in table + In case an action with equal key exists, returns index + of the stored action. Otherwise add entry in table. + act_store_shared : This stored action will always be shared. + act_get : retrieve table + act_get_shared : retrieve table, with sharing explicit +*) + +type 'a shared = Shared of 'a | Single of 'a + +type ('a, 'ctx) t_store = + {act_get : unit -> 'a array ; + act_get_shared : unit -> 'a shared array ; + act_store : 'ctx -> 'a -> int ; + act_store_shared : 'ctx -> 'a -> int ; } + +exception Not_simple + +module type Stored = sig + type t + type key + val compare_key : key -> key -> int + val make_key : t -> key option +end + +module type CtxStored = sig + include Stored + type context + val make_key : context -> t -> key option +end + +module CtxStore(A:CtxStored) : + sig + val mk_store : unit -> (A.t, A.context) t_store + end + +module Store(A:Stored) : + sig + val mk_store : unit -> (A.t, unit) t_store + end + +(* Arguments to the Make functor *) +module type S = + sig + (* type of basic tests *) + type primitive + (* basic tests themselves *) + val eqint : primitive + val neint : primitive + val leint : primitive + val ltint : primitive + val geint : primitive + val gtint : primitive + (* type of actions *) + type act + + (* Various constructors, for making a binder, + adding one integer, etc. *) + val bind : act -> (act -> act) -> act + val make_const : int -> act + val make_offset : act -> int -> act + val make_prim : primitive -> act list -> act + val make_isout : act -> act -> act + val make_isin : act -> act -> act + val make_if : act -> act -> act -> act + (* construct an actual switch : + make_switch arg cases acts + NB: cases is in the value form *) + val make_switch : + Location.t -> act -> int array -> act array -> act + (* Build last minute sharing of action stuff *) + val make_catch : act -> int * (act -> act) + val make_exit : int -> act + + end + + +(* + Make.zyva arg low high cases actions where + - arg is the argument of the switch. + - low, high are the interval limits. + - cases is a list of sub-interval and action indices + - actions is an array of actions. + + All these arguments specify a switch construct and zyva + returns an action that performs the switch. +*) +module Make : + functor (Arg : S) -> + sig +(* Standard entry point, sharing is tracked *) + val zyva : + Location.t -> + (int * int) -> + Arg.act -> + (int * int * int) array -> + (Arg.act, _) t_store -> + Arg.act + +(* Output test sequence, sharing tracked *) + val test_sequence : + Arg.act -> + (int * int * int) array -> + (Arg.act, _) t_store -> + Arg.act + end diff --git a/lambda/translattribute.ml b/lambda/translattribute.ml new file mode 100644 index 00000000..1520a3b4 --- /dev/null +++ b/lambda/translattribute.ml @@ -0,0 +1,332 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Typedtree +open Lambda +open Location + +let is_inline_attribute = function + | {txt=("inline"|"ocaml.inline")} -> true + | _ -> false + +let is_inlined_attribute = function + | {txt=("inlined"|"ocaml.inlined")} -> true + | {txt=("unrolled"|"ocaml.unrolled")} when Config.flambda -> true + | _ -> false + +let is_specialise_attribute = function + | {txt=("specialise"|"ocaml.specialise")} when Config.flambda -> true + | _ -> false + +let is_specialised_attribute = function + | {txt=("specialised"|"ocaml.specialised")} when Config.flambda -> true + | _ -> false + +let is_local_attribute = function + | {txt=("local"|"ocaml.local")} -> true + | _ -> false + +let find_attribute p attributes = + let inline_attribute, other_attributes = + List.partition (fun a -> p a.Parsetree.attr_name) attributes + in + let attr = + match inline_attribute with + | [] -> None + | [attr] -> Some attr + | _ :: {Parsetree.attr_name = {txt;loc}; _} :: _ -> + Location.prerr_warning loc (Warnings.Duplicated_attribute txt); + None + in + attr, other_attributes + +let is_unrolled = function + | {txt="unrolled"|"ocaml.unrolled"} -> true + | {txt="inline"|"ocaml.inline"|"inlined"|"ocaml.inlined"} -> false + | _ -> assert false + +let get_id_payload = + let open Parsetree in + function + | PStr [] -> Some "" + | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] -> + begin match pexp_desc with + | Pexp_ident { txt = Longident.Lident id } -> Some id + | _ -> None + end + | _ -> None + +let parse_id_payload txt loc ~default ~empty cases payload = + let[@local] warn () = + let ( %> ) f g x = g (f x) in + let msg = + cases + |> List.map (fst %> Printf.sprintf "'%s'") + |> String.concat ", " + |> Printf.sprintf "It must be either %s or empty" + in + Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg)); + default + in + match get_id_payload payload with + | Some "" -> empty + | None -> warn () + | Some id -> + match List.assoc_opt id cases with + | Some r -> r + | None -> warn () + +let parse_inline_attribute attr = + match attr with + | None -> Default_inline + | Some {Parsetree.attr_name = {txt;loc} as id; attr_payload = payload} -> + let open Parsetree in + if is_unrolled id then begin + (* the 'unrolled' attributes must be used as [@unrolled n]. *) + let warning txt = Warnings.Attribute_payload + (txt, "It must be an integer literal") + in + match payload with + | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] -> begin + match pexp_desc with + | Pexp_constant (Pconst_integer(s, None)) -> begin + try + Unroll (Misc.Int_literal_converter.int s) + with Failure _ -> + Location.prerr_warning loc (warning txt); + Default_inline + end + | _ -> + Location.prerr_warning loc (warning txt); + Default_inline + end + | _ -> + Location.prerr_warning loc (warning txt); + Default_inline + end else + parse_id_payload txt loc + ~default:Default_inline + ~empty:Always_inline + [ + "never", Never_inline; + "always", Always_inline; + ] + payload + +let parse_specialise_attribute attr = + match attr with + | None -> Default_specialise + | Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} -> + parse_id_payload txt loc + ~default:Default_specialise + ~empty:Always_specialise + [ + "never", Never_specialise; + "always", Always_specialise; + ] + payload + +let parse_local_attribute attr = + match attr with + | None -> Default_local + | Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} -> + parse_id_payload txt loc + ~default:Default_local + ~empty:Always_local + [ + "never", Never_local; + "always", Always_local; + "maybe", Default_local; + ] + payload + +let get_inline_attribute l = + let attr, _ = find_attribute is_inline_attribute l in + parse_inline_attribute attr + +let get_specialise_attribute l = + let attr, _ = find_attribute is_specialise_attribute l in + parse_specialise_attribute attr + +let get_local_attribute l = + let attr, _ = find_attribute is_local_attribute l in + parse_local_attribute attr + +let check_local_inline loc attr = + match attr.local, attr.inline with + | Always_local, (Always_inline | Unroll _) -> + Location.prerr_warning loc + (Warnings.Duplicated_attribute "local/inline") + | _ -> + () + +let add_inline_attribute expr loc attributes = + match expr, get_inline_attribute attributes with + | expr, Default_inline -> expr + | Lfunction({ attr = { stub = false } as attr } as funct), inline -> + begin match attr.inline with + | Default_inline -> () + | Always_inline | Never_inline | Unroll _ -> + Location.prerr_warning loc + (Warnings.Duplicated_attribute "inline") + end; + let attr = { attr with inline } in + check_local_inline loc attr; + Lfunction { funct with attr = attr } + | expr, (Always_inline | Never_inline | Unroll _) -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute "inline"); + expr + +let add_specialise_attribute expr loc attributes = + match expr, get_specialise_attribute attributes with + | expr, Default_specialise -> expr + | Lfunction({ attr = { stub = false } as attr } as funct), specialise -> + begin match attr.specialise with + | Default_specialise -> () + | Always_specialise | Never_specialise -> + Location.prerr_warning loc + (Warnings.Duplicated_attribute "specialise") + end; + let attr = { attr with specialise } in + Lfunction { funct with attr } + | expr, (Always_specialise | Never_specialise) -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute "specialise"); + expr + +let add_local_attribute expr loc attributes = + match expr, get_local_attribute attributes with + | expr, Default_local -> expr + | Lfunction({ attr = { stub = false } as attr } as funct), local -> + begin match attr.local with + | Default_local -> () + | Always_local | Never_local -> + Location.prerr_warning loc + (Warnings.Duplicated_attribute "local") + end; + let attr = { attr with local } in + check_local_inline loc attr; + Lfunction { funct with attr } + | expr, (Always_local | Never_local) -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute "local"); + expr + +(* Get the [@inlined] attribute payload (or default if not present). + It also returns the expression without this attribute. This is + used to ensure that this attribute is not misplaced: If it + appears on any expression, it is an error, otherwise it would + have been removed by this function *) +let get_and_remove_inlined_attribute e = + let attr, exp_attributes = + find_attribute is_inlined_attribute e.exp_attributes + in + let inlined = parse_inline_attribute attr in + inlined, { e with exp_attributes } + +let get_and_remove_inlined_attribute_on_module e = + let rec get_and_remove mod_expr = + let attr, mod_attributes = + find_attribute is_inlined_attribute mod_expr.mod_attributes + in + let attr = parse_inline_attribute attr in + let attr, mod_desc = + match mod_expr.Typedtree.mod_desc with + | Tmod_constraint (me, mt, mtc, mc) -> + let inner_attr, me = get_and_remove me in + let attr = + match attr with + | Always_inline | Never_inline | Unroll _ -> attr + | Default_inline -> inner_attr + in + attr, Tmod_constraint (me, mt, mtc, mc) + | md -> attr, md + in + attr, { mod_expr with mod_desc; mod_attributes } + in + get_and_remove e + +let get_and_remove_specialised_attribute e = + let attr, exp_attributes = + find_attribute is_specialised_attribute e.exp_attributes + in + let specialised = parse_specialise_attribute attr in + specialised, { e with exp_attributes } + +(* It also removes the attribute from the expression, like + get_inlined_attribute *) +let get_tailcall_attribute e = + let is_tailcall_attribute = function + | {Parsetree.attr_name = {txt=("tailcall"|"ocaml.tailcall")}; _} -> true + | _ -> false + in + let tailcalls, exp_attributes = + List.partition is_tailcall_attribute e.exp_attributes + in + match tailcalls with + | [] -> false, e + | _ :: r -> + begin match r with + | [] -> () + | {Parsetree.attr_name = {txt;loc}; _} :: _ -> + Location.prerr_warning loc (Warnings.Duplicated_attribute txt) + end; + true, { e with exp_attributes } + +let check_attribute e {Parsetree.attr_name = { txt; loc }; _} = + match txt with + | "inline" | "ocaml.inline" + | "specialise" | "ocaml.specialise" -> begin + match e.exp_desc with + | Texp_function _ -> () + | _ -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute txt) + end + | "inlined" | "ocaml.inlined" + | "specialised" | "ocaml.specialised" + | "tailcall" | "ocaml.tailcall" -> + (* Removed by the Texp_apply cases *) + Location.prerr_warning loc + (Warnings.Misplaced_attribute txt) + | _ -> () + +let check_attribute_on_module e {Parsetree.attr_name = { txt; loc }; _} = + match txt with + | "inline" | "ocaml.inline" -> begin + match e.mod_desc with + | Tmod_functor _ -> () + | _ -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute txt) + end + | "inlined" | "ocaml.inlined" -> + (* Removed by the Texp_apply cases *) + Location.prerr_warning loc + (Warnings.Misplaced_attribute txt) + | _ -> () + +let add_function_attributes lam loc attr = + let lam = + add_inline_attribute lam loc attr + in + let lam = + add_specialise_attribute lam loc attr + in + let lam = + add_local_attribute lam loc attr + in + lam diff --git a/lambda/translattribute.mli b/lambda/translattribute.mli new file mode 100644 index 00000000..bf22fd1c --- /dev/null +++ b/lambda/translattribute.mli @@ -0,0 +1,76 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +val check_attribute + : Typedtree.expression + -> Parsetree.attribute + -> unit + +val check_attribute_on_module + : Typedtree.module_expr + -> Parsetree.attribute + -> unit + +val add_inline_attribute + : Lambda.lambda + -> Location.t + -> Parsetree.attributes + -> Lambda.lambda + +val get_inline_attribute + : Parsetree.attributes + -> Lambda.inline_attribute + +val add_specialise_attribute + : Lambda.lambda + -> Location.t + -> Parsetree.attributes + -> Lambda.lambda + +val get_specialise_attribute + : Parsetree.attributes + -> Lambda.specialise_attribute + +val add_local_attribute + : Lambda.lambda + -> Location.t + -> Parsetree.attributes + -> Lambda.lambda + +val get_local_attribute + : Parsetree.attributes + -> Lambda.local_attribute + +val get_and_remove_inlined_attribute + : Typedtree.expression + -> Lambda.inline_attribute * Typedtree.expression + +val get_and_remove_inlined_attribute_on_module + : Typedtree.module_expr + -> Lambda.inline_attribute * Typedtree.module_expr + +val get_and_remove_specialised_attribute + : Typedtree.expression + -> Lambda.specialise_attribute * Typedtree.expression + +val get_tailcall_attribute + : Typedtree.expression + -> bool * Typedtree.expression + +val add_function_attributes + : Lambda.lambda + -> Location.t + -> Parsetree.attributes + -> Lambda.lambda diff --git a/lambda/translclass.ml b/lambda/translclass.ml new file mode 100644 index 00000000..10b09066 --- /dev/null +++ b/lambda/translclass.ml @@ -0,0 +1,946 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Types +open Typedtree +open Lambda +open Translobj +open Translcore + +(* XXX Rajouter des evenements... | Add more events... *) + +type error = Tags of label * label + +exception Error of Location.t * error + +let lfunction params body = + if params = [] then body else + match body with + | Lfunction {kind = Curried; params = params'; body = body'; attr; loc} -> + Lfunction {kind = Curried; params = params @ params'; + return = Pgenval; + body = body'; attr; + loc} + | _ -> + Lfunction {kind = Curried; params; return = Pgenval; + body; + attr = default_function_attribute; + loc = Location.none} + +let lapply ap = + match ap.ap_func with + Lapply ap' -> + Lapply {ap with ap_func = ap'.ap_func; ap_args = ap'.ap_args @ ap.ap_args} + | _ -> + Lapply ap + +let mkappl (func, args) = + Lapply {ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=func; + ap_args=args; + ap_inlined=Default_inline; + ap_specialised=Default_specialise};; + +let lsequence l1 l2 = + if l2 = lambda_unit then l1 else Lsequence(l1, l2) + +let lfield v i = Lprim(Pfield i, [Lvar v], Location.none) + +let transl_label l = share (Const_immstring l) + +let transl_meth_list lst = + if lst = [] then Lconst (Const_pointer 0) else + share (Const_block + (0, List.map (fun lab -> Const_immstring lab) lst)) + +let set_inst_var obj id expr = + Lprim(Psetfield_computed (Typeopt.maybe_pointer expr, Assignment), + [Lvar obj; Lvar id; transl_exp expr], Location.none) + +let transl_val tbl create name = + mkappl (oo_prim (if create then "new_variable" else "get_variable"), + [Lvar tbl; transl_label name]) + +let transl_vals tbl create strict vals rem = + List.fold_right + (fun (name, id) rem -> + Llet(strict, Pgenval, id, transl_val tbl create name, rem)) + vals rem + +let meths_super tbl meths inh_meths = + List.fold_right + (fun (nm, id) rem -> + try + (nm, id, + mkappl(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)])) + :: rem + with Not_found -> rem) + inh_meths [] + +let bind_super tbl (vals, meths) cl_init = + transl_vals tbl false StrictOpt vals + (List.fold_right (fun (_nm, id, def) rem -> + Llet(StrictOpt, Pgenval, id, def, rem)) + meths cl_init) + +let create_object cl obj init = + let obj' = Ident.create_local "self" in + let (inh_init, obj_init, has_init) = init obj' in + if obj_init = lambda_unit then + (inh_init, + mkappl (oo_prim (if has_init then "create_object_and_run_initializers" + else"create_object_opt"), + [obj; Lvar cl])) + else begin + (inh_init, + Llet(Strict, Pgenval, obj', + mkappl (oo_prim "create_object_opt", [obj; Lvar cl]), + Lsequence(obj_init, + if not has_init then Lvar obj' else + mkappl (oo_prim "run_initializers_opt", + [obj; Lvar obj'; Lvar cl])))) + end + +let name_pattern default p = + match p.pat_desc with + | Tpat_var (id, _) -> id + | Tpat_alias(_, id, _) -> id + | _ -> Ident.create_local default + +let rec build_object_init cl_table obj params inh_init obj_init cl = + match cl.cl_desc with + Tcl_ident (path, _, _) -> + let obj_init = Ident.create_local "obj_init" in + let envs, inh_init = inh_init in + let env = + match envs with None -> [] + | Some envs -> + [Lprim(Pfield (List.length inh_init + 1), + [Lvar envs], + Location.none)] + in + let path_lam = transl_class_path cl.cl_loc cl.cl_env path in + ((envs, (path, path_lam, obj_init) :: inh_init), + mkappl(Lvar obj_init, env @ [obj])) + | Tcl_structure str -> + create_object cl_table obj (fun obj -> + let (inh_init, obj_init, has_init) = + List.fold_right + (fun field (inh_init, obj_init, has_init) -> + match field.cf_desc with + Tcf_inherit (_, cl, _, _, _) -> + let (inh_init, obj_init') = + build_object_init cl_table (Lvar obj) [] inh_init + (fun _ -> lambda_unit) cl + in + (inh_init, lsequence obj_init' obj_init, true) + | Tcf_val (_, _, id, Tcfk_concrete (_, exp), _) -> + (inh_init, lsequence (set_inst_var obj id exp) obj_init, + has_init) + | Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _-> + (inh_init, obj_init, has_init) + | Tcf_initializer _ -> + (inh_init, obj_init, true) + ) + str.cstr_fields + (inh_init, obj_init obj, false) + in + (inh_init, + List.fold_right + (fun (id, expr) rem -> + lsequence (Lifused (id, set_inst_var obj id expr)) rem) + params obj_init, + has_init)) + | Tcl_fun (_, pat, vals, cl, partial) -> + let (inh_init, obj_init) = + build_object_init cl_table obj (vals @ params) inh_init obj_init cl + in + (inh_init, + let build params rem = + let param = name_pattern "param" pat in + Lfunction {kind = Curried; params = (param, Pgenval)::params; + return = Pgenval; + attr = default_function_attribute; + loc = pat.pat_loc; + body = Matching.for_function + pat.pat_loc None (Lvar param) [pat, rem] partial} + in + begin match obj_init with + Lfunction {kind = Curried; params; body = rem} -> build params rem + | rem -> build [] rem + end) + | Tcl_apply (cl, oexprs) -> + let (inh_init, obj_init) = + build_object_init cl_table obj params inh_init obj_init cl + in + (inh_init, transl_apply obj_init oexprs Location.none) + | Tcl_let (rec_flag, defs, vals, cl) -> + let (inh_init, obj_init) = + build_object_init cl_table obj (vals @ params) inh_init obj_init cl + in + (inh_init, Translcore.transl_let rec_flag defs obj_init) + | Tcl_open (_, cl) + | Tcl_constraint (cl, _, _, _, _) -> + build_object_init cl_table obj params inh_init obj_init cl + +let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = + match cl.cl_desc with + Tcl_let (_rec_flag, _defs, vals, cl) -> + build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids + | _ -> + let self = Ident.create_local "self" in + let env = Ident.create_local "env" in + let obj = if ids = [] then lambda_unit else Lvar self in + let envs = if top then None else Some env in + let ((_,inh_init), obj_init) = + build_object_init cl_table obj params (envs,[]) copy_env cl in + let obj_init = + if ids = [] then obj_init else lfunction [self, Pgenval] obj_init in + (inh_init, lfunction [env, Pgenval] (subst_env env inh_init obj_init)) + + +let bind_method tbl lab id cl_init = + Llet(Strict, Pgenval, id, mkappl (oo_prim "get_method_label", + [Lvar tbl; transl_label lab]), + cl_init) + +let bind_methods tbl meths vals cl_init = + let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in + let len = List.length methl and nvals = List.length vals in + if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else + if len = 0 && nvals < 2 then transl_vals tbl true Strict vals cl_init else + let ids = Ident.create_local "ids" in + let i = ref (len + nvals) in + let getter, names = + if nvals = 0 then "get_method_labels", [] else + "new_methods_variables", [transl_meth_list (List.map fst vals)] + in + Llet(Strict, Pgenval, ids, + mkappl (oo_prim getter, + [Lvar tbl; transl_meth_list (List.map fst methl)] @ names), + List.fold_right + (fun (_lab,id) lam -> decr i; Llet(StrictOpt, Pgenval, id, + lfield ids !i, lam)) + (methl @ vals) cl_init) + +let output_methods tbl methods lam = + match methods with + [] -> lam + | [lab; code] -> + lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam + | _ -> + lsequence (mkappl(oo_prim "set_methods", + [Lvar tbl; Lprim(Pmakeblock(0,Immutable,None), + methods, Location.none)])) + lam + +let rec ignore_cstrs cl = + match cl.cl_desc with + Tcl_constraint (cl, _, _, _, _) -> ignore_cstrs cl + | Tcl_apply (cl, _) -> ignore_cstrs cl + | _ -> cl + +let rec index a = function + [] -> raise Not_found + | b :: l -> + if b = a then 0 else 1 + index a l + +let bind_id_as_val (id, _) = ("", id) + +let rec build_class_init cla cstr super inh_init cl_init msubst top cl = + match cl.cl_desc with + | Tcl_ident _ -> + begin match inh_init with + | (_, path_lam, obj_init)::inh_init -> + (inh_init, + Llet (Strict, Pgenval, obj_init, + mkappl(Lprim(Pfield 1, [path_lam], Location.none), Lvar cla :: + if top then [Lprim(Pfield 3, [path_lam], Location.none)] + else []), + bind_super cla super cl_init)) + | _ -> + assert false + end + | Tcl_structure str -> + let cl_init = bind_super cla super cl_init in + let (inh_init, cl_init, methods, values) = + List.fold_right + (fun field (inh_init, cl_init, methods, values) -> + match field.cf_desc with + Tcf_inherit (_, cl, _, vals, meths) -> + let cl_init = output_methods cla methods cl_init in + let inh_init, cl_init = + build_class_init cla false + (vals, meths_super cla str.cstr_meths meths) + inh_init cl_init msubst top cl in + (inh_init, cl_init, [], values) + | Tcf_val (name, _, id, _, over) -> + let values = + if over then values else (name.txt, id) :: values + in + (inh_init, cl_init, methods, values) + | Tcf_method (_, _, Tcfk_virtual _) + | Tcf_constraint _ + -> + (inh_init, cl_init, methods, values) + | Tcf_method (name, _, Tcfk_concrete (_, exp)) -> + let met_code = msubst true (transl_exp exp) in + let met_code = + if !Clflags.native_code && List.length met_code = 1 then + (* Force correct naming of method for profiles *) + let met = Ident.create_local ("method_" ^ name.txt) in + [Llet(Strict, Pgenval, met, List.hd met_code, Lvar met)] + else met_code + in + (inh_init, cl_init, + Lvar(Meths.find name.txt str.cstr_meths) :: met_code @ methods, + values) + | Tcf_initializer exp -> + (inh_init, + Lsequence(mkappl (oo_prim "add_initializer", + Lvar cla :: msubst false (transl_exp exp)), + cl_init), + methods, values) + | Tcf_attribute _ -> + (inh_init, cl_init, methods, values)) + str.cstr_fields + (inh_init, cl_init, [], []) + in + let cl_init = output_methods cla methods cl_init in + (inh_init, bind_methods cla str.cstr_meths values cl_init) + | Tcl_fun (_, _pat, vals, cl, _) -> + let (inh_init, cl_init) = + build_class_init cla cstr super inh_init cl_init msubst top cl + in + let vals = List.map bind_id_as_val vals in + (inh_init, transl_vals cla true StrictOpt vals cl_init) + | Tcl_apply (cl, _exprs) -> + build_class_init cla cstr super inh_init cl_init msubst top cl + | Tcl_let (_rec_flag, _defs, vals, cl) -> + let (inh_init, cl_init) = + build_class_init cla cstr super inh_init cl_init msubst top cl + in + let vals = List.map bind_id_as_val vals in + (inh_init, transl_vals cla true StrictOpt vals cl_init) + | Tcl_constraint (cl, _, vals, meths, concr_meths) -> + let virt_meths = + List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in + let concr_meths = Concr.elements concr_meths in + let narrow_args = + [Lvar cla; + transl_meth_list vals; + transl_meth_list virt_meths; + transl_meth_list concr_meths] in + let cl = ignore_cstrs cl in + begin match cl.cl_desc, inh_init with + | Tcl_ident (path, _, _), (path', path_lam, obj_init)::inh_init -> + assert (Path.same path path'); + let inh = Ident.create_local "inh" + and ofs = List.length vals + 1 + and valids, methids = super in + let cl_init = + List.fold_left + (fun init (nm, id, _) -> + Llet(StrictOpt, Pgenval, id, + lfield inh (index nm concr_meths + ofs), + init)) + cl_init methids in + let cl_init = + List.fold_left + (fun init (nm, id) -> + Llet(StrictOpt, Pgenval, id, + lfield inh (index nm vals + 1), init)) + cl_init valids in + (inh_init, + Llet (Strict, Pgenval, inh, + mkappl(oo_prim "inherits", narrow_args @ + [path_lam; + Lconst(Const_pointer(if top then 1 else 0))]), + Llet(StrictOpt, Pgenval, obj_init, lfield inh 0, cl_init))) + | _ -> + let core cl_init = + build_class_init cla true super inh_init cl_init msubst top cl + in + if cstr then core cl_init else + let (inh_init, cl_init) = + core (Lsequence (mkappl (oo_prim "widen", [Lvar cla]), cl_init)) + in + (inh_init, + Lsequence(mkappl (oo_prim "narrow", narrow_args), + cl_init)) + end + | Tcl_open (_, cl) -> + build_class_init cla cstr super inh_init cl_init msubst top cl + +let rec build_class_lets cl = + match cl.cl_desc with + Tcl_let (rec_flag, defs, _vals, cl') -> + let env, wrap = build_class_lets cl' in + (env, fun x -> + Translcore.transl_let rec_flag defs (wrap x)) + | _ -> + (cl.cl_env, fun x -> x) + +let rec get_class_meths cl = + match cl.cl_desc with + Tcl_structure cl -> + Meths.fold (fun _ -> Ident.Set.add) cl.cstr_meths Ident.Set.empty + | Tcl_ident _ -> Ident.Set.empty + | Tcl_fun (_, _, _, cl, _) + | Tcl_let (_, _, _, cl) + | Tcl_apply (cl, _) + | Tcl_open (_, cl) + | Tcl_constraint (cl, _, _, _, _) -> get_class_meths cl + +(* + XXX Il devrait etre peu couteux d'ecrire des classes : + | Writing classes should be cheap + class c x y = d e f +*) +let rec transl_class_rebind obj_init cl vf = + match cl.cl_desc with + Tcl_ident (path, _, _) -> + if vf = Concrete then begin + try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit + with Not_found -> raise Exit + end; + let path_lam = transl_class_path cl.cl_loc cl.cl_env path in + (path, path_lam, obj_init) + | Tcl_fun (_, pat, _, cl, partial) -> + let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in + let build params rem = + let param = name_pattern "param" pat in + Lfunction {kind = Curried; params = (param, Pgenval)::params; + return = Pgenval; + attr = default_function_attribute; + loc = pat.pat_loc; + body = Matching.for_function + pat.pat_loc None (Lvar param) [pat, rem] partial} + in + (path, path_lam, + match obj_init with + Lfunction {kind = Curried; params; body} -> build params body + | rem -> build [] rem) + | Tcl_apply (cl, oexprs) -> + let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in + (path, path_lam, transl_apply obj_init oexprs Location.none) + | Tcl_let (rec_flag, defs, _vals, cl) -> + let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in + (path, path_lam, Translcore.transl_let rec_flag defs obj_init) + | Tcl_structure _ -> raise Exit + | Tcl_constraint (cl', _, _, _, _) -> + let path, path_lam, obj_init = transl_class_rebind obj_init cl' vf in + let rec check_constraint = function + Cty_constr(path', _, _) when Path.same path path' -> () + | Cty_arrow (_, _, cty) -> check_constraint cty + | _ -> raise Exit + in + check_constraint cl.cl_type; + (path, path_lam, obj_init) + | Tcl_open (_, cl) -> + transl_class_rebind obj_init cl vf + +let rec transl_class_rebind_0 (self:Ident.t) obj_init cl vf = + match cl.cl_desc with + Tcl_let (rec_flag, defs, _vals, cl) -> + let path, path_lam, obj_init = + transl_class_rebind_0 self obj_init cl vf + in + (path, path_lam, Translcore.transl_let rec_flag defs obj_init) + | _ -> + let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in + (path, path_lam, lfunction [self, Pgenval] obj_init) + +let transl_class_rebind cl vf = + try + let obj_init = Ident.create_local "obj_init" + and self = Ident.create_local "self" in + let obj_init0 = + lapply {ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=Lvar obj_init; + ap_args=[Lvar self]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} + in + let _, path_lam, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in + let id = (obj_init' = lfunction [self, Pgenval] obj_init0) in + if id then path_lam else + + let cla = Ident.create_local "class" + and new_init = Ident.create_local "new_init" + and env_init = Ident.create_local "env_init" + and table = Ident.create_local "table" + and envs = Ident.create_local "envs" in + Llet( + Strict, Pgenval, new_init, lfunction [obj_init, Pgenval] obj_init', + Llet( + Alias, Pgenval, cla, path_lam, + Lprim(Pmakeblock(0, Immutable, None), + [mkappl(Lvar new_init, [lfield cla 0]); + lfunction [table, Pgenval] + (Llet(Strict, Pgenval, env_init, + mkappl(lfield cla 1, [Lvar table]), + lfunction [envs, Pgenval] + (mkappl(Lvar new_init, + [mkappl(Lvar env_init, [Lvar envs])])))); + lfield cla 2; + lfield cla 3], + Location.none))) + with Exit -> + lambda_unit + +(* Rewrite a closure using builtins. Improves native code size. *) + +let rec module_path = function + Lvar id -> + let s = Ident.name id in s <> "" && s.[0] >= 'A' && s.[0] <= 'Z' + | Lprim(Pfield _, [p], _) -> module_path p + | Lprim(Pgetglobal _, [], _) -> true + | _ -> false + +let const_path local = function + Lvar id -> not (List.mem id local) + | Lconst _ -> true + | Lfunction {kind = Curried; body} -> + let fv = free_variables body in + List.for_all (fun x -> not (Ident.Set.mem x fv)) local + | p -> module_path p + +let rec builtin_meths self env env2 body = + let const_path = const_path (env::self) in + let conv = function + (* Lvar s when List.mem s self -> "_self", [] *) + | p when const_path p -> "const", [p] + | Lprim(Parrayrefu _, [Lvar s; Lvar n], _) when List.mem s self -> + "var", [Lvar n] + | Lprim(Pfield n, [Lvar e], _) when Ident.same e env -> + "env", [Lvar env2; Lconst(Const_pointer n)] + | Lsend(Self, met, Lvar s, [], _) when List.mem s self -> + "meth", [met] + | _ -> raise Not_found + in + match body with + | Llet(_str, _k, s', Lvar s, body) when List.mem s self -> + builtin_meths (s'::self) env env2 body + | Lapply{ap_func = f; ap_args = [arg]} when const_path f -> + let s, args = conv arg in ("app_"^s, f :: args) + | Lapply{ap_func = f; ap_args = [arg; p]} when const_path f && const_path p -> + let s, args = conv arg in + ("app_"^s^"_const", f :: args @ [p]) + | Lapply{ap_func = f; ap_args = [p; arg]} when const_path f && const_path p -> + let s, args = conv arg in + ("app_const_"^s, f :: p :: args) + | Lsend(Self, Lvar n, Lvar s, [arg], _) when List.mem s self -> + let s, args = conv arg in + ("meth_app_"^s, Lvar n :: args) + | Lsend(Self, met, Lvar s, [], _) when List.mem s self -> + ("get_meth", [met]) + | Lsend(Public, met, arg, [], _) -> + let s, args = conv arg in + ("send_"^s, met :: args) + | Lsend(Cached, met, arg, [_;_], _) -> + let s, args = conv arg in + ("send_"^s, met :: args) + | Lfunction {kind = Curried; params = [x, _]; body} -> + let rec enter self = function + | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'], _) + when Ident.same x x' && List.mem s self -> + ("set_var", [Lvar n]) + | Llet(_str, _k, s', Lvar s, body) when List.mem s self -> + enter (s'::self) body + | _ -> raise Not_found + in enter self body + | Lfunction _ -> raise Not_found + | _ -> + let s, args = conv body in ("get_"^s, args) + +module M = struct + open CamlinternalOO + let builtin_meths self env env2 body = + let builtin, args = builtin_meths self env env2 body in + (* if not arr then [mkappl(oo_prim builtin, args)] else *) + let tag = match builtin with + "get_const" -> GetConst + | "get_var" -> GetVar + | "get_env" -> GetEnv + | "get_meth" -> GetMeth + | "set_var" -> SetVar + | "app_const" -> AppConst + | "app_var" -> AppVar + | "app_env" -> AppEnv + | "app_meth" -> AppMeth + | "app_const_const" -> AppConstConst + | "app_const_var" -> AppConstVar + | "app_const_env" -> AppConstEnv + | "app_const_meth" -> AppConstMeth + | "app_var_const" -> AppVarConst + | "app_env_const" -> AppEnvConst + | "app_meth_const" -> AppMethConst + | "meth_app_const" -> MethAppConst + | "meth_app_var" -> MethAppVar + | "meth_app_env" -> MethAppEnv + | "meth_app_meth" -> MethAppMeth + | "send_const" -> SendConst + | "send_var" -> SendVar + | "send_env" -> SendEnv + | "send_meth" -> SendMeth + | _ -> assert false + in Lconst(Const_pointer(Obj.magic tag)) :: args +end +open M + + +(* + Class translation. + Three subcases: + * reapplication of a known class -> transl_class_rebind + * class without local dependencies -> direct translation + * with local dependencies -> generate a stubs tree, + with a node for every local classes inherited + A class is a 4-tuple: + (obj_init, class_init, env_init, env) + obj_init: creation function (unit -> obj) + class_init: inheritance function (table -> env_init) + (one by source code) + env_init: parameterisation by the local environment + (env -> params -> obj_init) + (one for each combination of inherited class_init ) + env: local environment + If ids=0 (immediate object), then only env_init is conserved. +*) + +(* +let prerr_ids msg ids = + let names = List.map Ident.unique_toplevel_name ids in + prerr_endline (String.concat " " (msg :: names)) +*) + +let free_methods l = + let fv = ref Ident.Set.empty in + let rec free l = + Lambda.iter_head_constructor free l; + match l with + | Lsend(Self, Lvar meth, _, _, _) -> + fv := Ident.Set.add meth !fv + | Lsend _ -> () + | Lfunction{params} -> + List.iter (fun (param, _) -> fv := Ident.Set.remove param !fv) params + | Llet(_str, _k, id, _arg, _body) -> + fv := Ident.Set.remove id !fv + | Lletrec(decl, _body) -> + List.iter (fun (id, _exp) -> fv := Ident.Set.remove id !fv) decl + | Lstaticcatch(_e1, (_,vars), _e2) -> + List.iter (fun (id, _) -> fv := Ident.Set.remove id !fv) vars + | Ltrywith(_e1, exn, _e2) -> + fv := Ident.Set.remove exn !fv + | Lfor(v, _e1, _e2, _dir, _e3) -> + fv := Ident.Set.remove v !fv + | Lassign _ + | Lvar _ | Lconst _ | Lapply _ + | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _ + | Lifthenelse _ | Lsequence _ | Lwhile _ + | Levent _ | Lifused _ -> () + in free l; !fv + +let transl_class ids cl_id pub_meths cl vflag = + (* First check if it is not only a rebind *) + let rebind = transl_class_rebind cl vflag in + if rebind <> lambda_unit then rebind else + + (* Prepare for heavy environment handling *) + let tables = Ident.create_local (Ident.name cl_id ^ "_tables") in + let (top_env, req) = oo_add_class tables in + let top = not req in + let cl_env, llets = build_class_lets cl in + let new_ids = if top then [] else Env.diff top_env cl_env in + let env2 = Ident.create_local "env" in + let meth_ids = get_class_meths cl in + let subst env lam i0 new_ids' = + let fv = free_variables lam in + (* prerr_ids "cl_id =" [cl_id]; prerr_ids "fv =" (Ident.Set.elements fv); *) + let fv = List.fold_right Ident.Set.remove !new_ids' fv in + (* We need to handle method ids specially, as they do not appear + in the typing environment (PR#3576, PR#4560) *) + (* very hacky: we add and remove free method ids on the fly, + depending on the visit order... *) + method_ids := + Ident.Set.diff (Ident.Set.union (free_methods lam) !method_ids) meth_ids; + (* prerr_ids "meth_ids =" (Ident.Set.elements meth_ids); + prerr_ids "method_ids =" (Ident.Set.elements !method_ids); *) + let new_ids = List.fold_right Ident.Set.add new_ids !method_ids in + let fv = Ident.Set.inter fv new_ids in + new_ids' := !new_ids' @ Ident.Set.elements fv; + (* prerr_ids "new_ids' =" !new_ids'; *) + let i = ref (i0-1) in + List.fold_left + (fun subst id -> + incr i; Ident.Map.add id (lfield env !i) subst) + Ident.Map.empty !new_ids' + in + let new_ids_meths = ref [] in + let no_env_update _ _ env = env in + let msubst arr = function + Lfunction {kind = Curried; params = (self, Pgenval) :: args; body} -> + let env = Ident.create_local "env" in + let body' = + if new_ids = [] then body else + Lambda.subst no_env_update (subst env body 0 new_ids_meths) body in + begin try + (* Doesn't seem to improve size for bytecode *) + (* if not !Clflags.native_code then raise Not_found; *) + if not arr || !Clflags.debug then raise Not_found; + builtin_meths [self] env env2 (lfunction args body') + with Not_found -> + [lfunction ((self, Pgenval) :: args) + (if not (Ident.Set.mem env (free_variables body')) then body' else + Llet(Alias, Pgenval, env, + Lprim(Pfield_computed, + [Lvar self; Lvar env2], + Location.none), + body'))] + end + | _ -> assert false + in + let new_ids_init = ref [] in + let env1 = Ident.create_local "env" and env1' = Ident.create_local "env'" in + let copy_env self = + if top then lambda_unit else + Lifused(env2, Lprim(Psetfield_computed (Pointer, Assignment), + [Lvar self; Lvar env2; Lvar env1'], + Location.none)) + and subst_env envs l lam = + if top then lam else + (* must be called only once! *) + let lam = Lambda.subst no_env_update (subst env1 lam 1 new_ids_init) lam in + Llet(Alias, Pgenval, env1, (if l = [] then Lvar envs else lfield envs 0), + Llet(Alias, Pgenval, env1', + (if !new_ids_init = [] then Lvar env1 else lfield env1 0), + lam)) + in + + (* Now we start compiling the class *) + let cla = Ident.create_local "class" in + let (inh_init, obj_init) = + build_object_init_0 cla [] cl copy_env subst_env top ids in + let inh_init' = List.rev inh_init in + let (inh_init', cl_init) = + build_class_init cla true ([],[]) inh_init' obj_init msubst top cl + in + assert (inh_init' = []); + let table = Ident.create_local "table" + and class_init = Ident.create_local (Ident.name cl_id ^ "_init") + and env_init = Ident.create_local "env_init" + and obj_init = Ident.create_local "obj_init" in + let pub_meths = + List.sort + (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s')) + pub_meths in + let tags = List.map Btype.hash_variant pub_meths in + let rev_map = List.combine tags pub_meths in + List.iter2 + (fun tag name -> + let name' = List.assoc tag rev_map in + if name' <> name then raise(Error(cl.cl_loc, Tags(name, name')))) + tags pub_meths; + let ltable table lam = + Llet(Strict, Pgenval, table, + mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam) + and ldirect obj_init = + Llet(Strict, Pgenval, obj_init, cl_init, + Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), + mkappl (Lvar obj_init, [lambda_unit]))) + in + (* Simplest case: an object defined at toplevel (ids=[]) *) + if top && ids = [] then llets (ltable cla (ldirect obj_init)) else + + let concrete = (vflag = Concrete) + and lclass lam = + let cl_init = llets (Lfunction{kind = Curried; + attr = default_function_attribute; + loc = Location.none; + return = Pgenval; + params = [cla, Pgenval]; body = cl_init}) in + Llet(Strict, Pgenval, class_init, cl_init, lam (free_variables cl_init)) + and lbody fv = + if List.for_all (fun id -> not (Ident.Set.mem id fv)) ids then + mkappl (oo_prim "make_class",[transl_meth_list pub_meths; + Lvar class_init]) + else + ltable table ( + Llet( + Strict, Pgenval, env_init, mkappl (Lvar class_init, [Lvar table]), + Lsequence( + mkappl (oo_prim "init_class", [Lvar table]), + Lprim(Pmakeblock(0, Immutable, None), + [mkappl (Lvar env_init, [lambda_unit]); + Lvar class_init; Lvar env_init; lambda_unit], + Location.none)))) + and lbody_virt lenvs = + Lprim(Pmakeblock(0, Immutable, None), + [lambda_unit; Lfunction{kind = Curried; + attr = default_function_attribute; + loc = Location.none; + return = Pgenval; + params = [cla, Pgenval]; body = cl_init}; + lambda_unit; lenvs], + Location.none) + in + (* Still easy: a class defined at toplevel *) + if top && concrete then lclass lbody else + if top then llets (lbody_virt lambda_unit) else + + (* Now for the hard stuff: prepare for table caching *) + let envs = Ident.create_local "envs" + and cached = Ident.create_local "cached" in + let lenvs = + if !new_ids_meths = [] && !new_ids_init = [] && inh_init = [] + then lambda_unit + else Lvar envs in + let lenv = + let menv = + if !new_ids_meths = [] then lambda_unit else + Lprim(Pmakeblock(0, Immutable, None), + List.map (fun id -> Lvar id) !new_ids_meths, + Location.none) in + if !new_ids_init = [] then menv else + Lprim(Pmakeblock(0, Immutable, None), + menv :: List.map (fun id -> Lvar id) !new_ids_init, + Location.none) + and linh_envs = + List.map + (fun (_, path_lam, _) -> Lprim(Pfield 3, [path_lam], Location.none)) + (List.rev inh_init) + in + let make_envs lam = + Llet(StrictOpt, Pgenval, envs, + (if linh_envs = [] then lenv else + Lprim(Pmakeblock(0, Immutable, None), + lenv :: linh_envs, Location.none)), + lam) + and def_ids cla lam = + Llet(StrictOpt, Pgenval, env2, + mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]), + lam) + in + let inh_paths = + List.filter + (fun (path, _, _) -> List.mem (Path.head path) new_ids) inh_init + in + let inh_keys = + List.map + (fun (_, path_lam, _) -> Lprim(Pfield 1, [path_lam], Location.none)) + inh_paths + in + let lclass lam = + Llet(Strict, Pgenval, class_init, + Lfunction{kind = Curried; params = [cla, Pgenval]; + return = Pgenval; + attr = default_function_attribute; + loc = Location.none; + body = def_ids cla cl_init}, lam) + and lcache lam = + if inh_keys = [] then Llet(Alias, Pgenval, cached, Lvar tables, lam) else + Llet(Strict, Pgenval, cached, + mkappl (oo_prim "lookup_tables", + [Lvar tables; Lprim(Pmakeblock(0, Immutable, None), + inh_keys, Location.none)]), + lam) + and lset cached i lam = + Lprim(Psetfield(i, Pointer, Assignment), + [Lvar cached; lam], Location.none) + in + let ldirect () = + ltable cla + (Llet(Strict, Pgenval, env_init, def_ids cla cl_init, + Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), + lset cached 0 (Lvar env_init)))) + and lclass_virt () = + lset cached 0 + (Lfunction + { + kind = Curried; + attr = default_function_attribute; + loc = Location.none; + return = Pgenval; + params = [cla, Pgenval]; + body = def_ids cla cl_init; + } + ) + in + let lupdate_cache = + if ids = [] then ldirect () else + if not concrete then lclass_virt () else + lclass ( + mkappl (oo_prim "make_class_store", + [transl_meth_list pub_meths; + Lvar class_init; Lvar cached])) in + let lcheck_cache = + if !Clflags.native_code && !Clflags.afl_instrument then + (* When afl-fuzz instrumentation is enabled, ignore the cache + so that the program's behaviour does not change between runs *) + lupdate_cache + else + Lifthenelse(lfield cached 0, lambda_unit, lupdate_cache) in + llets ( + lcache ( + Lsequence(lcheck_cache, + make_envs ( + if ids = [] then mkappl (lfield cached 0, [lenvs]) else + Lprim(Pmakeblock(0, Immutable, None), + (if concrete then + [mkappl (lfield cached 0, [lenvs]); + lfield cached 1; + lfield cached 0; + lenvs] + else [lambda_unit; lfield cached 0; lambda_unit; lenvs]), + Location.none + ))))) + +(* Wrapper for class compilation *) +(* + let cl_id = ci.ci_id_class in +(* TODO: cl_id is used somewhere else as typesharp ? *) + let _arity = List.length ci.ci_params in + let pub_meths = m in + let cl = ci.ci_expr in + let vflag = vf in +*) + +let transl_class ids id pub_meths cl vf = + oo_wrap cl.cl_env false (transl_class ids id pub_meths cl) vf + +let () = + transl_object := (fun id meths cl -> transl_class [] id meths cl Concrete) + +(* Error report *) + +open Format + +let report_error ppf = function + | Tags (lab1, lab2) -> + fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s" + lab1 lab2 "Change one of them." + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer ~loc report_error err) + | _ -> + None + ) diff --git a/lambda/translclass.mli b/lambda/translclass.mli new file mode 100644 index 00000000..4c4bed0f --- /dev/null +++ b/lambda/translclass.mli @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Typedtree +open Lambda + +val transl_class : + Ident.t list -> Ident.t -> + string list -> class_expr -> Asttypes.virtual_flag -> lambda;; + +type error = Tags of string * string + +exception Error of Location.t * error + +open Format + +val report_error: formatter -> error -> unit diff --git a/lambda/translcore.ml b/lambda/translcore.ml new file mode 100644 index 00000000..6fe2dcbb --- /dev/null +++ b/lambda/translcore.ml @@ -0,0 +1,1048 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Translation from typed abstract syntax to lambda terms, + for the core language *) + +open Misc +open Asttypes +open Primitive +open Types +open Typedtree +open Typeopt +open Lambda + +type error = + Free_super_var + | Unreachable_reached + +exception Error of Location.t * error + +let use_dup_for_constant_arrays_bigger_than = 4 + +(* Forward declaration -- to be filled in by Translmod.transl_module *) +let transl_module = + ref((fun _cc _rootpath _modl -> assert false) : + module_coercion -> Path.t option -> module_expr -> lambda) + +let transl_object = + ref (fun _id _s _cl -> assert false : + Ident.t -> string list -> class_expr -> lambda) + +(* Compile an exception/extension definition *) + +let prim_fresh_oo_id = + Pccall (Primitive.simple ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false) + +let transl_extension_constructor env path ext = + let path = + Printtyp.wrap_printing_env env ~error:true (fun () -> + Option.map (Printtyp.rewrite_double_underscore_paths env) path) + in + let name = + match path, !Clflags.for_package with + None, _ -> Ident.name ext.ext_id + | Some p, None -> Path.name p + | Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p) + in + let loc = ext.ext_loc in + match ext.ext_kind with + Text_decl _ -> + Lprim (Pmakeblock (Obj.object_tag, Immutable, None), + [Lconst (Const_base (Const_string (name, None))); + Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)], + loc) + | Text_rebind(path, _lid) -> + transl_extension_path loc env path + +(* To propagate structured constants *) + +exception Not_constant + +let extract_constant = function + Lconst sc -> sc + | _ -> raise Not_constant + +let extract_float = function + Const_base(Const_float f) -> f + | _ -> fatal_error "Translcore.extract_float" + +(* Push the default values under the functional abstractions *) +(* Also push bindings of module patterns, since this sound *) + +type binding = + | Bind_value of value_binding list + | Bind_module of Ident.t * string loc * module_presence * module_expr + +let rec push_defaults loc bindings cases partial = + match cases with + [{c_lhs=pat; c_guard=None; + c_rhs={exp_desc = Texp_function { arg_label; param; cases; partial; } } + as exp}] -> + let cases = push_defaults exp.exp_loc bindings cases partial in + [{c_lhs=pat; c_guard=None; + c_rhs={exp with exp_desc = Texp_function { arg_label; param; cases; + partial; }}}] + | [{c_lhs=pat; c_guard=None; + c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#default"};_}]; + exp_desc = Texp_let + (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] -> + push_defaults loc (Bind_value binds :: bindings) + [{c_lhs=pat;c_guard=None;c_rhs=e2}] + partial + | [{c_lhs=pat; c_guard=None; + c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#modulepat"};_}]; + exp_desc = Texp_letmodule + (id, name, pres, mexpr, + ({exp_desc = Texp_function _} as e2))}}] -> + push_defaults loc (Bind_module (id, name, pres, mexpr) :: bindings) + [{c_lhs=pat;c_guard=None;c_rhs=e2}] + partial + | [case] -> + let exp = + List.fold_left + (fun exp binds -> + {exp with exp_desc = + match binds with + | Bind_value binds -> Texp_let(Nonrecursive, binds, exp) + | Bind_module (id, name, pres, mexpr) -> + Texp_letmodule (id, name, pres, mexpr, exp)}) + case.c_rhs bindings + in + [{case with c_rhs=exp}] + | {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] -> + let param = Typecore.name_cases "param" cases in + let desc = + {val_type = pat.pat_type; val_kind = Val_reg; + val_attributes = []; Types.val_loc = Location.none; } + in + let env = Env.add_value param desc exp.exp_env in + let name = Ident.name param in + let exp = + { exp with exp_loc = loc; exp_env = env; exp_desc = + Texp_match + ({exp with exp_type = pat.pat_type; exp_env = env; exp_desc = + Texp_ident + (Path.Pident param, mknoloc (Longident.Lident name), desc)}, + cases, partial) } + in + push_defaults loc bindings + [{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)}; + c_guard=None; c_rhs=exp}] + Total + | _ -> + cases + +(* Insertion of debugging events *) + +let event_before = Translprim.event_before + +let event_after = Translprim.event_after + +let event_function exp lam = + if !Clflags.debug && not !Clflags.native_code then + let repr = Some (ref 0) in + let (info, body) = lam repr in + (info, + Levent(body, {lev_loc = exp.exp_loc; + lev_kind = Lev_function; + lev_repr = repr; + lev_env = exp.exp_env})) + else + lam None + +(* Assertions *) + +let assert_failed exp = + let slot = + transl_extension_path Location.none + Env.initial_safe_string Predef.path_assert_failure + in + let (fname, line, char) = + Location.get_pos_info exp.exp_loc.Location.loc_start + in + Lprim(Praise Raise_regular, [event_after exp + (Lprim(Pmakeblock(0, Immutable, None), + [slot; + Lconst(Const_block(0, + [Const_base(Const_string (fname, None)); + Const_base(Const_int line); + Const_base(Const_int char)]))], exp.exp_loc))], exp.exp_loc) +;; + +let rec cut n l = + if n = 0 then ([],l) else + match l with [] -> failwith "Translcore.cut" + | a::l -> let (l1,l2) = cut (n-1) l in (a::l1,l2) + +(* Translation of expressions *) + +let rec iter_exn_names f pat = + match pat.pat_desc with + | Tpat_var (id, _) -> f id + | Tpat_alias (p, id, _) -> + f id; + iter_exn_names f p + | _ -> () + +let transl_ident loc env ty path desc = + match desc.val_kind with + | Val_prim p -> + Translprim.transl_primitive loc p env ty (Some path) + | Val_anc _ -> + raise(Error(loc, Free_super_var)) + | Val_reg | Val_self _ -> + transl_value_path loc env path + | _ -> fatal_error "Translcore.transl_exp: bad Texp_ident" + +let rec transl_exp e = + List.iter (Translattribute.check_attribute e) e.exp_attributes; + let eval_once = + (* Whether classes for immediate objects must be cached *) + match e.exp_desc with + Texp_function _ | Texp_for _ | Texp_while _ -> false + | _ -> true + in + if eval_once then transl_exp0 e else + Translobj.oo_wrap e.exp_env true transl_exp0 e + +and transl_exp0 e = + match e.exp_desc with + | Texp_ident(path, _, desc) -> + transl_ident e.exp_loc e.exp_env e.exp_type path desc + | Texp_constant cst -> + Lconst(Const_base cst) + | Texp_let(rec_flag, pat_expr_list, body) -> + transl_let rec_flag pat_expr_list (event_before body (transl_exp body)) + | Texp_function { arg_label = _; param; cases; partial; } -> + let ((kind, params, return), body) = + event_function e + (function repr -> + let pl = push_defaults e.exp_loc [] cases partial in + let return_kind = function_return_value_kind e.exp_env e.exp_type in + transl_function e.exp_loc return_kind !Clflags.native_code repr + partial param pl) + in + let attr = default_function_attribute in + let loc = e.exp_loc in + let lam = Lfunction{kind; params; return; body; attr; loc} in + Translattribute.add_function_attributes lam loc e.exp_attributes + | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p}); + exp_type = prim_type } as funct, oargs) + when List.length oargs >= p.prim_arity + && List.for_all (fun (_, arg) -> arg <> None) oargs -> + let argl, extra_args = cut p.prim_arity oargs in + let arg_exps = + List.map (function _, Some x -> x | _ -> assert false) argl + in + let args = transl_list arg_exps in + let prim_exp = if extra_args = [] then Some e else None in + let lam = + Translprim.transl_primitive_application + e.exp_loc p e.exp_env prim_type path + prim_exp args arg_exps + in + if extra_args = [] then lam + else begin + let should_be_tailcall, funct = + Translattribute.get_tailcall_attribute funct + in + let inlined, funct = + Translattribute.get_and_remove_inlined_attribute funct + in + let specialised, funct = + Translattribute.get_and_remove_specialised_attribute funct + in + let e = { e with exp_desc = Texp_apply(funct, oargs) } in + event_after e + (transl_apply ~should_be_tailcall ~inlined ~specialised + lam extra_args e.exp_loc) + end + | Texp_apply(funct, oargs) -> + let should_be_tailcall, funct = + Translattribute.get_tailcall_attribute funct + in + let inlined, funct = + Translattribute.get_and_remove_inlined_attribute funct + in + let specialised, funct = + Translattribute.get_and_remove_specialised_attribute funct + in + let e = { e with exp_desc = Texp_apply(funct, oargs) } in + event_after e + (transl_apply ~should_be_tailcall ~inlined ~specialised + (transl_exp funct) oargs e.exp_loc) + | Texp_match(arg, pat_expr_list, partial) -> + transl_match e arg pat_expr_list partial + | Texp_try(body, pat_expr_list) -> + let id = Typecore.name_cases "exn" pat_expr_list in + Ltrywith(transl_exp body, id, + Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list)) + | Texp_tuple el -> + let ll, shape = transl_list_with_shape el in + begin try + Lconst(Const_block(0, List.map extract_constant ll)) + with Not_constant -> + Lprim(Pmakeblock(0, Immutable, Some shape), ll, e.exp_loc) + end + | Texp_construct(_, cstr, args) -> + let ll, shape = transl_list_with_shape args in + if cstr.cstr_inlined <> None then begin match ll with + | [x] -> x + | _ -> assert false + end else begin match cstr.cstr_tag with + Cstr_constant n -> + Lconst(Const_pointer n) + | Cstr_unboxed -> + (match ll with [v] -> v | _ -> assert false) + | Cstr_block n -> + begin try + Lconst(Const_block(n, List.map extract_constant ll)) + with Not_constant -> + Lprim(Pmakeblock(n, Immutable, Some shape), ll, e.exp_loc) + end + | Cstr_extension(path, is_const) -> + let lam = transl_extension_path e.exp_loc e.exp_env path in + if is_const then lam + else + Lprim(Pmakeblock(0, Immutable, Some (Pgenval :: shape)), + lam :: ll, e.exp_loc) + end + | Texp_extension_constructor (_, path) -> + transl_extension_path e.exp_loc e.exp_env path + | Texp_variant(l, arg) -> + let tag = Btype.hash_variant l in + begin match arg with + None -> Lconst(Const_pointer tag) + | Some arg -> + let lam = transl_exp arg in + try + Lconst(Const_block(0, [Const_base(Const_int tag); + extract_constant lam])) + with Not_constant -> + Lprim(Pmakeblock(0, Immutable, None), + [Lconst(Const_base(Const_int tag)); lam], e.exp_loc) + end + | Texp_record {fields; representation; extended_expression} -> + transl_record e.exp_loc e.exp_env fields representation + extended_expression + | Texp_field(arg, _, lbl) -> + let targ = transl_exp arg in + begin match lbl.lbl_repres with + Record_regular | Record_inlined _ -> + Lprim (Pfield lbl.lbl_pos, [targ], e.exp_loc) + | Record_unboxed _ -> targ + | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [targ], e.exp_loc) + | Record_extension _ -> + Lprim (Pfield (lbl.lbl_pos + 1), [targ], e.exp_loc) + end + | Texp_setfield(arg, _, lbl, newval) -> + let access = + match lbl.lbl_repres with + Record_regular + | Record_inlined _ -> + Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment) + | Record_unboxed _ -> assert false + | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment) + | Record_extension _ -> + Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment) + in + Lprim(access, [transl_exp arg; transl_exp newval], e.exp_loc) + | Texp_array expr_list -> + let kind = array_kind e in + let ll = transl_list expr_list in + begin try + (* For native code the decision as to which compilation strategy to + use is made later. This enables the Flambda passes to lift certain + kinds of array definitions to symbols. *) + (* Deactivate constant optimization if array is small enough *) + if List.length ll <= use_dup_for_constant_arrays_bigger_than + then begin + raise Not_constant + end; + begin match List.map extract_constant ll with + | exception Not_constant when kind = Pfloatarray -> + (* We cannot currently lift [Pintarray] arrays safely in Flambda + because [caml_modify] might be called upon them (e.g. from + code operating on polymorphic arrays, or functions such as + [caml_array_blit]. + To avoid having different Lambda code for + bytecode/Closure vs. Flambda, we always generate + [Pduparray] here, and deal with it in [Bytegen] (or in + the case of Closure, in [Cmmgen], which already has to + handle [Pduparray Pmakearray Pfloatarray] in the case + where the array turned out to be inconstant). + When not [Pfloatarray], the exception propagates to the handler + below. *) + let imm_array = + Lprim (Pmakearray (kind, Immutable), ll, e.exp_loc) + in + Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc) + | cl -> + let imm_array = + match kind with + | Paddrarray | Pintarray -> + Lconst(Const_block(0, cl)) + | Pfloatarray -> + Lconst(Const_float_array(List.map extract_float cl)) + | Pgenarray -> + raise Not_constant (* can this really happen? *) + in + Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc) + end + with Not_constant -> + Lprim(Pmakearray (kind, Mutable), ll, e.exp_loc) + end + | Texp_ifthenelse(cond, ifso, Some ifnot) -> + Lifthenelse(transl_exp cond, + event_before ifso (transl_exp ifso), + event_before ifnot (transl_exp ifnot)) + | Texp_ifthenelse(cond, ifso, None) -> + Lifthenelse(transl_exp cond, + event_before ifso (transl_exp ifso), + lambda_unit) + | Texp_sequence(expr1, expr2) -> + Lsequence(transl_exp expr1, event_before expr2 (transl_exp expr2)) + | Texp_while(cond, body) -> + Lwhile(transl_exp cond, event_before body (transl_exp body)) + | Texp_for(param, _, low, high, dir, body) -> + Lfor(param, transl_exp low, transl_exp high, dir, + event_before body (transl_exp body)) + | Texp_send(_, _, Some exp) -> transl_exp exp + | Texp_send(expr, met, None) -> + let obj = transl_exp expr in + let lam = + match met with + Tmeth_val id -> Lsend (Self, Lvar id, obj, [], e.exp_loc) + | Tmeth_name nm -> + let (tag, cache) = Translobj.meth obj nm in + let kind = if cache = [] then Public else Cached in + Lsend (kind, tag, obj, cache, e.exp_loc) + in + event_after e lam + | Texp_new (cl, {Location.loc=loc}, _) -> + Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func= + Lprim(Pfield 0, [transl_class_path loc e.exp_env cl], loc); + ap_args=[lambda_unit]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} + | Texp_instvar(path_self, path, _) -> + let self = transl_value_path e.exp_loc e.exp_env path_self in + let var = transl_value_path e.exp_loc e.exp_env path in + Lprim(Pfield_computed, [self; var], e.exp_loc) + | Texp_setinstvar(path_self, path, _, expr) -> + let self = transl_value_path e.exp_loc e.exp_env path_self in + let var = transl_value_path e.exp_loc e.exp_env path in + transl_setinstvar e.exp_loc self var expr + | Texp_override(path_self, modifs) -> + let self = transl_value_path e.exp_loc e.exp_env path_self in + let cpy = Ident.create_local "copy" in + Llet(Strict, Pgenval, cpy, + Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=Translobj.oo_prim "copy"; + ap_args=[self]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}, + List.fold_right + (fun (path, _, expr) rem -> + let var = transl_value_path e.exp_loc e.exp_env path in + Lsequence(transl_setinstvar Location.none + (Lvar cpy) var expr, rem)) + modifs + (Lvar cpy)) + | Texp_letmodule(id, loc, Mp_present, modl, body) -> + let defining_expr = + Levent (!transl_module Tcoerce_none None modl, { + lev_loc = loc.loc; + lev_kind = Lev_module_definition id; + lev_repr = None; + lev_env = Env.empty; + }) + in + Llet(Strict, Pgenval, id, defining_expr, transl_exp body) + | Texp_letmodule(_, _, Mp_absent, _, body) -> + transl_exp body + | Texp_letexception(cd, body) -> + Llet(Strict, Pgenval, + cd.ext_id, transl_extension_constructor e.exp_env None cd, + transl_exp body) + | Texp_pack modl -> + !transl_module Tcoerce_none None modl + | Texp_assert {exp_desc=Texp_construct(_, {cstr_name="false"}, _)} -> + assert_failed e + | Texp_assert (cond) -> + if !Clflags.noassert + then lambda_unit + else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e) + | Texp_lazy e -> + (* when e needs no computation (constants, identifiers, ...), we + optimize the translation just as Lazy.lazy_from_val would + do *) + begin match Typeopt.classify_lazy_argument e with + | `Constant_or_function -> + (* A constant expr (of type <> float if [Config.flat_float_array] is + true) gets compiled as itself. *) + transl_exp e + | `Float_that_cannot_be_shortcut -> + (* We don't need to wrap with Popaque: this forward + block will never be shortcutted since it points to a float + and Config.flat_float_array is true. *) + Lprim(Pmakeblock(Obj.forward_tag, Immutable, None), + [transl_exp e], e.exp_loc) + | `Identifier `Forward_value -> + (* CR-someday mshinwell: Consider adding a new primitive + that expresses the construction of forward_tag blocks. + We need to use [Popaque] here to prevent unsound + optimisation in Flambda, but the concept of a mutable + block doesn't really match what is going on here. This + value may subsequently turn into an immediate... *) + Lprim (Popaque, + [Lprim(Pmakeblock(Obj.forward_tag, Immutable, None), + [transl_exp e], e.exp_loc)], + e.exp_loc) + | `Identifier `Other -> + transl_exp e + | `Other -> + (* other cases compile to a lazy block holding a function *) + let fn = Lfunction {kind = Curried; + params= [Ident.create_local "param", Pgenval]; + return = Pgenval; + attr = default_function_attribute; + loc = e.exp_loc; + body = transl_exp e} in + Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [fn], e.exp_loc) + end + | Texp_object (cs, meths) -> + let cty = cs.cstr_type in + let cl = Ident.create_local "class" in + !transl_object cl meths + { cl_desc = Tcl_structure cs; + cl_loc = e.exp_loc; + cl_type = Cty_signature cty; + cl_env = e.exp_env; + cl_attributes = []; + } + | Texp_letop{let_; ands; param; body; partial} -> + event_after e + (transl_letop e.exp_loc e.exp_env let_ ands param body partial) + | Texp_unreachable -> + raise (Error (e.exp_loc, Unreachable_reached)) + | Texp_open (od, e) -> + let pure = pure_module od.open_expr in + (* this optimization shouldn't be needed because Simplif would + actually remove the [Llet] when it's not used. + But since [scan_used_globals] runs before Simplif, we need to + do it. *) + begin match od.open_bound_items with + | [] when pure = Alias -> transl_exp e + | _ -> + let oid = Ident.create_local "open" in + let body, _ = + List.fold_left (fun (body, pos) id -> + Llet(Alias, Pgenval, id, + Lprim(Pfield pos, [Lvar oid], od.open_loc), body), + pos + 1 + ) (transl_exp e, 0) (bound_value_identifiers od.open_bound_items) + in + Llet(pure, Pgenval, oid, + !transl_module Tcoerce_none None od.open_expr, body) + end + +and pure_module m = + match m.mod_desc with + Tmod_ident _ -> Alias + | Tmod_constraint (m,_,_,_) -> pure_module m + | _ -> Strict + +and transl_list expr_list = + List.map transl_exp expr_list + +and transl_list_with_shape expr_list = + let transl_with_shape e = + let shape = Typeopt.value_kind e.exp_env e.exp_type in + transl_exp e, shape + in + List.split (List.map transl_with_shape expr_list) + +and transl_guard guard rhs = + let expr = event_before rhs (transl_exp rhs) in + match guard with + | None -> expr + | Some cond -> + event_before cond (Lifthenelse(transl_exp cond, expr, staticfail)) + +and transl_case {c_lhs; c_guard; c_rhs} = + c_lhs, transl_guard c_guard c_rhs + +and transl_cases cases = + let cases = + List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in + List.map transl_case cases + +and transl_case_try {c_lhs; c_guard; c_rhs} = + iter_exn_names Translprim.add_exception_ident c_lhs; + Misc.try_finally + (fun () -> c_lhs, transl_guard c_guard c_rhs) + ~always:(fun () -> + iter_exn_names Translprim.remove_exception_ident c_lhs) + +and transl_cases_try cases = + let cases = + List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in + List.map transl_case_try cases + +and transl_tupled_cases patl_expr_list = + let patl_expr_list = + List.filter (fun (_,_,e) -> e.exp_desc <> Texp_unreachable) + patl_expr_list in + List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr)) + patl_expr_list + +and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline) + ?(specialised = Default_specialise) lam sargs loc = + let lapply funct args = + match funct with + Lsend(k, lmet, lobj, largs, loc) -> + Lsend(k, lmet, lobj, largs @ args, loc) + | Levent(Lsend(k, lmet, lobj, largs, loc), _) -> + Lsend(k, lmet, lobj, largs @ args, loc) + | Lapply ap -> + Lapply {ap with ap_args = ap.ap_args @ args; ap_loc = loc} + | lexp -> + Lapply {ap_should_be_tailcall=should_be_tailcall; + ap_loc=loc; + ap_func=lexp; + ap_args=args; + ap_inlined=inlined; + ap_specialised=specialised;} + in + let rec build_apply lam args = function + (None, optional) :: l -> + let defs = ref [] in + let protect name lam = + match lam with + Lvar _ | Lconst _ -> lam + | _ -> + let id = Ident.create_local name in + defs := (id, lam) :: !defs; + Lvar id + in + let args, args' = + if List.for_all (fun (_,opt) -> opt) args then [], args + else args, [] in + let lam = + if args = [] then lam else lapply lam (List.rev_map fst args) in + let handle = protect "func" lam + and l = List.map (fun (arg, opt) -> may_map (protect "arg") arg, opt) l + and id_arg = Ident.create_local "param" in + let body = + match build_apply handle ((Lvar id_arg, optional)::args') l with + Lfunction{kind = Curried; params = ids; return; + body = lam; attr; loc} -> + Lfunction{kind = Curried; + params = (id_arg, Pgenval)::ids; + return; + body = lam; attr; + loc} + | Levent(Lfunction{kind = Curried; params = ids; return; + body = lam; attr; loc}, _) -> + Lfunction{kind = Curried; params = (id_arg, Pgenval)::ids; + return; + body = lam; attr; + loc} + | lam -> + Lfunction{kind = Curried; params = [id_arg, Pgenval]; + return = Pgenval; body = lam; + attr = default_stub_attribute; loc = loc} + in + List.fold_left + (fun body (id, lam) -> Llet(Strict, Pgenval, id, lam, body)) + body !defs + | (Some arg, optional) :: l -> + build_apply lam ((arg, optional) :: args) l + | [] -> + lapply lam (List.rev_map fst args) + in + (build_apply lam [] (List.map (fun (l, x) -> + may_map transl_exp x, Btype.is_optional l) + sargs) + : Lambda.lambda) + +and transl_function loc return untuplify_fn repr partial (param:Ident.t) cases = + match cases with + [{c_lhs=pat; c_guard=None; + c_rhs={exp_desc = Texp_function { arg_label = _; param = param'; cases; + partial = partial'; }; exp_env; exp_type} as exp}] + when Parmatch.inactive ~partial pat -> + let kind = value_kind pat.pat_env pat.pat_type in + let return_kind = function_return_value_kind exp_env exp_type in + let ((_, params, return), body) = + transl_function exp.exp_loc return_kind false repr partial' param' cases + in + ((Curried, (param, kind) :: params, return), + Matching.for_function loc None (Lvar param) [pat, body] partial) + | {c_lhs={pat_desc = Tpat_tuple pl}} :: _ when untuplify_fn -> + begin try + let size = List.length pl in + let pats_expr_list = + List.map + (fun {c_lhs; c_guard; c_rhs} -> + (Matching.flatten_pattern size c_lhs, c_guard, c_rhs)) + cases in + let kinds = + (* All the patterns might not share the same types. We must take the + union of the patterns types *) + match pats_expr_list with + | [] -> assert false + | (pats, _, _) :: cases -> + let first_case_kinds = + List.map (fun pat -> value_kind pat.pat_env pat.pat_type) pats + in + List.fold_left + (fun kinds (pats, _, _) -> + List.map2 (fun kind pat -> + value_kind_union kind + (value_kind pat.pat_env pat.pat_type)) + kinds pats) + first_case_kinds cases + in + let tparams = + List.map (fun kind -> Ident.create_local "param", kind) kinds + in + let params = List.map fst tparams in + ((Tupled, tparams, return), + Matching.for_tupled_function loc params + (transl_tupled_cases pats_expr_list) partial) + with Matching.Cannot_flatten -> + ((Curried, [param, Pgenval], return), + Matching.for_function loc repr (Lvar param) + (transl_cases cases) partial) + end + | {c_lhs=pat} :: other_cases -> + let kind = + (* All the patterns might not share the same types. We must take the + union of the patterns types *) + List.fold_left (fun k {c_lhs=pat} -> + Typeopt.value_kind_union k + (value_kind pat.pat_env pat.pat_type)) + (value_kind pat.pat_env pat.pat_type) other_cases + in + ((Curried, [param, kind], return), + Matching.for_function loc repr (Lvar param) + (transl_cases cases) partial) + | [] -> + (* With Camlp4, a pattern matching might be empty *) + ((Curried, [param, Pgenval], return), + Matching.for_function loc repr (Lvar param) + (transl_cases cases) partial) + +(* + Notice: transl_let consumes (ie compiles) its pat_expr_list argument, + and returns a function that will take the body of the lambda-let construct. + This complication allows choosing any compilation order for the + bindings and body of let constructs. +*) +and transl_let rec_flag pat_expr_list = + match rec_flag with + Nonrecursive -> + let rec transl = function + [] -> + fun body -> body + | {vb_pat=pat; vb_expr=expr; vb_attributes=attr; vb_loc} :: rem -> + let lam = transl_exp expr in + let lam = Translattribute.add_function_attributes lam vb_loc attr in + let mk_body = transl rem in + fun body -> Matching.for_let pat.pat_loc lam pat (mk_body body) + in transl pat_expr_list + | Recursive -> + let idlist = + List.map + (fun {vb_pat=pat} -> match pat.pat_desc with + Tpat_var (id,_) -> id + | Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id + | _ -> assert false) + pat_expr_list in + let transl_case {vb_expr=expr; vb_attributes; vb_loc} id = + let lam = transl_exp expr in + let lam = + Translattribute.add_function_attributes lam vb_loc vb_attributes + in + (id, lam) in + let lam_bds = List.map2 transl_case pat_expr_list idlist in + fun body -> Lletrec(lam_bds, body) + +and transl_setinstvar loc self var expr = + Lprim(Psetfield_computed (maybe_pointer expr, Assignment), + [self; var; transl_exp expr], loc) + +and transl_record loc env fields repres opt_init_expr = + let size = Array.length fields in + (* Determine if there are "enough" fields (only relevant if this is a + functional-style record update *) + let no_init = match opt_init_expr with None -> true | _ -> false in + if no_init || size < Config.max_young_wosize + then begin + (* Allocate new record with given fields (and remaining fields + taken from init_expr if any *) + let init_id = Ident.create_local "init" in + let lv = + Array.mapi + (fun i (_, definition) -> + match definition with + | Kept typ -> + let field_kind = value_kind env typ in + let access = + match repres with + Record_regular | Record_inlined _ -> Pfield i + | Record_unboxed _ -> assert false + | Record_extension _ -> Pfield (i + 1) + | Record_float -> Pfloatfield i in + Lprim(access, [Lvar init_id], loc), field_kind + | Overridden (_lid, expr) -> + let field_kind = value_kind expr.exp_env expr.exp_type in + transl_exp expr, field_kind) + fields + in + let ll, shape = List.split (Array.to_list lv) in + let mut = + if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields + then Mutable + else Immutable in + let lam = + try + if mut = Mutable then raise Not_constant; + let cl = List.map extract_constant ll in + match repres with + | Record_regular -> Lconst(Const_block(0, cl)) + | Record_inlined tag -> Lconst(Const_block(tag, cl)) + | Record_unboxed _ -> Lconst(match cl with [v] -> v | _ -> assert false) + | Record_float -> + Lconst(Const_float_array(List.map extract_float cl)) + | Record_extension _ -> + raise Not_constant + with Not_constant -> + match repres with + Record_regular -> + Lprim(Pmakeblock(0, mut, Some shape), ll, loc) + | Record_inlined tag -> + Lprim(Pmakeblock(tag, mut, Some shape), ll, loc) + | Record_unboxed _ -> (match ll with [v] -> v | _ -> assert false) + | Record_float -> + Lprim(Pmakearray (Pfloatarray, mut), ll, loc) + | Record_extension path -> + let slot = transl_extension_path loc env path in + Lprim(Pmakeblock(0, mut, Some (Pgenval :: shape)), slot :: ll, loc) + in + begin match opt_init_expr with + None -> lam + | Some init_expr -> Llet(Strict, Pgenval, init_id, + transl_exp init_expr, lam) + end + end else begin + (* Take a shallow copy of the init record, then mutate the fields + of the copy *) + let copy_id = Ident.create_local "newrecord" in + let update_field cont (lbl, definition) = + match definition with + | Kept _type -> cont + | Overridden (_lid, expr) -> + let upd = + match repres with + Record_regular + | Record_inlined _ -> + Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment) + | Record_unboxed _ -> assert false + | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment) + | Record_extension _ -> + Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment) + in + Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr], loc), cont) + in + begin match opt_init_expr with + None -> assert false + | Some init_expr -> + Llet(Strict, Pgenval, copy_id, + Lprim(Pduprecord (repres, size), [transl_exp init_expr], loc), + Array.fold_left update_field (Lvar copy_id) fields) + end + end + +and transl_match e arg pat_expr_list partial = + let rewrite_case (val_cases, exn_cases, static_handlers as acc) + ({ c_lhs; c_guard; c_rhs } as case) = + if c_rhs.exp_desc = Texp_unreachable then acc else + let val_pat, exn_pat = split_pattern c_lhs in + match val_pat, exn_pat with + | None, None -> assert false + | Some pv, None -> + let val_case = + transl_case { case with c_lhs = pv } + in + val_case :: val_cases, exn_cases, static_handlers + | None, Some pe -> + let exn_case = transl_case_try { case with c_lhs = pe } in + val_cases, exn_case :: exn_cases, static_handlers + | Some pv, Some pe -> + assert (c_guard = None); + let lbl = next_raise_count () in + let static_raise ids = + Lstaticraise (lbl, List.map (fun id -> Lvar id) ids) + in + (* Simplif doesn't like it if binders are not uniq, so we make sure to + use different names in the value and the exception branches. *) + let ids_full = Typedtree.pat_bound_idents_full pv in + let ids = List.map (fun (id, _, _) -> id) ids_full in + let ids_kinds = + List.map (fun (id, _, ty) -> id, Typeopt.value_kind pv.pat_env ty) + ids_full + in + let vids = List.map Ident.rename ids in + let pv = alpha_pat (List.combine ids vids) pv in + (* Also register the names of the exception so Re-raise happens. *) + iter_exn_names Translprim.add_exception_ident pe; + let rhs = + Misc.try_finally + (fun () -> event_before c_rhs (transl_exp c_rhs)) + ~always:(fun () -> + iter_exn_names Translprim.remove_exception_ident pe) + in + (pv, static_raise vids) :: val_cases, + (pe, static_raise ids) :: exn_cases, + (lbl, ids_kinds, rhs) :: static_handlers + in + let val_cases, exn_cases, static_handlers = + let x, y, z = List.fold_left rewrite_case ([], [], []) pat_expr_list in + List.rev x, List.rev y, List.rev z + in + let static_catch body val_ids handler = + let id = Typecore.name_pattern "exn" (List.map fst exn_cases) in + let static_exception_id = next_raise_count () in + Lstaticcatch + (Ltrywith (Lstaticraise (static_exception_id, body), id, + Matching.for_trywith (Lvar id) exn_cases), + (static_exception_id, val_ids), + handler) + in + let classic = + match arg, exn_cases with + | {exp_desc = Texp_tuple argl}, [] -> + assert (static_handlers = []); + Matching.for_multiple_match e.exp_loc (transl_list argl) val_cases partial + | {exp_desc = Texp_tuple argl}, _ :: _ -> + let val_ids = + List.map + (fun arg -> + Typecore.name_pattern "val" [], + Typeopt.value_kind arg.exp_env arg.exp_type + ) + argl + in + let lvars = List.map (fun (id, _) -> Lvar id) val_ids in + static_catch (transl_list argl) val_ids + (Matching.for_multiple_match e.exp_loc lvars val_cases partial) + | arg, [] -> + assert (static_handlers = []); + Matching.for_function e.exp_loc None (transl_exp arg) val_cases partial + | arg, _ :: _ -> + let val_id = Typecore.name_cases "val" pat_expr_list in + let k = Typeopt.value_kind arg.exp_env arg.exp_type in + static_catch [transl_exp arg] [val_id, k] + (Matching.for_function e.exp_loc None (Lvar val_id) val_cases partial) + in + List.fold_left (fun body (static_exception_id, val_ids, handler) -> + Lstaticcatch (body, (static_exception_id, val_ids), handler) + ) classic static_handlers + +and transl_letop loc env let_ ands param case partial = + let rec loop prev_lam = function + | [] -> prev_lam + | and_ :: rest -> + let left_id = Ident.create_local "left" in + let right_id = Ident.create_local "right" in + let op = + transl_ident and_.bop_op_name.loc env + and_.bop_op_type and_.bop_op_path and_.bop_op_val + in + let exp = transl_exp and_.bop_exp in + let lam = + bind Strict right_id exp + (Lapply{ap_should_be_tailcall = false; + ap_loc = and_.bop_loc; + ap_func = op; + ap_args=[Lvar left_id; Lvar right_id]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}) + in + bind Strict left_id prev_lam (loop lam rest) + in + let op = + transl_ident let_.bop_op_name.loc env + let_.bop_op_type let_.bop_op_path let_.bop_op_val + in + let exp = loop (transl_exp let_.bop_exp) ands in + let func = + let return_kind = value_kind case.c_rhs.exp_env case.c_rhs.exp_type in + let (kind, params, return), body = + event_function case.c_rhs + (function repr -> + transl_function case.c_rhs.exp_loc return_kind + !Clflags.native_code repr partial param [case]) + in + let attr = default_function_attribute in + let loc = case.c_rhs.exp_loc in + Lfunction{kind; params; return; body; attr; loc} + in + Lapply{ap_should_be_tailcall = false; + ap_loc = loc; + ap_func = op; + ap_args=[exp; func]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} + +(* Wrapper for class compilation *) + +(* +let transl_exp = transl_exp_wrap + +let transl_let rec_flag pat_expr_list body = + match pat_expr_list with + [] -> body + | (_, expr) :: _ -> + Translobj.oo_wrap expr.exp_env false + (transl_let rec_flag pat_expr_list) body +*) + +(* Error report *) + +open Format + +let report_error ppf = function + | Free_super_var -> + fprintf ppf + "Ancestor names can only be used to select inherited methods" + | Unreachable_reached -> + fprintf ppf "Unreachable expression was reached" + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer ~loc report_error err) + | _ -> + None + ) diff --git a/lambda/translcore.mli b/lambda/translcore.mli new file mode 100644 index 00000000..7a27dbcb --- /dev/null +++ b/lambda/translcore.mli @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Translation from typed abstract syntax to lambda terms, + for the core language *) + +open Asttypes +open Typedtree +open Lambda + +val pure_module : module_expr -> let_kind + +val transl_exp: expression -> lambda +val transl_apply: ?should_be_tailcall:bool + -> ?inlined:inline_attribute + -> ?specialised:specialise_attribute + -> lambda -> (arg_label * expression option) list + -> Location.t -> lambda +val transl_let: rec_flag -> value_binding list -> lambda -> lambda + +val transl_extension_constructor: Env.t -> Path.t option -> + extension_constructor -> lambda + +type error = + Free_super_var + | Unreachable_reached + +exception Error of Location.t * error + +open Format + +val report_error: formatter -> error -> unit + +(* Forward declaration -- to be filled in by Translmod.transl_module *) +val transl_module : + (module_coercion -> Path.t option -> module_expr -> lambda) ref +val transl_object : + (Ident.t -> string list -> class_expr -> lambda) ref diff --git a/lambda/translmod.ml b/lambda/translmod.ml new file mode 100644 index 00000000..be6ecc31 --- /dev/null +++ b/lambda/translmod.ml @@ -0,0 +1,1560 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Translation from typed abstract syntax to lambda terms, + for the module language *) + +open Misc +open Asttypes +open Path +open Types +open Typedtree +open Lambda +open Translobj +open Translcore +open Translclass + +type unsafe_component = + | Unsafe_module_binding + | Unsafe_functor + | Unsafe_non_function + | Unsafe_typext + +type unsafe_info = { reason:unsafe_component; loc:Location.t; subid:Ident.t } +type error = + Circular_dependency of (Ident.t * unsafe_info) list +| Conflicting_inline_attributes + +exception Error of Location.t * error + +(* Keep track of the root path (from the root of the namespace to the + currently compiled module expression). Useful for naming extensions. *) + +let global_path glob = Some(Pident glob) +let functor_path path param = + match path with + None -> None + | Some p -> Some(Papply(p, Pident param)) +let field_path path field = + match path with + None -> None + | Some p -> Some(Pdot(p, Ident.name field)) + +(* Compile type extensions *) + +let transl_type_extension env rootpath tyext body = + List.fold_right + (fun ext body -> + let lam = + transl_extension_constructor env (field_path rootpath ext.ext_id) ext + in + Llet(Strict, Pgenval, ext.ext_id, lam, body)) + tyext.tyext_constructors + body + +(* Compile a coercion *) + +let rec apply_coercion loc strict restr arg = + match restr with + Tcoerce_none -> + arg + | Tcoerce_structure(pos_cc_list, id_pos_list) -> + name_lambda strict arg (fun id -> + let get_field pos = + if pos < 0 then lambda_unit + else Lprim(Pfield pos,[Lvar id], loc) + in + let lam = + Lprim(Pmakeblock(0, Immutable, None), + List.map (apply_coercion_field loc get_field) pos_cc_list, + loc) + in + wrap_id_pos_list loc id_pos_list get_field lam) + | Tcoerce_functor(cc_arg, cc_res) -> + let param = Ident.create_local "funarg" in + let carg = apply_coercion loc Alias cc_arg (Lvar param) in + apply_coercion_result loc strict arg [param, Pgenval] [carg] cc_res + | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } -> + Translprim.transl_primitive pc_loc pc_desc pc_env pc_type None + | Tcoerce_alias (env, path, cc) -> + let lam = transl_module_path loc env path in + name_lambda strict arg + (fun _ -> apply_coercion loc Alias cc lam) + +and apply_coercion_field loc get_field (pos, cc) = + apply_coercion loc Alias cc (get_field pos) + +and apply_coercion_result loc strict funct params args cc_res = + match cc_res with + | Tcoerce_functor(cc_arg, cc_res) -> + let param = Ident.create_local "funarg" in + let arg = apply_coercion loc Alias cc_arg (Lvar param) in + apply_coercion_result loc strict funct + ((param, Pgenval) :: params) (arg :: args) cc_res + | _ -> + name_lambda strict funct + (fun id -> + Lfunction + { + kind = Curried; + params = List.rev params; + return = Pgenval; + attr = { default_function_attribute with + is_a_functor = true; + stub = true; }; + loc = loc; + body = apply_coercion + loc Strict cc_res + (Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=Lvar id; + ap_args=List.rev args; + ap_inlined=Default_inline; + ap_specialised=Default_specialise})}) + +and wrap_id_pos_list loc id_pos_list get_field lam = + let fv = free_variables lam in + (*Format.eprintf "%a@." Printlambda.lambda lam; + Ident.Set.iter (fun id -> Format.eprintf "%a " Ident.print id) fv; + Format.eprintf "@.";*) + let (lam,s) = + List.fold_left (fun (lam, s) (id',pos,c) -> + if Ident.Set.mem id' fv then + let id'' = Ident.create_local (Ident.name id') in + (Llet(Alias, Pgenval, id'', + apply_coercion loc Alias c (get_field pos),lam), + Ident.Map.add id' id'' s) + else (lam, s)) + (lam, Ident.Map.empty) id_pos_list + in + if s == Ident.Map.empty then lam else Lambda.rename s lam + + +(* Compose two coercions + apply_coercion c1 (apply_coercion c2 e) behaves like + apply_coercion (compose_coercions c1 c2) e. *) + +let rec compose_coercions c1 c2 = + match (c1, c2) with + (Tcoerce_none, c2) -> c2 + | (c1, Tcoerce_none) -> c1 + | (Tcoerce_structure (pc1, ids1), Tcoerce_structure (pc2, ids2)) -> + let v2 = Array.of_list pc2 in + let ids1 = + List.map (fun (id,pos1,c1) -> + let (pos2,c2) = v2.(pos1) in (id, pos2, compose_coercions c1 c2)) + ids1 + in + Tcoerce_structure + (List.map + (fun pc -> + match pc with + | _, (Tcoerce_primitive _ | Tcoerce_alias _) -> + (* These cases do not take an argument (the position is -1), + so they do not need adjusting. *) + pc + | (p1, c1) -> + let (p2, c2) = v2.(p1) in + (p2, compose_coercions c1 c2)) + pc1, + ids1 @ ids2) + | (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) -> + Tcoerce_functor(compose_coercions arg2 arg1, + compose_coercions res1 res2) + | (c1, Tcoerce_alias (env, path, c2)) -> + Tcoerce_alias (env, path, compose_coercions c1 c2) + | (_, _) -> + fatal_error "Translmod.compose_coercions" + +(* +let apply_coercion a b c = + Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion b; + apply_coercion a b c + +let compose_coercions c1 c2 = + let c3 = compose_coercions c1 c2 in + let open Includemod in + Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@." + print_coercion c1 print_coercion c2 print_coercion c3; + c3 +*) + +(* Record the primitive declarations occurring in the module compiled *) + +let primitive_declarations = ref ([] : Primitive.description list) +let record_primitive = function + | {val_kind=Val_prim p;val_loc} -> + Translprim.check_primitive_arity val_loc p; + primitive_declarations := p :: !primitive_declarations + | _ -> () + +(* Utilities for compiling "module rec" definitions *) + +let mod_prim = Lambda.transl_prim "CamlinternalMod" + +let undefined_location loc = + let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in + Lconst(Const_block(0, + [Const_base(Const_string (fname, None)); + Const_base(Const_int line); + Const_base(Const_int char)])) + +exception Initialization_failure of unsafe_info + +let init_shape id modl = + let rec init_shape_mod subid loc env mty = + match Mtype.scrape env mty with + Mty_ident _ + | Mty_alias _ -> + raise (Initialization_failure {reason=Unsafe_module_binding;loc;subid}) + | Mty_signature sg -> + Const_block(0, [Const_block(0, init_shape_struct env sg)]) + | Mty_functor _ -> + (* can we do better? *) + raise (Initialization_failure {reason=Unsafe_functor;loc;subid}) + and init_shape_struct env sg = + match sg with + [] -> [] + | Sig_value(subid, {val_kind=Val_reg; val_type=ty; val_loc=loc},_) :: rem -> + let init_v = + match Ctype.expand_head env ty with + {desc = Tarrow(_,_,_,_)} -> + Const_pointer 0 (* camlinternalMod.Function *) + | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t -> + Const_pointer 1 (* camlinternalMod.Lazy *) + | _ -> + let not_a_function = {reason=Unsafe_non_function; loc; subid } in + raise (Initialization_failure not_a_function) in + init_v :: init_shape_struct env rem + | Sig_value(_, {val_kind=Val_prim _}, _) :: rem -> + init_shape_struct env rem + | Sig_value _ :: _rem -> + assert false + | Sig_type(id, tdecl, _, _) :: rem -> + init_shape_struct (Env.add_type ~check:false id tdecl env) rem + | Sig_typext (subid, {ext_loc=loc},_,_) :: _ -> + raise (Initialization_failure {reason=Unsafe_typext; loc; subid}) + | Sig_module(id, Mp_present, md, _, _) :: rem -> + init_shape_mod id md.md_loc env md.md_type :: + init_shape_struct (Env.add_module_declaration ~check:false + id Mp_present md env) rem + | Sig_module(id, Mp_absent, md, _, _) :: rem -> + init_shape_struct + (Env.add_module_declaration ~check:false + id Mp_absent md env) rem + | Sig_modtype(id, minfo, _) :: rem -> + init_shape_struct (Env.add_modtype id minfo env) rem + | Sig_class _ :: rem -> + Const_pointer 2 (* camlinternalMod.Class *) + :: init_shape_struct env rem + | Sig_class_type _ :: rem -> + init_shape_struct env rem + in + try + Ok(undefined_location modl.mod_loc, + Lconst(init_shape_mod id modl.mod_loc modl.mod_env modl.mod_type)) + with Initialization_failure reason -> Result.Error(reason) + +(* Reorder bindings to honor dependencies. *) + +type binding_status = + | Undefined + | Inprogress of int option (** parent node *) + | Defined + +let extract_unsafe_cycle id status init cycle_start = + let info i = match init.(i) with + | Result.Error r -> id.(i), r + | Ok _ -> assert false in + let rec collect stop l i = match status.(i) with + | Inprogress None | Undefined | Defined -> assert false + | Inprogress Some i when i = stop -> info i :: l + | Inprogress Some i -> collect stop (info i::l) i in + collect cycle_start [] cycle_start + +let reorder_rec_bindings bindings = + let id = Array.of_list (List.map (fun (id,_,_,_) -> id) bindings) + and loc = Array.of_list (List.map (fun (_,loc,_,_) -> loc) bindings) + and init = Array.of_list (List.map (fun (_,_,init,_) -> init) bindings) + and rhs = Array.of_list (List.map (fun (_,_,_,rhs) -> rhs) bindings) in + let fv = Array.map Lambda.free_variables rhs in + let num_bindings = Array.length id in + let status = Array.make num_bindings Undefined in + let res = ref [] in + let is_unsafe i = match init.(i) with + | Ok _ -> false + | Result.Error _ -> true in + let init_res i = match init.(i) with + | Result.Error _ -> None + | Ok(a,b) -> Some(a,b) in + let rec emit_binding parent i = + match status.(i) with + Defined -> () + | Inprogress _ -> + status.(i) <- Inprogress parent; + let cycle = extract_unsafe_cycle id status init i in + raise(Error(loc.(i), Circular_dependency cycle)) + | Undefined -> + if is_unsafe i then begin + status.(i) <- Inprogress parent; + for j = 0 to num_bindings - 1 do + if Ident.Set.mem id.(j) fv.(i) then emit_binding (Some i) j + done + end; + res := (id.(i), init_res i, rhs.(i)) :: !res; + status.(i) <- Defined in + for i = 0 to num_bindings - 1 do + match status.(i) with + Undefined -> emit_binding None i + | Inprogress _ -> assert false + | Defined -> () + done; + List.rev !res + +(* Generate lambda-code for a reordered list of bindings *) + +let eval_rec_bindings bindings cont = + let rec bind_inits = function + [] -> + bind_strict bindings + | (_id, None, _rhs) :: rem -> + bind_inits rem + | (id, Some(loc, shape), _rhs) :: rem -> + Llet(Strict, Pgenval, id, + Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=mod_prim "init_mod"; + ap_args=[loc; shape]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}, + bind_inits rem) + and bind_strict = function + [] -> + patch_forwards bindings + | (id, None, rhs) :: rem -> + Llet(Strict, Pgenval, id, rhs, bind_strict rem) + | (_id, Some _, _rhs) :: rem -> + bind_strict rem + and patch_forwards = function + [] -> + cont + | (_id, None, _rhs) :: rem -> + patch_forwards rem + | (id, Some(_loc, shape), rhs) :: rem -> + Lsequence(Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=mod_prim "update_mod"; + ap_args=[shape; Lvar id; rhs]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}, + patch_forwards rem) + in + bind_inits bindings + +let compile_recmodule compile_rhs bindings cont = + eval_rec_bindings + (reorder_rec_bindings + (List.map + (fun {mb_id=id; mb_expr=modl; mb_loc=loc; _} -> + (id, modl.mod_loc, init_shape id modl, compile_rhs id modl loc)) + bindings)) + cont + +(* Code to translate class entries in a structure *) + +let transl_class_bindings cl_list = + let ids = List.map (fun (ci, _) -> ci.ci_id_class) cl_list in + (ids, + List.map + (fun ({ci_id_class=id; ci_expr=cl; ci_virt=vf}, meths) -> + (id, transl_class ids id meths cl vf)) + cl_list) + +(* Compile one or more functors, merging curried functors to produce + multi-argument functors. Any [@inline] attribute on a functor that is + merged must be consistent with any other [@inline] attribute(s) on the + functor(s) being merged with. Such an attribute will be placed on the + resulting merged functor. *) + +let merge_inline_attributes attr1 attr2 loc = + match Lambda.merge_inline_attributes attr1 attr2 with + | Some attr -> attr + | None -> raise (Error (loc, Conflicting_inline_attributes)) + +let merge_functors mexp coercion root_path = + let rec merge mexp coercion path acc inline_attribute = + let finished = acc, mexp, path, coercion, inline_attribute in + match mexp.mod_desc with + | Tmod_functor (param, _, _, body) -> + let inline_attribute' = + Translattribute.get_inline_attribute mexp.mod_attributes + in + let arg_coercion, res_coercion = + match coercion with + | Tcoerce_none -> Tcoerce_none, Tcoerce_none + | Tcoerce_functor (arg_coercion, res_coercion) -> + arg_coercion, res_coercion + | _ -> fatal_error "Translmod.merge_functors: bad coercion" + in + let loc = mexp.mod_loc in + let path = functor_path path param in + let inline_attribute = + merge_inline_attributes inline_attribute inline_attribute' loc + in + merge body res_coercion path ((param, loc, arg_coercion) :: acc) + inline_attribute + | _ -> finished + in + merge mexp coercion root_path [] Default_inline + +let rec compile_functor mexp coercion root_path loc = + let functor_params_rev, body, body_path, res_coercion, inline_attribute = + merge_functors mexp coercion root_path + in + assert (List.length functor_params_rev >= 1); (* cf. [transl_module] *) + let params, body = + List.fold_left (fun (params, body) (param, loc, arg_coercion) -> + let param' = Ident.rename param in + let arg = apply_coercion loc Alias arg_coercion (Lvar param') in + let params = (param', Pgenval) :: params in + let body = Llet (Alias, Pgenval, param, arg, body) in + params, body) + ([], transl_module res_coercion body_path body) + functor_params_rev + in + Lfunction { + kind = Curried; + params; + return = Pgenval; + attr = { + inline = inline_attribute; + specialise = Default_specialise; + local = Default_local; + is_a_functor = true; + stub = false; + }; + loc; + body; + } + +(* Compile a module expression *) + +and transl_module cc rootpath mexp = + List.iter (Translattribute.check_attribute_on_module mexp) + mexp.mod_attributes; + let loc = mexp.mod_loc in + match mexp.mod_desc with + | Tmod_ident (path,_) -> + apply_coercion loc Strict cc + (transl_module_path loc mexp.mod_env path) + | Tmod_structure str -> + fst (transl_struct loc [] cc rootpath str) + | Tmod_functor _ -> + oo_wrap mexp.mod_env true (fun () -> + compile_functor mexp cc rootpath loc) () + | Tmod_apply(funct, arg, ccarg) -> + let inlined_attribute, funct = + Translattribute.get_and_remove_inlined_attribute_on_module funct + in + oo_wrap mexp.mod_env true + (apply_coercion loc Strict cc) + (Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=transl_module Tcoerce_none None funct; + ap_args=[transl_module ccarg None arg]; + ap_inlined=inlined_attribute; + ap_specialised=Default_specialise}) + | Tmod_constraint(arg, _, _, ccarg) -> + transl_module (compose_coercions cc ccarg) rootpath arg + | Tmod_unpack(arg, _) -> + apply_coercion loc Strict cc (Translcore.transl_exp arg) + +and transl_struct loc fields cc rootpath str = + transl_structure loc fields cc rootpath str.str_final_env str.str_items + +(* The function transl_structure is called by the bytecode compiler. + Some effort is made to compile in top to bottom order, in order to display + warning by increasing locations. *) +and transl_structure loc fields cc rootpath final_env = function + [] -> + let body, size = + match cc with + Tcoerce_none -> + Lprim(Pmakeblock(0, Immutable, None), + List.map (fun id -> Lvar id) (List.rev fields), loc), + List.length fields + | Tcoerce_structure(pos_cc_list, id_pos_list) -> + (* Do not ignore id_pos_list ! *) + (*Format.eprintf "%a@.@[" Includemod.print_coercion cc; + List.iter (fun l -> Format.eprintf "%a@ " Ident.print l) + fields; + Format.eprintf "@]@.";*) + let v = Array.of_list (List.rev fields) in + let get_field pos = + if pos < 0 then lambda_unit + else Lvar v.(pos) + in + let ids = List.fold_right Ident.Set.add fields Ident.Set.empty in + let lam = + Lprim(Pmakeblock(0, Immutable, None), + List.map + (fun (pos, cc) -> + match cc with + Tcoerce_primitive p -> + Translprim.transl_primitive p.pc_loc + p.pc_desc p.pc_env p.pc_type None + | _ -> apply_coercion loc Strict cc (get_field pos)) + pos_cc_list, loc) + and id_pos_list = + List.filter (fun (id,_,_) -> not (Ident.Set.mem id ids)) + id_pos_list + in + wrap_id_pos_list loc id_pos_list get_field lam, + List.length pos_cc_list + | _ -> + fatal_error "Translmod.transl_structure" + in + (* This debugging event provides information regarding the structure + items. It is ignored by the OCaml debugger but is used by + Js_of_ocaml to preserve variable names. *) + (if !Clflags.debug && not !Clflags.native_code then + Levent(body, + {lev_loc = loc; + lev_kind = Lev_pseudo; + lev_repr = None; + lev_env = final_env}) + else + body), + size + | item :: rem -> + match item.str_desc with + | Tstr_eval (expr, _) -> + let body, size = + transl_structure loc fields cc rootpath final_env rem + in + Lsequence(transl_exp expr, body), size + | Tstr_value(rec_flag, pat_expr_list) -> + (* Translate bindings first *) + let mk_lam_let = transl_let rec_flag pat_expr_list in + let ext_fields = rev_let_bound_idents pat_expr_list @ fields in + (* Then, translate remainder of struct *) + let body, size = + transl_structure loc ext_fields cc rootpath final_env rem + in + mk_lam_let body, size + | Tstr_primitive descr -> + record_primitive descr.val_val; + transl_structure loc fields cc rootpath final_env rem + | Tstr_type _ -> + transl_structure loc fields cc rootpath final_env rem + | Tstr_typext(tyext) -> + let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + let body, size = + transl_structure loc (List.rev_append ids fields) + cc rootpath final_env rem + in + transl_type_extension item.str_env rootpath tyext body, size + | Tstr_exception ext -> + let id = ext.tyexn_constructor.ext_id in + let path = field_path rootpath id in + let body, size = + transl_structure loc (id :: fields) cc rootpath final_env rem + in + Llet(Strict, Pgenval, id, + transl_extension_constructor item.str_env + path + ext.tyexn_constructor, body), + size + | Tstr_module ({mb_presence=Mp_present} as mb) -> + let id = mb.mb_id in + (* Translate module first *) + let module_body = + transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr + in + let module_body = + Translattribute.add_inline_attribute module_body mb.mb_loc + mb.mb_attributes + in + (* Translate remainder second *) + let body, size = + transl_structure loc (id :: fields) cc rootpath final_env rem + in + let module_body = + Levent (module_body, { + lev_loc = mb.mb_loc; + lev_kind = Lev_module_definition id; + lev_repr = None; + lev_env = Env.empty; + }) + in + Llet(pure_module mb.mb_expr, Pgenval, id, + module_body, + body), size + | Tstr_module {mb_presence=Mp_absent} -> + transl_structure loc fields cc rootpath final_env rem + | Tstr_recmodule bindings -> + let ext_fields = + List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields + in + let body, size = + transl_structure loc ext_fields cc rootpath final_env rem + in + let lam = + compile_recmodule + (fun id modl loc -> + let module_body = + transl_module Tcoerce_none (field_path rootpath id) modl + in + Levent (module_body, { + lev_loc = loc; + lev_kind = Lev_module_definition id; + lev_repr = None; + lev_env = Env.empty; + })) + bindings + body + in + lam, size + | Tstr_class cl_list -> + let (ids, class_bindings) = transl_class_bindings cl_list in + let body, size = + transl_structure loc (List.rev_append ids fields) + cc rootpath final_env rem + in + Lletrec(class_bindings, body), size + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in + let mid = Ident.create_local "include" in + let rec rebind_idents pos newfields = function + [] -> + transl_structure loc newfields cc rootpath final_env rem + | id :: ids -> + let body, size = + rebind_idents (pos + 1) (id :: newfields) ids + in + Llet(Alias, Pgenval, id, + Lprim(Pfield pos, [Lvar mid], incl.incl_loc), body), + size + in + let body, size = rebind_idents 0 fields ids in + Llet(pure_module modl, Pgenval, mid, + transl_module Tcoerce_none None modl, body), + size + + | Tstr_open od -> + let pure = pure_module od.open_expr in + (* this optimization shouldn't be needed because Simplif would + actually remove the [Llet] when it's not used. + But since [scan_used_globals] runs before Simplif, we need to do + it. *) + begin match od.open_bound_items with + | [] when pure = Alias -> + transl_structure loc fields cc rootpath final_env rem + | _ -> + let ids = bound_value_identifiers od.open_bound_items in + let mid = Ident.create_local "open" in + let rec rebind_idents pos newfields = function + [] -> + transl_structure loc newfields cc rootpath final_env rem + | id :: ids -> + let body, size = + rebind_idents (pos + 1) (id :: newfields) ids + in + Llet(Alias, Pgenval, id, + Lprim(Pfield pos, [Lvar mid], od.open_loc), body), + size + in + let body, size = rebind_idents 0 fields ids in + Llet(pure, Pgenval, mid, + transl_module Tcoerce_none None od.open_expr, body), size + end + | Tstr_modtype _ + | Tstr_class_type _ + | Tstr_attribute _ -> + transl_structure loc fields cc rootpath final_env rem + +(* Update forward declaration in Translcore *) +let _ = + Translcore.transl_module := transl_module + +(* Introduce dependencies on modules referenced only by "external". *) + +let scan_used_globals lam = + let globals = ref Ident.Set.empty in + let rec scan lam = + Lambda.iter_head_constructor scan lam; + match lam with + Lprim ((Pgetglobal id | Psetglobal id), _, _) -> + globals := Ident.Set.add id !globals + | _ -> () + in + scan lam; !globals + +let required_globals ~flambda body = + let globals = scan_used_globals body in + let add_global id req = + if not flambda && Ident.Set.mem id globals then + req + else + Ident.Set.add id req + in + let required = + List.fold_left + (fun acc path -> add_global (Path.head path) acc) + (if flambda then globals else Ident.Set.empty) + (Translprim.get_used_primitives ()) + in + let required = + List.fold_right add_global (Env.get_required_globals ()) required + in + Env.reset_required_globals (); + Translprim.clear_used_primitives (); + required + +(* Compile an implementation *) + +let transl_implementation_flambda module_name (str, cc) = + reset_labels (); + primitive_declarations := []; + Translprim.clear_used_primitives (); + let module_id = Ident.create_persistent module_name in + let body, size = + Translobj.transl_label_init + (fun () -> transl_struct Location.none [] cc + (global_path module_id) str) + in + { module_ident = module_id; + main_module_block_size = size; + required_globals = required_globals ~flambda:true body; + code = body } + +let transl_implementation module_name (str, cc) = + let implementation = + transl_implementation_flambda module_name (str, cc) + in + let code = + Lprim (Psetglobal implementation.module_ident, [implementation.code], + Location.none) + in + { implementation with code } + +(* Build the list of value identifiers defined by a toplevel structure + (excluding primitive declarations). *) + +let rec defined_idents = function + [] -> [] + | item :: rem -> + match item.str_desc with + | Tstr_eval _ -> defined_idents rem + | Tstr_value(_rec_flag, pat_expr_list) -> + let_bound_idents pat_expr_list @ defined_idents rem + | Tstr_primitive _ -> defined_idents rem + | Tstr_type _ -> defined_idents rem + | Tstr_typext tyext -> + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + @ defined_idents rem + | Tstr_exception ext -> ext.tyexn_constructor.ext_id :: defined_idents rem + | Tstr_module {mb_id; mb_presence=Mp_present} -> mb_id :: defined_idents rem + | Tstr_module {mb_presence=Mp_absent} -> defined_idents rem + | Tstr_recmodule decls -> + List.map (fun mb -> mb.mb_id) decls @ defined_idents rem + | Tstr_modtype _ -> defined_idents rem + | Tstr_open od -> + bound_value_identifiers od.open_bound_items @ defined_idents rem + | Tstr_class cl_list -> + List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ defined_idents rem + | Tstr_class_type _ -> defined_idents rem + | Tstr_include incl -> + bound_value_identifiers incl.incl_type @ defined_idents rem + | Tstr_attribute _ -> defined_idents rem + +(* second level idents (module M = struct ... let id = ... end), + and all sub-levels idents *) +let rec more_idents = function + [] -> [] + | item :: rem -> + match item.str_desc with + | Tstr_eval _ -> more_idents rem + | Tstr_value _ -> more_idents rem + | Tstr_primitive _ -> more_idents rem + | Tstr_type _ -> more_idents rem + | Tstr_typext _ -> more_idents rem + | Tstr_exception _ -> more_idents rem + | Tstr_recmodule _ -> more_idents rem + | Tstr_modtype _ -> more_idents rem + | Tstr_open od -> + let rest = more_idents rem in + begin match od.open_expr.mod_desc with + | Tmod_structure str -> all_idents str.str_items @ rest + | _ -> rest + end + | Tstr_class _ -> more_idents rem + | Tstr_class_type _ -> more_idents rem + | Tstr_include{incl_mod={mod_desc = + Tmod_constraint ({mod_desc = Tmod_structure str}, + _, _, _)}} -> + all_idents str.str_items @ more_idents rem + | Tstr_include _ -> more_idents rem + | Tstr_module + {mb_presence=Mp_present; mb_expr={mod_desc = Tmod_structure str}} + | Tstr_module + {mb_presence=Mp_present; + mb_expr={mod_desc= + Tmod_constraint ({mod_desc = Tmod_structure str}, _, _, _)}} -> + all_idents str.str_items @ more_idents rem + | Tstr_module _ -> more_idents rem + | Tstr_attribute _ -> more_idents rem + +and all_idents = function + [] -> [] + | item :: rem -> + match item.str_desc with + | Tstr_eval _ -> all_idents rem + | Tstr_value(_rec_flag, pat_expr_list) -> + let_bound_idents pat_expr_list @ all_idents rem + | Tstr_primitive _ -> all_idents rem + | Tstr_type _ -> all_idents rem + | Tstr_typext tyext -> + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + @ all_idents rem + | Tstr_exception ext -> ext.tyexn_constructor.ext_id :: all_idents rem + | Tstr_recmodule decls -> + List.map (fun mb -> mb.mb_id) decls @ all_idents rem + | Tstr_modtype _ -> all_idents rem + | Tstr_open od -> + let rest = all_idents rem in + begin match od.open_expr.mod_desc with + | Tmod_structure str -> + bound_value_identifiers od.open_bound_items + @ all_idents str.str_items + @ rest + | _ -> bound_value_identifiers od.open_bound_items @ rest + end + | Tstr_class cl_list -> + List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ all_idents rem + | Tstr_class_type _ -> all_idents rem + + | Tstr_include{incl_type; incl_mod={mod_desc = + Tmod_constraint ({mod_desc = Tmod_structure str}, + _, _, _)}} -> + bound_value_identifiers incl_type + @ all_idents str.str_items + @ all_idents rem + | Tstr_include incl -> + bound_value_identifiers incl.incl_type @ all_idents rem + + | Tstr_module + {mb_id;mb_presence=Mp_present;mb_expr={mod_desc = Tmod_structure str}} + | Tstr_module + {mb_id;mb_presence=Mp_present; + mb_expr= + {mod_desc = + Tmod_constraint ({mod_desc = Tmod_structure str}, _, _, _)}} -> + mb_id :: all_idents str.str_items @ all_idents rem + | Tstr_module {mb_id;mb_presence=Mp_present} -> mb_id :: all_idents rem + | Tstr_module {mb_presence=Mp_absent} -> all_idents rem + | Tstr_attribute _ -> all_idents rem + + +(* A variant of transl_structure used to compile toplevel structure definitions + for the native-code compiler. Store the defined values in the fields + of the global as soon as they are defined, in order to reduce register + pressure. Also rewrites the defining expressions so that they + refer to earlier fields of the structure through the fields of + the global, not by their names. + "map" is a table from defined idents to (pos in global block, coercion). + "prim" is a list of (pos in global block, primitive declaration). *) + +let transl_store_subst = ref Ident.Map.empty + (** In the native toplevel, this reference is threaded through successive + calls of transl_store_structure *) + +let nat_toplevel_name id = + try match Ident.Map.find id !transl_store_subst with + | Lprim(Pfield pos, [Lprim(Pgetglobal glob, [], _)], _) -> (glob,pos) + | _ -> raise Not_found + with Not_found -> + fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id) + +let field_of_str loc str = + let ids = Array.of_list (defined_idents str.str_items) in + fun (pos, cc) -> + match cc with + | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } -> + Translprim.transl_primitive pc_loc pc_desc pc_env pc_type None + | Tcoerce_alias (env, path, cc) -> + let lam = transl_module_path loc env path in + apply_coercion loc Alias cc lam + | _ -> apply_coercion loc Strict cc (Lvar ids.(pos)) + + +let transl_store_structure glob map prims aliases str = + let no_env_update _ _ env = env in + let rec transl_store rootpath subst cont = function + [] -> + transl_store_subst := subst; + Lambda.subst no_env_update subst cont + | item :: rem -> + match item.str_desc with + | Tstr_eval (expr, _attrs) -> + Lsequence(Lambda.subst no_env_update subst (transl_exp expr), + transl_store rootpath subst cont rem) + | Tstr_value(rec_flag, pat_expr_list) -> + let ids = let_bound_idents pat_expr_list in + let lam = + transl_let rec_flag pat_expr_list + (store_idents Location.none ids) + in + Lsequence(Lambda.subst no_env_update subst lam, + transl_store rootpath + (add_idents false ids subst) cont rem) + | Tstr_primitive descr -> + record_primitive descr.val_val; + transl_store rootpath subst cont rem + | Tstr_type _ -> + transl_store rootpath subst cont rem + | Tstr_typext(tyext) -> + let ids = + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + in + let lam = + transl_type_extension item.str_env rootpath tyext + (store_idents Location.none ids) + in + Lsequence(Lambda.subst no_env_update subst lam, + transl_store rootpath + (add_idents false ids subst) cont rem) + | Tstr_exception ext -> + let id = ext.tyexn_constructor.ext_id in + let path = field_path rootpath id in + let lam = + transl_extension_constructor item.str_env + path + ext.tyexn_constructor + in + Lsequence(Llet(Strict, Pgenval, id, + Lambda.subst no_env_update subst lam, + store_ident ext.tyexn_constructor.ext_loc id), + transl_store rootpath + (add_ident false id subst) cont rem) + | Tstr_module{mb_id=id;mb_loc=loc;mb_presence=Mp_present; + mb_expr={mod_desc = Tmod_structure str} as mexp; + mb_attributes} -> + List.iter (Translattribute.check_attribute_on_module mexp) + mb_attributes; + let lam = + transl_store (field_path rootpath id) subst + lambda_unit str.str_items + in + (* Careful: see next case *) + let subst = !transl_store_subst in + Lsequence(lam, + Llet(Strict, Pgenval, id, + Lambda.subst no_env_update subst + (Lprim(Pmakeblock(0, Immutable, None), + List.map (fun id -> Lvar id) + (defined_idents str.str_items), loc)), + Lsequence(store_ident loc id, + transl_store rootpath + (add_ident true id subst) + cont rem))) + | Tstr_module{ + mb_id=id;mb_loc=loc;mb_presence=Mp_present; + mb_expr= { + mod_desc = Tmod_constraint ( + {mod_desc = Tmod_structure str} as mexp, _, _, + (Tcoerce_structure (map, _) as _cc))}; + mb_attributes + } -> + (* Format.printf "coerc id %s: %a@." (Ident.unique_name id) + Includemod.print_coercion cc; *) + List.iter (Translattribute.check_attribute_on_module mexp) + mb_attributes; + let lam = + transl_store (field_path rootpath id) subst + lambda_unit str.str_items + in + (* Careful: see next case *) + let subst = !transl_store_subst in + let field = field_of_str loc str in + Lsequence(lam, + Llet(Strict, Pgenval, id, + Lambda.subst no_env_update subst + (Lprim(Pmakeblock(0, Immutable, None), + List.map field map, loc)), + Lsequence(store_ident loc id, + transl_store rootpath + (add_ident true id subst) + cont rem))) + | Tstr_module + {mb_id=id; mb_presence=Mp_present; mb_expr=modl; + mb_loc=loc; mb_attributes} -> + let lam = + Translattribute.add_inline_attribute + (transl_module Tcoerce_none (field_path rootpath id) modl) + loc mb_attributes + in + (* Careful: the module value stored in the global may be different + from the local module value, in case a coercion is applied. + If so, keep using the local module value (id) in the remainder of + the compilation unit (add_ident true returns subst unchanged). + If not, we can use the value from the global + (add_ident true adds id -> Pgetglobal... to subst). *) + Llet(Strict, Pgenval, id, Lambda.subst no_env_update subst lam, + Lsequence(store_ident loc id, + transl_store rootpath (add_ident true id subst) + cont rem)) + | Tstr_module {mb_presence=Mp_absent} -> + transl_store rootpath subst cont rem + | Tstr_recmodule bindings -> + let ids = List.map (fun mb -> mb.mb_id) bindings in + compile_recmodule + (fun id modl _loc -> + Lambda.subst no_env_update subst + (transl_module Tcoerce_none + (field_path rootpath id) modl)) + bindings + (Lsequence(store_idents Location.none ids, + transl_store rootpath (add_idents true ids subst) + cont rem)) + | Tstr_class cl_list -> + let (ids, class_bindings) = transl_class_bindings cl_list in + let lam = + Lletrec(class_bindings, store_idents Location.none ids) + in + Lsequence(Lambda.subst no_env_update subst lam, + transl_store rootpath (add_idents false ids subst) + cont rem) + + | Tstr_include{ + incl_loc=loc; + incl_mod= { + mod_desc = Tmod_constraint ( + ({mod_desc = Tmod_structure str} as mexp), _, _, + (Tcoerce_structure (map, _)))}; + incl_attributes; + incl_type; + } -> + List.iter (Translattribute.check_attribute_on_module mexp) + incl_attributes; + (* Shouldn't we use mod_attributes instead of incl_attributes? + Same question for the Tstr_module cases above, btw. *) + let lam = + transl_store None subst lambda_unit str.str_items + (* It is tempting to pass rootpath instead of None + in order to give a more precise name to exceptions + in the included structured, but this would introduce + a difference of behavior compared to bytecode. *) + in + let subst = !transl_store_subst in + let field = field_of_str loc str in + let ids0 = bound_value_identifiers incl_type in + let rec loop ids args = + match ids, args with + | [], [] -> + transl_store rootpath (add_idents true ids0 subst) + cont rem + | id :: ids, arg :: args -> + Llet(Alias, Pgenval, id, + Lambda.subst no_env_update subst (field arg), + Lsequence(store_ident loc id, + loop ids args)) + | _ -> assert false + in + Lsequence(lam, loop ids0 map) + + + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in + let mid = Ident.create_local "include" in + let loc = incl.incl_loc in + let rec store_idents pos = function + | [] -> + transl_store rootpath (add_idents true ids subst) cont rem + | id :: idl -> + Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid], loc), + Lsequence(store_ident loc id, + store_idents (pos + 1) idl)) + in + Llet(Strict, Pgenval, mid, + Lambda.subst no_env_update subst + (transl_module Tcoerce_none None modl), + store_idents 0 ids) + | Tstr_open od -> + begin match od.open_expr.mod_desc with + | Tmod_structure str -> + let lam = + transl_store rootpath subst lambda_unit str.str_items + in + let ids = Array.of_list (defined_idents str.str_items) in + let ids0 = bound_value_identifiers od.open_bound_items in + let subst = !transl_store_subst in + let rec store_idents pos = function + | [] -> + transl_store rootpath (add_idents true ids0 subst) cont rem + | id :: idl -> + Llet(Alias, Pgenval, id, Lvar ids.(pos), + Lsequence(store_ident od.open_loc id, + store_idents (pos + 1) idl)) + in + Lsequence(lam, Lambda.subst no_env_update subst + (store_idents 0 ids0)) + | _ -> + let pure = pure_module od.open_expr in + (* this optimization shouldn't be needed because Simplif would + actually remove the [Llet] when it's not used. + But since [scan_used_globals] runs before Simplif, we need to + do it. *) + match od.open_bound_items with + | [] when pure = Alias -> transl_store rootpath subst cont rem + | _ -> + let ids = bound_value_identifiers od.open_bound_items in + let mid = Ident.create_local "open" in + let loc = od.open_loc in + let rec store_idents pos = function + [] -> + transl_store rootpath (add_idents true ids subst) cont + rem + | id :: idl -> + Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid], + loc), + Lsequence(store_ident loc id, + store_idents (pos + 1) idl)) + in + Llet(pure, Pgenval, mid, + Lambda.subst no_env_update subst + (transl_module Tcoerce_none None od.open_expr), + store_idents 0 ids) + end + | Tstr_modtype _ + | Tstr_class_type _ + | Tstr_attribute _ -> + transl_store rootpath subst cont rem + + and store_ident loc id = + try + let (pos, cc) = Ident.find_same id map in + let init_val = apply_coercion loc Alias cc (Lvar id) in + Lprim(Psetfield(pos, Pointer, Root_initialization), + [Lprim(Pgetglobal glob, [], loc); init_val], + loc) + with Not_found -> + fatal_error("Translmod.store_ident: " ^ Ident.unique_name id) + + and store_idents loc idlist = + make_sequence (store_ident loc) idlist + + and add_ident may_coerce id subst = + try + let (pos, cc) = Ident.find_same id map in + match cc with + Tcoerce_none -> + Ident.Map.add id + (Lprim(Pfield pos, + [Lprim(Pgetglobal glob, [], Location.none)], + Location.none)) + subst + | _ -> + if may_coerce then subst else assert false + with Not_found -> + assert false + + and add_idents may_coerce idlist subst = + List.fold_right (add_ident may_coerce) idlist subst + + and store_primitive (pos, prim) cont = + Lsequence(Lprim(Psetfield(pos, Pointer, Root_initialization), + [Lprim(Pgetglobal glob, [], Location.none); + Translprim.transl_primitive Location.none + prim.pc_desc prim.pc_env prim.pc_type None], + Location.none), + cont) + + and store_alias (pos, env, path, cc) = + let path_lam = transl_module_path Location.none env path in + let init_val = apply_coercion Location.none Strict cc path_lam in + Lprim(Psetfield(pos, Pointer, Root_initialization), + [Lprim(Pgetglobal glob, [], Location.none); + init_val], + Location.none) + in + let aliases = make_sequence store_alias aliases in + List.fold_right store_primitive prims + (transl_store (global_path glob) !transl_store_subst aliases str) + +(* Transform a coercion and the list of value identifiers defined by + a toplevel structure into a table [id -> (pos, coercion)], + with [pos] being the position in the global block where the value of + [id] must be stored, and [coercion] the coercion to be applied to it. + A given identifier may appear several times + in the coercion (if it occurs several times in the signature); remember + to assign it the position of its last occurrence. + Identifiers that are not exported are assigned positions at the + end of the block (beyond the positions of all exported idents). + Also compute the total size of the global block, + and the list of all primitives exported as values. *) + +let build_ident_map restr idlist more_ids = + let rec natural_map pos map prims aliases = function + | [] -> + (map, prims, aliases, pos) + | id :: rem -> + natural_map (pos+1) + (Ident.add id (pos, Tcoerce_none) map) prims aliases rem + in + let (map, prims, aliases, pos) = + match restr with + | Tcoerce_none -> + natural_map 0 Ident.empty [] [] idlist + | Tcoerce_structure (pos_cc_list, _id_pos_list) -> + (* ignore _id_pos_list as the ids are already bound *) + let idarray = Array.of_list idlist in + let rec export_map pos map prims aliases undef = function + | [] -> + natural_map pos map prims aliases undef + | (_source_pos, Tcoerce_primitive p) :: rem -> + export_map (pos + 1) map + ((pos, p) :: prims) aliases undef rem + | (_source_pos, Tcoerce_alias(env, path, cc)) :: rem -> + export_map (pos + 1) map prims + ((pos, env, path, cc) :: aliases) undef rem + | (source_pos, cc) :: rem -> + let id = idarray.(source_pos) in + export_map (pos + 1) (Ident.add id (pos, cc) map) + prims aliases (list_remove id undef) rem + in + export_map 0 Ident.empty [] [] idlist pos_cc_list + | _ -> + fatal_error "Translmod.build_ident_map" + in + natural_map pos map prims aliases more_ids + +(* Compile an implementation using transl_store_structure + (for the native-code compiler). *) + +let transl_store_gen module_name ({ str_items = str }, restr) topl = + reset_labels (); + primitive_declarations := []; + Translprim.clear_used_primitives (); + let module_id = Ident.create_persistent module_name in + let (map, prims, aliases, size) = + build_ident_map restr (defined_idents str) (more_idents str) in + let f = function + | [ { str_desc = Tstr_eval (expr, _attrs) } ] when topl -> + assert (size = 0); + Lambda.subst (fun _ _ env -> env) !transl_store_subst (transl_exp expr) + | str -> transl_store_structure module_id map prims aliases str + in + transl_store_label_init module_id size f str + (*size, transl_label_init (transl_store_structure module_id map prims str)*) + +let transl_store_phrases module_name str = + transl_store_gen module_name (str,Tcoerce_none) true + +let transl_store_implementation module_name (str, restr) = + let s = !transl_store_subst in + transl_store_subst := Ident.Map.empty; + let (i, code) = transl_store_gen module_name (str, restr) false in + transl_store_subst := s; + { Lambda.main_module_block_size = i; + code; + (* module_ident is not used by closure, but this allow to share + the type with the flambda version *) + module_ident = Ident.create_persistent module_name; + required_globals = required_globals ~flambda:true code } + +(* Compile a toplevel phrase *) + +let toploop_ident = Ident.create_persistent "Toploop" +let toploop_getvalue_pos = 0 (* position of getvalue in module Toploop *) +let toploop_setvalue_pos = 1 (* position of setvalue in module Toploop *) + +let aliased_idents = ref Ident.empty + +let set_toplevel_unique_name id = + aliased_idents := + Ident.add id (Ident.unique_toplevel_name id) !aliased_idents + +let toplevel_name id = + try Ident.find_same id !aliased_idents + with Not_found -> Ident.name id + +let toploop_getvalue id = + Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=Lprim(Pfield toploop_getvalue_pos, + [Lprim(Pgetglobal toploop_ident, [], Location.none)], + Location.none); + ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)))]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} + +let toploop_setvalue id lam = + Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=Lprim(Pfield toploop_setvalue_pos, + [Lprim(Pgetglobal toploop_ident, [], Location.none)], + Location.none); + ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None))); + lam]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} + +let toploop_setvalue_id id = toploop_setvalue id (Lvar id) + +let close_toplevel_term (lam, ()) = + Ident.Set.fold (fun id l -> Llet(Strict, Pgenval, id, + toploop_getvalue id, l)) + (free_variables lam) lam + +let transl_toplevel_item item = + match item.str_desc with + Tstr_eval (expr, _) + | Tstr_value(Nonrecursive, + [{vb_pat = {pat_desc=Tpat_any};vb_expr = expr}]) -> + (* special compilation for toplevel "let _ = expr", so + that Toploop can display the result of the expression. + Otherwise, the normal compilation would result + in a Lsequence returning unit. *) + transl_exp expr + | Tstr_value(rec_flag, pat_expr_list) -> + let idents = let_bound_idents pat_expr_list in + transl_let rec_flag pat_expr_list + (make_sequence toploop_setvalue_id idents) + | Tstr_typext(tyext) -> + let idents = + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + in + (* we need to use unique name in case of multiple + definitions of the same extension constructor in the toplevel *) + List.iter set_toplevel_unique_name idents; + transl_type_extension item.str_env None tyext + (make_sequence toploop_setvalue_id idents) + | Tstr_exception ext -> + set_toplevel_unique_name ext.tyexn_constructor.ext_id; + toploop_setvalue ext.tyexn_constructor.ext_id + (transl_extension_constructor item.str_env None ext.tyexn_constructor) + | Tstr_module {mb_id=id; mb_presence=Mp_present; mb_expr=modl} -> + (* we need to use the unique name for the module because of issues + with "open" (PR#8133) *) + set_toplevel_unique_name id; + let lam = transl_module Tcoerce_none (Some(Pident id)) modl in + toploop_setvalue id lam + | Tstr_recmodule bindings -> + let idents = List.map (fun mb -> mb.mb_id) bindings in + compile_recmodule + (fun id modl _loc -> transl_module Tcoerce_none (Some(Pident id)) modl) + bindings + (make_sequence toploop_setvalue_id idents) + | Tstr_class cl_list -> + (* we need to use unique names for the classes because there might + be a value named identically *) + let (ids, class_bindings) = transl_class_bindings cl_list in + List.iter set_toplevel_unique_name ids; + Lletrec(class_bindings, make_sequence toploop_setvalue_id ids) + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in + let mid = Ident.create_local "include" in + let rec set_idents pos = function + [] -> + lambda_unit + | id :: ids -> + Lsequence(toploop_setvalue id + (Lprim(Pfield pos, [Lvar mid], Location.none)), + set_idents (pos + 1) ids) in + Llet(Strict, Pgenval, mid, + transl_module Tcoerce_none None modl, set_idents 0 ids) + | Tstr_primitive descr -> + record_primitive descr.val_val; + lambda_unit + | Tstr_open od -> + let pure = pure_module od.open_expr in + (* this optimization shouldn't be needed because Simplif would + actually remove the [Llet] when it's not used. + But since [scan_used_globals] runs before Simplif, we need to do + it. *) + begin match od.open_bound_items with + | [] when pure = Alias -> lambda_unit + | _ -> + let ids = bound_value_identifiers od.open_bound_items in + let mid = Ident.create_local "open" in + let rec set_idents pos = function + [] -> + lambda_unit + | id :: ids -> + Lsequence(toploop_setvalue id + (Lprim(Pfield pos, [Lvar mid], Location.none)), + set_idents (pos + 1) ids) + in + Llet(pure, Pgenval, mid, + transl_module Tcoerce_none None od.open_expr, set_idents 0 ids) + end + | Tstr_modtype _ + | Tstr_module {mb_presence=Mp_absent} + | Tstr_type _ + | Tstr_class_type _ + | Tstr_attribute _ -> + lambda_unit + +let transl_toplevel_item_and_close itm = + close_toplevel_term + (transl_label_init (fun () -> transl_toplevel_item itm, ())) + +let transl_toplevel_definition str = + reset_labels (); + Translprim.clear_used_primitives (); + make_sequence transl_toplevel_item_and_close str.str_items + +(* Compile the initialization code for a packed library *) + +let get_component = function + None -> Lconst const_unit + | Some id -> Lprim(Pgetglobal id, [], Location.none) + +let transl_package_flambda component_names coercion = + let size = + match coercion with + | Tcoerce_none -> List.length component_names + | Tcoerce_structure (l, _) -> List.length l + | Tcoerce_functor _ + | Tcoerce_primitive _ + | Tcoerce_alias _ -> assert false + in + size, + apply_coercion Location.none Strict coercion + (Lprim(Pmakeblock(0, Immutable, None), + List.map get_component component_names, + Location.none)) + +let transl_package component_names target_name coercion = + let components = + Lprim(Pmakeblock(0, Immutable, None), + List.map get_component component_names, Location.none) in + Lprim(Psetglobal target_name, + [apply_coercion Location.none Strict coercion components], + Location.none) + (* + let components = + match coercion with + Tcoerce_none -> + List.map get_component component_names + | Tcoerce_structure (pos_cc_list, id_pos_list) -> + (* ignore id_pos_list as the ids are already bound *) + let g = Array.of_list component_names in + List.map + (fun (pos, cc) -> apply_coercion Strict cc (get_component g.(pos))) + pos_cc_list + | _ -> + assert false in + Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)]) + *) + +let transl_store_package component_names target_name coercion = + let rec make_sequence fn pos arg = + match arg with + [] -> lambda_unit + | hd :: tl -> Lsequence(fn pos hd, make_sequence fn (pos + 1) tl) in + match coercion with + Tcoerce_none -> + (List.length component_names, + make_sequence + (fun pos id -> + Lprim(Psetfield(pos, Pointer, Root_initialization), + [Lprim(Pgetglobal target_name, [], Location.none); + get_component id], + Location.none)) + 0 component_names) + | Tcoerce_structure (pos_cc_list, _id_pos_list) -> + let components = + Lprim(Pmakeblock(0, Immutable, None), + List.map get_component component_names, + Location.none) + in + let blk = Ident.create_local "block" in + (List.length pos_cc_list, + Llet (Strict, Pgenval, blk, + apply_coercion Location.none Strict coercion components, + make_sequence + (fun pos _id -> + Lprim(Psetfield(pos, Pointer, Root_initialization), + [Lprim(Pgetglobal target_name, [], Location.none); + Lprim(Pfield pos, [Lvar blk], Location.none)], + Location.none)) + 0 pos_cc_list)) + (* + (* ignore id_pos_list as the ids are already bound *) + let id = Array.of_list component_names in + (List.length pos_cc_list, + make_sequence + (fun dst (src, cc) -> + Lprim(Psetfield(dst, false), + [Lprim(Pgetglobal target_name, []); + apply_coercion Strict cc (get_component id.(src))])) + 0 pos_cc_list) + *) + | _ -> assert false + +(* Error report *) + +open Format + +let print_cycle ppf cycle = + let print_ident ppf (x,_) = Format.pp_print_string ppf (Ident.name x) in + let pp_sep ppf () = fprintf ppf "@ -> " in + Format.fprintf ppf "%a%a%s" + (Format.pp_print_list ~pp_sep print_ident) cycle + pp_sep () + (Ident.name @@ fst @@ List.hd cycle) +(* we repeat the first element to make the cycle more apparent *) + +let explanation_submsg (id, {reason;loc;subid}) = + let print fmt = + let printer = Format.dprintf fmt (Ident.name id) (Ident.name subid) in + Location.mkloc printer loc in + match reason with + | Unsafe_module_binding -> print "Module %s defines an unsafe module, %s ." + | Unsafe_functor -> print "Module %s defines an unsafe functor, %s ." + | Unsafe_typext -> + print "Module %s defines an unsafe extension constructor, %s ." + | Unsafe_non_function -> print "Module %s defines an unsafe value, %s ." + +let report_error loc = function + | Circular_dependency cycle -> + let[@manual.ref "s-recursive-modules"] chapter, section = 8, 2 in + Location.errorf ~loc ~sub:(List.map explanation_submsg cycle) + "Cannot safely evaluate the definition of the following cycle@ \ + of recursively-defined modules:@ %a.@ \ + There are no safe modules in this cycle@ (see manual section %d.%d)." + print_cycle cycle chapter section + | Conflicting_inline_attributes -> + Location.errorf "@[Conflicting 'inline' attributes@]" + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> Some (report_error loc err) + | _ -> + None + ) + +let reset () = + primitive_declarations := []; + transl_store_subst := Ident.Map.empty; + aliased_idents := Ident.empty; + Env.reset_required_globals (); + Translprim.clear_used_primitives () diff --git a/lambda/translmod.mli b/lambda/translmod.mli new file mode 100644 index 00000000..d0898c76 --- /dev/null +++ b/lambda/translmod.mli @@ -0,0 +1,61 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Translation from typed abstract syntax to lambda terms, + for the module language *) + +open Typedtree +open Lambda + +val transl_implementation: + string -> structure * module_coercion -> Lambda.program +val transl_store_phrases: string -> structure -> int * lambda +val transl_store_implementation: + string -> structure * module_coercion -> Lambda.program + +val transl_implementation_flambda: + string -> structure * module_coercion -> Lambda.program + +val transl_toplevel_definition: structure -> lambda +val transl_package: + Ident.t option list -> Ident.t -> module_coercion -> lambda +val transl_store_package: + Ident.t option list -> Ident.t -> module_coercion -> int * lambda + +val transl_package_flambda: + Ident.t option list -> module_coercion -> int * lambda + +val toplevel_name: Ident.t -> string +val nat_toplevel_name: Ident.t -> Ident.t * int + +val primitive_declarations: Primitive.description list ref + +type unsafe_component = + | Unsafe_module_binding + | Unsafe_functor + | Unsafe_non_function + | Unsafe_typext + +type unsafe_info = { reason:unsafe_component; loc:Location.t; subid:Ident.t } + +type error = + Circular_dependency of (Ident.t * unsafe_info) list +| Conflicting_inline_attributes + +exception Error of Location.t * error + +val report_error: Location.t -> error -> Location.error + +val reset: unit -> unit diff --git a/lambda/translobj.ml b/lambda/translobj.ml new file mode 100644 index 00000000..ce063538 --- /dev/null +++ b/lambda/translobj.ml @@ -0,0 +1,199 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Lambda + +(* Get oo primitives identifiers *) + +let oo_prim = Lambda.transl_prim "CamlinternalOO" + +(* Share blocks *) + +let consts : (structured_constant, Ident.t) Hashtbl.t = Hashtbl.create 17 + +let share c = + match c with + Const_block (_n, l) when l <> [] -> + begin try + Lvar (Hashtbl.find consts c) + with Not_found -> + let id = Ident.create_local "shared" in + Hashtbl.add consts c id; + Lvar id + end + | _ -> Lconst c + +(* Collect labels *) + +let cache_required = ref false +let method_cache = ref lambda_unit +let method_count = ref 0 +let method_table = ref [] + +let meth_tag s = Lconst(Const_base(Const_int(Btype.hash_variant s))) + +let next_cache tag = + let n = !method_count in + incr method_count; + (tag, [!method_cache; Lconst(Const_base(Const_int n))]) + +let rec is_path = function + Lvar _ | Lprim (Pgetglobal _, [], _) | Lconst _ -> true + | Lprim (Pfield _, [lam], _) -> is_path lam + | Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2], _) -> + is_path lam1 && is_path lam2 + | _ -> false + +let meth obj lab = + let tag = meth_tag lab in + if not (!cache_required && !Clflags.native_code) then (tag, []) else + if not (is_path obj) then next_cache tag else + try + let r = List.assoc obj !method_table in + try + (tag, List.assoc tag !r) + with Not_found -> + let p = next_cache tag in + r := p :: !r; + p + with Not_found -> + let p = next_cache tag in + method_table := (obj, ref [p]) :: !method_table; + p + +let reset_labels () = + Hashtbl.clear consts; + method_count := 0; + method_table := [] + +(* Insert labels *) + +let int n = Lconst (Const_base (Const_int n)) + +let prim_makearray = + Primitive.simple ~name:"caml_make_vect" ~arity:2 ~alloc:true + +(* Also use it for required globals *) +let transl_label_init_general f = + let expr, size = f () in + let expr = + Hashtbl.fold + (fun c id expr -> Llet(Alias, Pgenval, id, Lconst c, expr)) + consts expr + in + (*let expr = + List.fold_right + (fun id expr -> Lsequence(Lprim(Pgetglobal id, [], Location.none), expr)) + (Env.get_required_globals ()) expr + in + Env.reset_required_globals ();*) + reset_labels (); + expr, size + +let transl_label_init_flambda f = + assert(Config.flambda); + let method_cache_id = Ident.create_local "method_cache" in + method_cache := Lvar method_cache_id; + (* Calling f (usually Translmod.transl_struct) requires the + method_cache variable to be initialised to be able to generate + method accesses. *) + let expr, size = f () in + let expr = + if !method_count = 0 then expr + else + Llet (Strict, Pgenval, method_cache_id, + Lprim (Pccall prim_makearray, + [int !method_count; int 0], + Location.none), + expr) + in + transl_label_init_general (fun () -> expr, size) + +let transl_store_label_init glob size f arg = + assert(not Config.flambda); + assert(!Clflags.native_code); + method_cache := Lprim(Pfield size, + [Lprim(Pgetglobal glob, [], Location.none)], + Location.none); + let expr = f arg in + let (size, expr) = + if !method_count = 0 then (size, expr) else + (size+1, + Lsequence( + Lprim(Psetfield(size, Pointer, Root_initialization), + [Lprim(Pgetglobal glob, [], Location.none); + Lprim (Pccall prim_makearray, + [int !method_count; int 0], + Location.none)], + Location.none), + expr)) + in + let lam, size = transl_label_init_general (fun () -> (expr, size)) in + size, lam + +let transl_label_init f = + if !Clflags.native_code then + transl_label_init_flambda f + else + transl_label_init_general f + +(* Share classes *) + +let wrapping = ref false +let top_env = ref Env.empty +let classes = ref [] +let method_ids = ref Ident.Set.empty + +let oo_add_class id = + classes := id :: !classes; + (!top_env, !cache_required) + +let oo_wrap env req f x = + if !wrapping then + if !cache_required then f x else + Misc.protect_refs [Misc.R (cache_required, true)] (fun () -> + f x + ) + else + Misc.protect_refs [Misc.R (wrapping, true); Misc.R (top_env, env)] + (fun () -> + cache_required := req; + classes := []; + method_ids := Ident.Set.empty; + let lambda = f x in + let lambda = + List.fold_left + (fun lambda id -> + Llet(StrictOpt, Pgenval, id, + Lprim(Pmakeblock(0, Mutable, None), + [lambda_unit; lambda_unit; lambda_unit], + Location.none), + lambda)) + lambda !classes + in + lambda + ) + +let reset () = + Hashtbl.clear consts; + cache_required := false; + method_cache := lambda_unit; + method_count := 0; + method_table := []; + wrapping := false; + top_env := Env.empty; + classes := []; + method_ids := Ident.Set.empty diff --git a/lambda/translobj.mli b/lambda/translobj.mli new file mode 100644 index 00000000..c27053e9 --- /dev/null +++ b/lambda/translobj.mli @@ -0,0 +1,33 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Lambda + +val oo_prim: string -> lambda + +val share: structured_constant -> lambda +val meth: lambda -> string -> lambda * lambda list + +val reset_labels: unit -> unit +val transl_label_init: (unit -> lambda * 'a) -> lambda * 'a +val transl_store_label_init: + Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda + +val method_ids: Ident.Set.t ref (* reset when starting a new wrapper *) + +val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda +val oo_add_class: Ident.t -> Env.t * bool + +val reset: unit -> unit diff --git a/lambda/translprim.ml b/lambda/translprim.ml new file mode 100644 index 00000000..d56002b7 --- /dev/null +++ b/lambda/translprim.ml @@ -0,0 +1,811 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Translation of primitives *) + +open Misc +open Asttypes +open Primitive +open Types +open Typedtree +open Typeopt +open Lambda + +type error = + | Unknown_builtin_primitive of string + | Wrong_arity_builtin_primitive of string + +exception Error of Location.t * error + +(* Insertion of debugging events *) + +let event_before exp lam = match lam with +| Lstaticraise (_,_) -> lam +| _ -> + if !Clflags.debug && not !Clflags.native_code + then Levent(lam, {lev_loc = exp.exp_loc; + lev_kind = Lev_before; + lev_repr = None; + lev_env = exp.exp_env}) + else lam + +let event_after exp lam = + if !Clflags.debug && not !Clflags.native_code + then Levent(lam, {lev_loc = exp.exp_loc; + lev_kind = Lev_after exp.exp_type; + lev_repr = None; + lev_env = exp.exp_env}) + else lam + +type comparison = + | Equal + | Not_equal + | Less_equal + | Less_than + | Greater_equal + | Greater_than + | Compare + +type comparison_kind = + | Compare_generic + | Compare_ints + | Compare_floats + | Compare_strings + | Compare_bytes + | Compare_nativeints + | Compare_int32s + | Compare_int64s + +type loc_kind = + | Loc_FILE + | Loc_LINE + | Loc_MODULE + | Loc_LOC + | Loc_POS + +type prim = + | Primitive of Lambda.primitive * int + | External of Primitive.description + | Comparison of comparison * comparison_kind + | Raise of Lambda.raise_kind + | Raise_with_backtrace + | Lazy_force + | Loc of loc_kind + | Send + | Send_self + | Send_cache + +let used_primitives = Hashtbl.create 7 +let add_used_primitive loc env path = + match path with + Some (Path.Pdot _ as path) -> + let path = Env.normalize_path_prefix (Some loc) env path in + let unit = Path.head path in + if Ident.global unit && not (Hashtbl.mem used_primitives path) + then Hashtbl.add used_primitives path loc + | _ -> () + +let clear_used_primitives () = Hashtbl.clear used_primitives +let get_used_primitives () = + Hashtbl.fold (fun path _ acc -> path :: acc) used_primitives [] + +let gen_array_kind = + if Config.flat_float_array then Pgenarray else Paddrarray + +let prim_sys_argv = + Primitive.simple ~name:"caml_sys_argv" ~arity:1 ~alloc:true + +let primitives_table = + create_hashtable 57 [ + "%identity", Primitive (Pidentity, 1); + "%bytes_to_string", Primitive (Pbytes_to_string, 1); + "%bytes_of_string", Primitive (Pbytes_of_string, 1); + "%ignore", Primitive (Pignore, 1); + "%revapply", Primitive (Prevapply, 2); + "%apply", Primitive (Pdirapply, 2); + "%loc_LOC", Loc Loc_LOC; + "%loc_FILE", Loc Loc_FILE; + "%loc_LINE", Loc Loc_LINE; + "%loc_POS", Loc Loc_POS; + "%loc_MODULE", Loc Loc_MODULE; + "%field0", Primitive ((Pfield 0), 1); + "%field1", Primitive ((Pfield 1), 1); + "%setfield0", Primitive ((Psetfield(0, Pointer, Assignment)), 2); + "%makeblock", Primitive ((Pmakeblock(0, Immutable, None)), 1); + "%makemutable", Primitive ((Pmakeblock(0, Mutable, None)), 1); + "%raise", Raise Raise_regular; + "%reraise", Raise Raise_reraise; + "%raise_notrace", Raise Raise_notrace; + "%raise_with_backtrace", Raise_with_backtrace; + "%sequand", Primitive (Psequand, 2); + "%sequor", Primitive (Psequor, 2); + "%boolnot", Primitive (Pnot, 1); + "%big_endian", Primitive ((Pctconst Big_endian), 1); + "%backend_type", Primitive ((Pctconst Backend_type), 1); + "%word_size", Primitive ((Pctconst Word_size), 1); + "%int_size", Primitive ((Pctconst Int_size), 1); + "%max_wosize", Primitive ((Pctconst Max_wosize), 1); + "%ostype_unix", Primitive ((Pctconst Ostype_unix), 1); + "%ostype_win32", Primitive ((Pctconst Ostype_win32), 1); + "%ostype_cygwin", Primitive ((Pctconst Ostype_cygwin), 1); + "%negint", Primitive (Pnegint, 1); + "%succint", Primitive ((Poffsetint 1), 1); + "%predint", Primitive ((Poffsetint(-1)), 1); + "%addint", Primitive (Paddint, 2); + "%subint", Primitive (Psubint, 2); + "%mulint", Primitive (Pmulint, 2); + "%divint", Primitive ((Pdivint Safe), 2); + "%modint", Primitive ((Pmodint Safe), 2); + "%andint", Primitive (Pandint, 2); + "%orint", Primitive (Porint, 2); + "%xorint", Primitive (Pxorint, 2); + "%lslint", Primitive (Plslint, 2); + "%lsrint", Primitive (Plsrint, 2); + "%asrint", Primitive (Pasrint, 2); + "%eq", Primitive ((Pintcomp Ceq), 2); + "%noteq", Primitive ((Pintcomp Cne), 2); + "%ltint", Primitive ((Pintcomp Clt), 2); + "%leint", Primitive ((Pintcomp Cle), 2); + "%gtint", Primitive ((Pintcomp Cgt), 2); + "%geint", Primitive ((Pintcomp Cge), 2); + "%incr", Primitive ((Poffsetref(1)), 1); + "%decr", Primitive ((Poffsetref(-1)), 1); + "%intoffloat", Primitive (Pintoffloat, 1); + "%floatofint", Primitive (Pfloatofint, 1); + "%negfloat", Primitive (Pnegfloat, 1); + "%absfloat", Primitive (Pabsfloat, 1); + "%addfloat", Primitive (Paddfloat, 2); + "%subfloat", Primitive (Psubfloat, 2); + "%mulfloat", Primitive (Pmulfloat, 2); + "%divfloat", Primitive (Pdivfloat, 2); + "%eqfloat", Primitive ((Pfloatcomp CFeq), 2); + "%noteqfloat", Primitive ((Pfloatcomp CFneq), 2); + "%ltfloat", Primitive ((Pfloatcomp CFlt), 2); + "%lefloat", Primitive ((Pfloatcomp CFle), 2); + "%gtfloat", Primitive ((Pfloatcomp CFgt), 2); + "%gefloat", Primitive ((Pfloatcomp CFge), 2); + "%string_length", Primitive (Pstringlength, 1); + "%string_safe_get", Primitive (Pstringrefs, 2); + "%string_safe_set", Primitive (Pbytessets, 3); + "%string_unsafe_get", Primitive (Pstringrefu, 2); + "%string_unsafe_set", Primitive (Pbytessetu, 3); + "%bytes_length", Primitive (Pbyteslength, 1); + "%bytes_safe_get", Primitive (Pbytesrefs, 2); + "%bytes_safe_set", Primitive (Pbytessets, 3); + "%bytes_unsafe_get", Primitive (Pbytesrefu, 2); + "%bytes_unsafe_set", Primitive (Pbytessetu, 3); + "%array_length", Primitive ((Parraylength gen_array_kind), 1); + "%array_safe_get", Primitive ((Parrayrefs gen_array_kind), 2); + "%array_safe_set", Primitive ((Parraysets gen_array_kind), 3); + "%array_unsafe_get", Primitive ((Parrayrefu gen_array_kind), 2); + "%array_unsafe_set", Primitive ((Parraysetu gen_array_kind), 3); + "%obj_size", Primitive ((Parraylength gen_array_kind), 1); + "%obj_field", Primitive ((Parrayrefu gen_array_kind), 2); + "%obj_set_field", Primitive ((Parraysetu gen_array_kind), 3); + "%floatarray_length", Primitive ((Parraylength Pfloatarray), 1); + "%floatarray_safe_get", Primitive ((Parrayrefs Pfloatarray), 2); + "%floatarray_safe_set", Primitive ((Parraysets Pfloatarray), 3); + "%floatarray_unsafe_get", Primitive ((Parrayrefu Pfloatarray), 2); + "%floatarray_unsafe_set", Primitive ((Parraysetu Pfloatarray), 3); + "%obj_is_int", Primitive (Pisint, 1); + "%lazy_force", Lazy_force; + "%nativeint_of_int", Primitive ((Pbintofint Pnativeint), 1); + "%nativeint_to_int", Primitive ((Pintofbint Pnativeint), 1); + "%nativeint_neg", Primitive ((Pnegbint Pnativeint), 1); + "%nativeint_add", Primitive ((Paddbint Pnativeint), 2); + "%nativeint_sub", Primitive ((Psubbint Pnativeint), 2); + "%nativeint_mul", Primitive ((Pmulbint Pnativeint), 2); + "%nativeint_div", + Primitive ((Pdivbint { size = Pnativeint; is_safe = Safe }), 2); + "%nativeint_mod", + Primitive ((Pmodbint { size = Pnativeint; is_safe = Safe }), 2); + "%nativeint_and", Primitive ((Pandbint Pnativeint), 2); + "%nativeint_or", Primitive ( (Porbint Pnativeint), 2); + "%nativeint_xor", Primitive ((Pxorbint Pnativeint), 2); + "%nativeint_lsl", Primitive ((Plslbint Pnativeint), 2); + "%nativeint_lsr", Primitive ((Plsrbint Pnativeint), 2); + "%nativeint_asr", Primitive ((Pasrbint Pnativeint), 2); + "%int32_of_int", Primitive ((Pbintofint Pint32), 1); + "%int32_to_int", Primitive ((Pintofbint Pint32), 1); + "%int32_neg", Primitive ((Pnegbint Pint32), 1); + "%int32_add", Primitive ((Paddbint Pint32), 2); + "%int32_sub", Primitive ((Psubbint Pint32), 2); + "%int32_mul", Primitive ((Pmulbint Pint32), 2); + "%int32_div", Primitive ((Pdivbint { size = Pint32; is_safe = Safe }), 2); + "%int32_mod", Primitive ((Pmodbint { size = Pint32; is_safe = Safe }), 2); + "%int32_and", Primitive ((Pandbint Pint32), 2); + "%int32_or", Primitive ( (Porbint Pint32), 2); + "%int32_xor", Primitive ((Pxorbint Pint32), 2); + "%int32_lsl", Primitive ((Plslbint Pint32), 2); + "%int32_lsr", Primitive ((Plsrbint Pint32), 2); + "%int32_asr", Primitive ((Pasrbint Pint32), 2); + "%int64_of_int", Primitive ((Pbintofint Pint64), 1); + "%int64_to_int", Primitive ((Pintofbint Pint64), 1); + "%int64_neg", Primitive ((Pnegbint Pint64), 1); + "%int64_add", Primitive ((Paddbint Pint64), 2); + "%int64_sub", Primitive ((Psubbint Pint64), 2); + "%int64_mul", Primitive ((Pmulbint Pint64), 2); + "%int64_div", Primitive ((Pdivbint { size = Pint64; is_safe = Safe }), 2); + "%int64_mod", Primitive ((Pmodbint { size = Pint64; is_safe = Safe }), 2); + "%int64_and", Primitive ((Pandbint Pint64), 2); + "%int64_or", Primitive ( (Porbint Pint64), 2); + "%int64_xor", Primitive ((Pxorbint Pint64), 2); + "%int64_lsl", Primitive ((Plslbint Pint64), 2); + "%int64_lsr", Primitive ((Plsrbint Pint64), 2); + "%int64_asr", Primitive ((Pasrbint Pint64), 2); + "%nativeint_of_int32", Primitive ((Pcvtbint(Pint32, Pnativeint)), 1); + "%nativeint_to_int32", Primitive ((Pcvtbint(Pnativeint, Pint32)), 1); + "%int64_of_int32", Primitive ((Pcvtbint(Pint32, Pint64)), 1); + "%int64_to_int32", Primitive ((Pcvtbint(Pint64, Pint32)), 1); + "%int64_of_nativeint", Primitive ((Pcvtbint(Pnativeint, Pint64)), 1); + "%int64_to_nativeint", Primitive ((Pcvtbint(Pint64, Pnativeint)), 1); + "%caml_ba_ref_1", + Primitive + ((Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), + 2); + "%caml_ba_ref_2", + Primitive + ((Pbigarrayref(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), + 3); + "%caml_ba_ref_3", + Primitive + ((Pbigarrayref(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), + 4); + "%caml_ba_set_1", + Primitive + ((Pbigarrayset(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), + 3); + "%caml_ba_set_2", + Primitive + ((Pbigarrayset(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), + 4); + "%caml_ba_set_3", + Primitive + ((Pbigarrayset(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), + 5); + "%caml_ba_unsafe_ref_1", + Primitive + ((Pbigarrayref(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), + 2); + "%caml_ba_unsafe_ref_2", + Primitive + ((Pbigarrayref(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), + 3); + "%caml_ba_unsafe_ref_3", + Primitive + ((Pbigarrayref(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), + 4); + "%caml_ba_unsafe_set_1", + Primitive + ((Pbigarrayset(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), + 3); + "%caml_ba_unsafe_set_2", + Primitive + ((Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), + 4); + "%caml_ba_unsafe_set_3", + Primitive + ((Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), + 5); + "%caml_ba_dim_1", Primitive ((Pbigarraydim(1)), 1); + "%caml_ba_dim_2", Primitive ((Pbigarraydim(2)), 1); + "%caml_ba_dim_3", Primitive ((Pbigarraydim(3)), 1); + "%caml_string_get16", Primitive ((Pstring_load_16(false)), 2); + "%caml_string_get16u", Primitive ((Pstring_load_16(true)), 2); + "%caml_string_get32", Primitive ((Pstring_load_32(false)), 2); + "%caml_string_get32u", Primitive ((Pstring_load_32(true)), 2); + "%caml_string_get64", Primitive ((Pstring_load_64(false)), 2); + "%caml_string_get64u", Primitive ((Pstring_load_64(true)), 2); + "%caml_string_set16", Primitive ((Pbytes_set_16(false)), 3); + "%caml_string_set16u", Primitive ((Pbytes_set_16(true)), 3); + "%caml_string_set32", Primitive ((Pbytes_set_32(false)), 3); + "%caml_string_set32u", Primitive ((Pbytes_set_32(true)), 3); + "%caml_string_set64", Primitive ((Pbytes_set_64(false)), 3); + "%caml_string_set64u", Primitive ((Pbytes_set_64(true)), 3); + "%caml_bytes_get16", Primitive ((Pbytes_load_16(false)), 2); + "%caml_bytes_get16u", Primitive ((Pbytes_load_16(true)), 2); + "%caml_bytes_get32", Primitive ((Pbytes_load_32(false)), 2); + "%caml_bytes_get32u", Primitive ((Pbytes_load_32(true)), 2); + "%caml_bytes_get64", Primitive ((Pbytes_load_64(false)), 2); + "%caml_bytes_get64u", Primitive ((Pbytes_load_64(true)), 2); + "%caml_bytes_set16", Primitive ((Pbytes_set_16(false)), 3); + "%caml_bytes_set16u", Primitive ((Pbytes_set_16(true)), 3); + "%caml_bytes_set32", Primitive ((Pbytes_set_32(false)), 3); + "%caml_bytes_set32u", Primitive ((Pbytes_set_32(true)), 3); + "%caml_bytes_set64", Primitive ((Pbytes_set_64(false)), 3); + "%caml_bytes_set64u", Primitive ((Pbytes_set_64(true)), 3); + "%caml_bigstring_get16", Primitive ((Pbigstring_load_16(false)), 2); + "%caml_bigstring_get16u", Primitive ((Pbigstring_load_16(true)), 2); + "%caml_bigstring_get32", Primitive ((Pbigstring_load_32(false)), 2); + "%caml_bigstring_get32u", Primitive ((Pbigstring_load_32(true)), 2); + "%caml_bigstring_get64", Primitive ((Pbigstring_load_64(false)), 2); + "%caml_bigstring_get64u", Primitive ((Pbigstring_load_64(true)), 2); + "%caml_bigstring_set16", Primitive ((Pbigstring_set_16(false)), 3); + "%caml_bigstring_set16u", Primitive ((Pbigstring_set_16(true)), 3); + "%caml_bigstring_set32", Primitive ((Pbigstring_set_32(false)), 3); + "%caml_bigstring_set32u", Primitive ((Pbigstring_set_32(true)), 3); + "%caml_bigstring_set64", Primitive ((Pbigstring_set_64(false)), 3); + "%caml_bigstring_set64u", Primitive ((Pbigstring_set_64(true)), 3); + "%bswap16", Primitive (Pbswap16, 1); + "%bswap_int32", Primitive ((Pbbswap(Pint32)), 1); + "%bswap_int64", Primitive ((Pbbswap(Pint64)), 1); + "%bswap_native", Primitive ((Pbbswap(Pnativeint)), 1); + "%int_as_pointer", Primitive (Pint_as_pointer, 1); + "%opaque", Primitive (Popaque, 1); + "%sys_argv", External prim_sys_argv; + "%send", Send; + "%sendself", Send_self; + "%sendcache", Send_cache; + "%equal", Comparison(Equal, Compare_generic); + "%notequal", Comparison(Not_equal, Compare_generic); + "%lessequal", Comparison(Less_equal, Compare_generic); + "%lessthan", Comparison(Less_than, Compare_generic); + "%greaterequal", Comparison(Greater_equal, Compare_generic); + "%greaterthan", Comparison(Greater_than, Compare_generic); + "%compare", Comparison(Compare, Compare_generic); + ] + + +let lookup_primitive loc p = + match Hashtbl.find primitives_table p.prim_name with + | prim -> prim + | exception Not_found -> + if String.length p.prim_name > 0 && p.prim_name.[0] = '%' then + raise(Error(loc, Unknown_builtin_primitive p.prim_name)); + External p + +let lookup_primitive_and_mark_used loc p env path = + match lookup_primitive loc p with + | External _ as e -> add_used_primitive loc env path; e + | x -> x + +let simplify_constant_constructor = function + | Equal -> true + | Not_equal -> true + | Less_equal -> false + | Less_than -> false + | Greater_equal -> false + | Greater_than -> false + | Compare -> false + +(* The following function computes the greatest lower bound in the + semilattice of array kinds: + gen + / \ + addr float + | + int + Note that the GLB is not guaranteed to exist, in which case we return + our first argument instead of raising a fatal error because, although + it cannot happen in a well-typed program, (ab)use of Obj.magic can + probably trigger it. +*) +let glb_array_type t1 t2 = + match t1, t2 with + | Pfloatarray, (Paddrarray | Pintarray) + | (Paddrarray | Pintarray), Pfloatarray -> t1 + + | Pgenarray, x | x, Pgenarray -> x + | Paddrarray, x | x, Paddrarray -> x + | Pintarray, Pintarray -> Pintarray + | Pfloatarray, Pfloatarray -> Pfloatarray + +(* Specialize a primitive from available type information. *) + +let specialize_primitive env ty ~has_constant_constructor prim = + let param_tys = + match is_function_type env ty with + | None -> [] + | Some (p1, rhs) -> + match is_function_type env rhs with + | None -> [p1] + | Some (p2, _) -> [p1;p2] + in + match prim, param_tys with + | Primitive (Psetfield(n, Pointer, init), arity), [_; p2] -> begin + match maybe_pointer_type env p2 with + | Pointer -> None + | Immediate -> Some (Primitive (Psetfield(n, Immediate, init), arity)) + end + | Primitive (Parraylength t, arity), [p] -> begin + let array_type = glb_array_type t (array_type_kind env p) in + if t = array_type then None + else Some (Primitive (Parraylength array_type, arity)) + end + | Primitive (Parrayrefu t, arity), p1 :: _ -> begin + let array_type = glb_array_type t (array_type_kind env p1) in + if t = array_type then None + else Some (Primitive (Parrayrefu array_type, arity)) + end + | Primitive (Parraysetu t, arity), p1 :: _ -> begin + let array_type = glb_array_type t (array_type_kind env p1) in + if t = array_type then None + else Some (Primitive (Parraysetu array_type, arity)) + end + | Primitive (Parrayrefs t, arity), p1 :: _ -> begin + let array_type = glb_array_type t (array_type_kind env p1) in + if t = array_type then None + else Some (Primitive (Parrayrefs array_type, arity)) + end + | Primitive (Parraysets t, arity), p1 :: _ -> begin + let array_type = glb_array_type t (array_type_kind env p1) in + if t = array_type then None + else Some (Primitive (Parraysets array_type, arity)) + end + | Primitive (Pbigarrayref(unsafe, n, Pbigarray_unknown, + Pbigarray_unknown_layout), arity), p1 :: _ -> begin + let (k, l) = bigarray_type_kind_and_layout env p1 in + match k, l with + | Pbigarray_unknown, Pbigarray_unknown_layout -> None + | _, _ -> Some (Primitive (Pbigarrayref(unsafe, n, k, l), arity)) + end + | Primitive (Pbigarrayset(unsafe, n, Pbigarray_unknown, + Pbigarray_unknown_layout), arity), p1 :: _ -> begin + let (k, l) = bigarray_type_kind_and_layout env p1 in + match k, l with + | Pbigarray_unknown, Pbigarray_unknown_layout -> None + | _, _ -> Some (Primitive (Pbigarrayset(unsafe, n, k, l), arity)) + end + | Primitive (Pmakeblock(tag, mut, None), arity), fields -> begin + let shape = List.map (Typeopt.value_kind env) fields in + let useful = List.exists (fun knd -> knd <> Pgenval) shape in + if useful then Some (Primitive (Pmakeblock(tag, mut, Some shape), arity)) + else None + end + | Comparison(comp, Compare_generic), p1 :: _ -> + if (has_constant_constructor + && simplify_constant_constructor comp) then begin + Some (Comparison(comp, Compare_ints)) + end else if (is_base_type env p1 Predef.path_int + || is_base_type env p1 Predef.path_char + || (maybe_pointer_type env p1 = Immediate)) then begin + Some (Comparison(comp, Compare_ints)) + end else if is_base_type env p1 Predef.path_float then begin + Some (Comparison(comp, Compare_floats)) + end else if is_base_type env p1 Predef.path_string then begin + Some (Comparison(comp, Compare_strings)) + end else if is_base_type env p1 Predef.path_bytes then begin + Some (Comparison(comp, Compare_bytes)) + end else if is_base_type env p1 Predef.path_nativeint then begin + Some (Comparison(comp, Compare_nativeints)) + end else if is_base_type env p1 Predef.path_int32 then begin + Some (Comparison(comp, Compare_int32s)) + end else if is_base_type env p1 Predef.path_int64 then begin + Some (Comparison(comp, Compare_int64s)) + end else begin + None + end + | _ -> None + +let unboxed_compare name native_repr = + Primitive.make ~name ~alloc:false ~native_name:(name^"_unboxed") + ~native_repr_args:[native_repr;native_repr] ~native_repr_res:Untagged_int + +let caml_equal = + Primitive.simple ~name:"caml_equal" ~arity:2 ~alloc:true +let caml_string_equal = + Primitive.simple ~name:"caml_string_equal" ~arity:2 ~alloc:false +let caml_bytes_equal = + Primitive.simple ~name:"caml_bytes_equal" ~arity:2 ~alloc:false +let caml_notequal = + Primitive.simple ~name:"caml_notequal" ~arity:2 ~alloc:true +let caml_string_notequal = + Primitive.simple ~name:"caml_string_notequal" ~arity:2 ~alloc:false +let caml_bytes_notequal = + Primitive.simple ~name:"caml_bytes_notequal" ~arity:2 ~alloc:false +let caml_lessequal = + Primitive.simple ~name:"caml_lessequal" ~arity:2 ~alloc:true +let caml_string_lessequal = + Primitive.simple ~name:"caml_string_lessequal" ~arity:2 ~alloc:false +let caml_bytes_lessequal = + Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2 ~alloc:false +let caml_lessthan = + Primitive.simple ~name:"caml_lessthan" ~arity:2 ~alloc:true +let caml_string_lessthan = + Primitive.simple ~name:"caml_string_lessthan" ~arity:2 ~alloc:false +let caml_bytes_lessthan = + Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2 ~alloc:false +let caml_greaterequal = + Primitive.simple ~name:"caml_greaterequal" ~arity:2 ~alloc:true +let caml_string_greaterequal = + Primitive.simple ~name:"caml_string_greaterequal" ~arity:2 ~alloc:false +let caml_bytes_greaterequal = + Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2 ~alloc:false +let caml_greaterthan = + Primitive.simple ~name:"caml_greaterthan" ~arity:2 ~alloc:true +let caml_string_greaterthan = + Primitive.simple ~name:"caml_string_greaterthan" ~arity:2 ~alloc: false +let caml_bytes_greaterthan = + Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2 ~alloc: false +let caml_compare = + Primitive.simple ~name:"caml_compare" ~arity:2 ~alloc:true +let caml_int_compare = + (* Not unboxed since the comparison is done directly on tagged int *) + Primitive.simple ~name:"caml_int_compare" ~arity:2 ~alloc:false +let caml_float_compare = + unboxed_compare "caml_float_compare" Unboxed_float +let caml_string_compare = + Primitive.simple ~name:"caml_string_compare" ~arity:2 ~alloc:false +let caml_bytes_compare = + Primitive.simple ~name:"caml_bytes_compare" ~arity:2 ~alloc:false +let caml_nativeint_compare = + unboxed_compare "caml_nativeint_compare" (Unboxed_integer Pnativeint) +let caml_int32_compare = + unboxed_compare "caml_int32_compare" (Unboxed_integer Pint32) +let caml_int64_compare = + unboxed_compare "caml_int64_compare" (Unboxed_integer Pint64) + +let comparison_primitive comparison comparison_kind = + match comparison, comparison_kind with + | Equal, Compare_generic -> Pccall caml_equal + | Equal, Compare_ints -> Pintcomp Ceq + | Equal, Compare_floats -> Pfloatcomp CFeq + | Equal, Compare_strings -> Pccall caml_string_equal + | Equal, Compare_bytes -> Pccall caml_bytes_equal + | Equal, Compare_nativeints -> Pbintcomp(Pnativeint, Ceq) + | Equal, Compare_int32s -> Pbintcomp(Pint32, Ceq) + | Equal, Compare_int64s -> Pbintcomp(Pint64, Ceq) + | Not_equal, Compare_generic -> Pccall caml_notequal + | Not_equal, Compare_ints -> Pintcomp Cne + | Not_equal, Compare_floats -> Pfloatcomp CFneq + | Not_equal, Compare_strings -> Pccall caml_string_notequal + | Not_equal, Compare_bytes -> Pccall caml_bytes_notequal + | Not_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cne) + | Not_equal, Compare_int32s -> Pbintcomp(Pint32, Cne) + | Not_equal, Compare_int64s -> Pbintcomp(Pint64, Cne) + | Less_equal, Compare_generic -> Pccall caml_lessequal + | Less_equal, Compare_ints -> Pintcomp Cle + | Less_equal, Compare_floats -> Pfloatcomp CFle + | Less_equal, Compare_strings -> Pccall caml_string_lessequal + | Less_equal, Compare_bytes -> Pccall caml_bytes_lessequal + | Less_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cle) + | Less_equal, Compare_int32s -> Pbintcomp(Pint32, Cle) + | Less_equal, Compare_int64s -> Pbintcomp(Pint64, Cle) + | Less_than, Compare_generic -> Pccall caml_lessthan + | Less_than, Compare_ints -> Pintcomp Clt + | Less_than, Compare_floats -> Pfloatcomp CFlt + | Less_than, Compare_strings -> Pccall caml_string_lessthan + | Less_than, Compare_bytes -> Pccall caml_bytes_lessthan + | Less_than, Compare_nativeints -> Pbintcomp(Pnativeint, Clt) + | Less_than, Compare_int32s -> Pbintcomp(Pint32, Clt) + | Less_than, Compare_int64s -> Pbintcomp(Pint64, Clt) + | Greater_equal, Compare_generic -> Pccall caml_greaterequal + | Greater_equal, Compare_ints -> Pintcomp Cge + | Greater_equal, Compare_floats -> Pfloatcomp CFge + | Greater_equal, Compare_strings -> Pccall caml_string_greaterequal + | Greater_equal, Compare_bytes -> Pccall caml_bytes_greaterequal + | Greater_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cge) + | Greater_equal, Compare_int32s -> Pbintcomp(Pint32, Cge) + | Greater_equal, Compare_int64s -> Pbintcomp(Pint64, Cge) + | Greater_than, Compare_generic -> Pccall caml_greaterthan + | Greater_than, Compare_ints -> Pintcomp Cgt + | Greater_than, Compare_floats -> Pfloatcomp CFgt + | Greater_than, Compare_strings -> Pccall caml_string_greaterthan + | Greater_than, Compare_bytes -> Pccall caml_bytes_greaterthan + | Greater_than, Compare_nativeints -> Pbintcomp(Pnativeint, Cgt) + | Greater_than, Compare_int32s -> Pbintcomp(Pint32, Cgt) + | Greater_than, Compare_int64s -> Pbintcomp(Pint64, Cgt) + | Compare, Compare_generic -> Pccall caml_compare + | Compare, Compare_ints -> Pccall caml_int_compare + | Compare, Compare_floats -> Pccall caml_float_compare + | Compare, Compare_strings -> Pccall caml_string_compare + | Compare, Compare_bytes -> Pccall caml_bytes_compare + | Compare, Compare_nativeints -> Pccall caml_nativeint_compare + | Compare, Compare_int32s -> Pccall caml_int32_compare + | Compare, Compare_int64s -> Pccall caml_int64_compare + +let lambda_of_loc kind loc = + let loc_start = loc.Location.loc_start in + let (file, lnum, cnum) = Location.get_pos_info loc_start in + let file = + if Filename.is_relative file then + file + else + Location.rewrite_absolute_path file in + let enum = loc.Location.loc_end.Lexing.pos_cnum - + loc_start.Lexing.pos_cnum + cnum in + match kind with + | Loc_POS -> + Lconst (Const_block (0, [ + Const_immstring file; + Const_base (Const_int lnum); + Const_base (Const_int cnum); + Const_base (Const_int enum); + ])) + | Loc_FILE -> Lconst (Const_immstring file) + | Loc_MODULE -> + let filename = Filename.basename file in + let name = Env.get_unit_name () in + let module_name = if name = "" then "//"^filename^"//" else name in + Lconst (Const_immstring module_name) + | Loc_LOC -> + let loc = Printf.sprintf "File %S, line %d, characters %d-%d" + file lnum cnum enum in + Lconst (Const_immstring loc) + | Loc_LINE -> Lconst (Const_base (Const_int lnum)) + +let caml_restore_raw_backtrace = + Primitive.simple ~name:"caml_restore_raw_backtrace" ~arity:2 ~alloc:false + +let try_ids = Hashtbl.create 8 + +let add_exception_ident id = + Hashtbl.replace try_ids id () + +let remove_exception_ident id = + Hashtbl.remove try_ids id + +let lambda_of_prim prim_name prim loc args arg_exps = + match prim, args with + | Primitive (prim, arity), args when arity = List.length args -> + Lprim(prim, args, loc) + | External prim, args when prim = prim_sys_argv -> + Lprim(Pccall prim, Lconst (Const_pointer 0) :: args, loc) + | External prim, args -> + Lprim(Pccall prim, args, loc) + | Comparison(comp, knd), ([_;_] as args) -> + let prim = comparison_primitive comp knd in + Lprim(prim, args, loc) + | Raise kind, [arg] -> + let kind = + match kind, arg with + | Raise_regular, Lvar argv when Hashtbl.mem try_ids argv -> + Raise_reraise + | _, _ -> + kind + in + let arg = + match arg_exps with + | None -> arg + | Some [arg_exp] -> event_after arg_exp arg + | Some _ -> assert false + in + Lprim(Praise kind, [arg], loc) + | Raise_with_backtrace, [exn; bt] -> + let vexn = Ident.create_local "exn" in + let raise_arg = + match arg_exps with + | None -> Lvar vexn + | Some [exn_exp; _] -> event_after exn_exp (Lvar vexn) + | Some _ -> assert false + in + Llet(Strict, Pgenval, vexn, exn, + Lsequence(Lprim(Pccall caml_restore_raw_backtrace, + [Lvar vexn; bt], + loc), + Lprim(Praise Raise_reraise, [raise_arg], loc))) + | Lazy_force, [arg] -> + Matching.inline_lazy_force arg Location.none + | Loc kind, [] -> + lambda_of_loc kind loc + | Loc kind, [arg] -> + let lam = lambda_of_loc kind loc in + Lprim(Pmakeblock(0, Immutable, None), [lam; arg], loc) + | Send, [obj; meth] -> + Lsend(Public, meth, obj, [], loc) + | Send_self, [obj; meth] -> + Lsend(Self, meth, obj, [], loc) + | Send_cache, [obj; meth; cache; pos] -> + Lsend(Cached, meth, obj, [cache; pos], loc) + | (Raise _ | Raise_with_backtrace + | Lazy_force | Loc _ | Primitive _ | Comparison _ + | Send | Send_self | Send_cache), _ -> + raise(Error(loc, Wrong_arity_builtin_primitive prim_name)) + +let check_primitive_arity loc p = + let prim = lookup_primitive loc p in + let ok = + match prim with + | Primitive (_,arity) -> arity = p.prim_arity + | External _ -> true + | Comparison _ -> p.prim_arity = 2 + | Raise _ -> p.prim_arity = 1 + | Raise_with_backtrace -> p.prim_arity = 2 + | Lazy_force -> p.prim_arity = 1 + | Loc _ -> p.prim_arity = 1 || p.prim_arity = 0 + | Send | Send_self -> p.prim_arity = 2 + | Send_cache -> p.prim_arity = 4 + in + if not ok then raise(Error(loc, Wrong_arity_builtin_primitive p.prim_name)) + +(* Eta-expand a primitive *) + +let transl_primitive loc p env ty path = + let prim = lookup_primitive_and_mark_used loc p env path in + let has_constant_constructor = false in + let prim = + match specialize_primitive env ty ~has_constant_constructor prim with + | None -> prim + | Some prim -> prim + in + let rec make_params n = + if n <= 0 then [] + else (Ident.create_local "prim", Pgenval) :: make_params (n-1) + in + let params = make_params p.prim_arity in + let args = List.map (fun (id, _) -> Lvar id) params in + let body = lambda_of_prim p.prim_name prim loc args None in + match params with + | [] -> body + | _ -> + Lfunction{ kind = Curried; + params; + return = Pgenval; + attr = default_stub_attribute; + loc = loc; + body = body; } + +(* Determine if a primitive is a Pccall or will be turned later into + a C function call that may raise an exception *) +let primitive_is_ccall = function + | Pccall _ | Pstringrefs | Pbytesrefs | Pbytessets | Parrayrefs _ | + Parraysets _ | Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply | + Prevapply -> true + | _ -> false + +(* Determine if a primitive should be surrounded by an "after" debug event *) +let primitive_needs_event_after = function + | Primitive (prim,_) -> primitive_is_ccall prim + | External _ -> true + | Comparison(comp, knd) -> + primitive_is_ccall (comparison_primitive comp knd) + | Lazy_force | Send | Send_self | Send_cache -> true + | Raise _ | Raise_with_backtrace | Loc _ -> false + +let transl_primitive_application loc p env ty path exp args arg_exps = + let prim = lookup_primitive_and_mark_used loc p env (Some path) in + let has_constant_constructor = + match arg_exps with + | [_; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}] + | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}; _] + | [_; {exp_desc = Texp_variant(_, None)}] + | [{exp_desc = Texp_variant(_, None)}; _] -> true + | _ -> false + in + let prim = + match specialize_primitive env ty ~has_constant_constructor prim with + | None -> prim + | Some prim -> prim + in + let lam = lambda_of_prim p.prim_name prim loc args (Some arg_exps) in + let lam = + if primitive_needs_event_after prim then begin + match exp with + | None -> lam + | Some exp -> event_after exp lam + end else begin + lam + end + in + lam + +(* Error report *) + +open Format + +let report_error ppf = function + | Unknown_builtin_primitive prim_name -> + fprintf ppf "Unknown builtin primitive \"%s\"" prim_name + | Wrong_arity_builtin_primitive prim_name -> + fprintf ppf "Wrong arity for builtin primitive \"%s\"" prim_name + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer ~loc report_error err) + | _ -> + None + ) diff --git a/lambda/translprim.mli b/lambda/translprim.mli new file mode 100644 index 00000000..abf0f7d5 --- /dev/null +++ b/lambda/translprim.mli @@ -0,0 +1,51 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Insertion of debugging events *) + +val event_before : Typedtree.expression -> Lambda.lambda -> Lambda.lambda + +val event_after : Typedtree.expression -> Lambda.lambda -> Lambda.lambda + +(* Translation of primitives *) + +val add_exception_ident : Ident.t -> unit +val remove_exception_ident : Ident.t -> unit + +val clear_used_primitives : unit -> unit +val get_used_primitives: unit -> Path.t list + +val check_primitive_arity : Location.t -> Primitive.description -> unit + +val transl_primitive : + Location.t -> Primitive.description -> Env.t -> + Types.type_expr -> Path.t option -> Lambda.lambda + +val transl_primitive_application : + Location.t -> Primitive.description -> Env.t -> + Types.type_expr -> Path.t -> Typedtree.expression option -> + Lambda.lambda list -> Typedtree.expression list -> Lambda.lambda + +(* Errors *) + +type error = + | Unknown_builtin_primitive of string + | Wrong_arity_builtin_primitive of string + +exception Error of Location.t * error + +open Format + +val report_error : formatter -> error -> unit diff --git a/lex/Makefile b/lex/Makefile index 6c0d8a93..b643073b 100644 --- a/lex/Makefile +++ b/lex/Makefile @@ -20,10 +20,9 @@ ROOTDIR = .. include $(ROOTDIR)/Makefile.config include $(ROOTDIR)/Makefile.common -CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun CAMLYACC ?= $(ROOTDIR)/yacc/ocamlyacc -CAMLC = $(CAMLRUN) $(ROOTDIR)/boot/ocamlc -strict-sequence -nostdlib \ +CAMLC = $(BOOT_OCAMLC) -strict-sequence -nostdlib \ -I $(ROOTDIR)/boot -use-prims $(ROOTDIR)/runtime/primitives CAMLOPT = $(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib COMPFLAGS = $(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -warn-error A \ @@ -31,7 +30,7 @@ COMPFLAGS = $(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -warn-error A \ LINKFLAGS = YACCFLAGS = -v CAMLLEX = $(CAMLRUN) $(ROOTDIR)/boot/ocamllex -CAMLDEP = $(CAMLRUN) $(ROOTDIR)/boot/ocamlc -depend +CAMLDEP = $(BOOT_OCAMLC) -depend DEPFLAGS = -slash DEPINCLUDES = @@ -51,7 +50,7 @@ ocamllex.opt: $(OBJS:.cmo=.cmx) clean:: rm -f ocamllex ocamllex.opt - rm -f *.cmo *.cmi *.cmx *.cmt *.cmti *.$(O) *~ + rm -f *.cmo *.cmi *.cmx *.cmt *.cmti *.$(O) parser.ml parser.mli: parser.mly $(CAMLYACC) $(YACCFLAGS) parser.mly diff --git a/man/ocamlc.m b/man/ocamlc.m index c3744fda..3fdaf6f1 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -582,15 +582,6 @@ contents of the object files a.cmo, b.cmo and c.cmo. These contents can be referenced as P.A, P.B and P.C in the remainder of the program. .TP -.BI \-plugin \ plugin -Dynamically load the code of the given -.I plugin -(a .cmo, .cma or .cmxs file) in the compiler. The plugin must exist in -the same kind of code as the compiler (ocamlc.byte must load bytecode -plugins, while ocamlc.opt must load native code plugins), and -extension adaptation is done automatically for .cma files (to .cmxs files -if the compiler is compiled in native code). -.TP .BI \-pp \ command Cause the compiler to call the given .I command @@ -703,11 +694,6 @@ invocations of the C compiler and linker in .B \-custom mode. Useful to debug C library problems. .TP -.B \-vmthread -Deprecated since OCaml 4.08.0. Compile or link multithreaded programs, -in combination with the VM-level threads library described in -.IR The\ OCaml\ user's\ manual . -.TP .BR \-vnum \ or\ \-version Print the version number of the compiler in short form (e.g. "3.11.0"), then exit. @@ -1070,6 +1056,13 @@ Show the description of all available warning numbers. .B \-where Print the location of the standard library, then exit. .TP +.B \-with-runtime +Include the runtime system in the generated program. This is the default. +.TP +.B \-without-runtime +The compiler does not include the runtime system (nor a reference to it) in the +generated program; it must be supplied separately. +.TP .BI \- \ file Process .I file diff --git a/man/ocamldep.m b/man/ocamldep.m index 98d1b273..dea9b93e 100644 --- a/man/ocamldep.m +++ b/man/ocamldep.m @@ -155,23 +155,6 @@ Assume that module is opened before parsing each of the following files. .TP -.BI \-plugin \ plugin -Dynamically load the code of the given -.I plugin -(a .cmo, .cma or .cmxs file) in -.BR ocamldep (1). -The plugin must exist in -the same kind of code as the tool ( -.BR ocamldep.byte -must load bytecode -plugins, while -.BR ocamldep.opt -must load native code plugins), and -extension adaptation is done automatically for .cma files (to .cmxs files -if -.BR ocamldep (1) -is compiled in native code). -.TP .BI \-pp \ command Cause .BR ocamldep (1) diff --git a/man/ocamlopt.m b/man/ocamlopt.m index 9ba40a23..5c1bc40e 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -349,6 +349,9 @@ in a slight expansion in code size. Higher values for the option cause larger and larger functions to become candidate for inlining, but can result in a serious increase in code size. .TP +.B \-insn\-sched +Enables the instruction scheduling pass in the compiler backend. +.TP .BI \-intf \ filename Compile the file .I filename @@ -426,6 +429,9 @@ and pass the correct C libraries and options on the command line. Allow the compiler to use some optimizations that are valid only for code that is never dynlinked. .TP +.B \-no\-insn\-sched +Disables the instruction scheduling pass in the compiler backend. +.TP .B -nostdlib Do not automatically add the standard library directory to the list of directories searched for compiled interface files (.cmi), compiled @@ -478,31 +484,6 @@ option. This option can also be used to produce a compiled shared/dynamic library (.so extension). .TP -.B \-p -Generate extra code to write profile information when the program is -executed. The profile information can then be examined with the -analysis program -.BR gprof (1). -The -.B \-p -option must be given both at -compile-time and at link-time. Linking object files not compiled with -.B \-p -is possible, but results in less precise profiling. - -See the -.BR gprof (1) -man page for more information about the profiles. - -Full support for -.BR gprof (1) -is only available for certain platforms -(currently: Intel x86/Linux and Alpha/Digital Unix). -On other platforms, the -.B \-p -option will result in a less precise -profile (no call graph information, only a time profile). -.TP .B \-pack Build an object file (.cmx and .o files) and its associated compiled interface (.cmi) that combines the .cmx object @@ -533,15 +514,6 @@ See .IR "The OCaml user's manual" , chapter "Native-code compilation" for more details. .TP -.BI \-plugin \ plugin -Dynamically load the code of the given -.I plugin -(a .cmo, .cma or .cmxs file) in the compiler. The plugin must exist in -the same kind of code as the compiler (ocamlopt.byte must load bytecode -plugins, while ocamlopt.opt must load native code plugins), and -extension adaptation is done automatically for .cma files (to .cmxs files -if the compiler is compiled in native code). -.TP .BI \-pp \ command Cause the compiler to call the given .I command @@ -712,6 +684,13 @@ Show the description of all available warning numbers. .B \-where Print the location of the standard library, then exit. .TP +.B \-with-runtime +Include the runtime system in the generated program. This is the default. +.TP +.B \-without-runtime +The compiler does not include the runtime system (nor a reference to it) in the +generated program; it must be supplied separately. +.TP .BI \- \ file Process .I file diff --git a/manual/README.md b/manual/README.md index 52824d5f..b7972b51 100644 --- a/manual/README.md +++ b/manual/README.md @@ -94,7 +94,7 @@ Consequently, these options are described together in the file and `top.etex`. If you need to update this list of options, the top comment of `unified-options.etex` contains the relevant information. -- Part IV, The OCaml library: 'libref' +- Part IV, The OCaml library: 'library' This parts contains an brief presentation of all libraries bundled with the compilers and the api documentation generated for these libraries. - The core library: `core.etex` diff --git a/manual/manual/allfiles.etex b/manual/manual/allfiles.etex index d1eade0c..2fb6f8e7 100644 --- a/manual/manual/allfiles.etex +++ b/manual/manual/allfiles.etex @@ -74,7 +74,6 @@ and as a \input{flambda.tex} \input{spacetime-chapter.tex} \input{afl-fuzz.tex} -\input{plugins} \part{The OCaml library} \label{p:library} diff --git a/manual/manual/cmds/Makefile b/manual/manual/cmds/Makefile index a6f47853..6112a1af 100644 --- a/manual/manual/cmds/Makefile +++ b/manual/manual/cmds/Makefile @@ -13,7 +13,7 @@ TRANSF = $(SET_LD_PATH) $(OCAMLRUN) $(TOOLS)/transf FILES = comp.tex top.tex runtime.tex native.tex lexyacc.tex intf-c.tex \ ocamldep.tex profil.tex debugger.tex browser.tex ocamldoc.tex \ warnings-help.tex ocamlbuild.tex flambda.tex spacetime-chapter.tex \ - afl-fuzz.tex plugins.tex unified-options.tex + afl-fuzz.tex unified-options.tex WITH_TRANSF = top.tex intf-c.tex flambda.tex spacetime-chapter.tex \ afl-fuzz.tex lexyacc.tex debugger.tex diff --git a/manual/manual/cmds/comp.etex b/manual/manual/cmds/comp.etex index 6cdd9367..39de94fc 100644 --- a/manual/manual/cmds/comp.etex +++ b/manual/manual/cmds/comp.etex @@ -100,6 +100,17 @@ phase can be run directly, as in: The produced file has the executable bit set, and it manages to launch the bytecode interpreter by itself. +The compiler is able to emit some information on its internal stages. +It can output ".cmt" files for the implementation of the compilation unit +and ".cmti" for signatures if the option "-bin-annot" is passed to it (see the +description of "-bin-annot" below). +Each such file contains a typed abstract syntax tree (AST), that is produced +during the type checking procedure. This tree contains all available information +about the location and the specific type of each term in the source file. +The AST is partial if type checking was unsuccessful. + +These ".cmt" and ".cmti" files are typically useful for code inspection tools. + \section{Options}\label{s:comp-options} The following command-line options are recognized by "ocamlc". @@ -361,7 +372,7 @@ This section describes and explains in detail some warnings: after the addition of new fields to a record type. \begin{verbatim} -type 'a point = {x='a ;y='a} +type 'a point = {x : 'a; y : 'a} let dx { x } = x (* implicit field elision: trigger warning 9 *) let dy { y; _ } = y (* explicit field elision: do not trigger warning 9 *) \end{verbatim} diff --git a/manual/manual/cmds/intf-c.etex b/manual/manual/cmds/intf-c.etex index 5cbaa94b..70376a2c 100644 --- a/manual/manual/cmds/intf-c.etex +++ b/manual/manual/cmds/intf-c.etex @@ -1439,15 +1439,15 @@ above: \end{verbatim} The pointer returned by "caml_named_value" is constant and can safely -be cached in a C variable to avoid repeated name lookups. On the other -hand, the value pointed to can change during garbage collection and -must always be recomputed at the point of use. Here is a more -efficient variant of "call_caml_f" above that calls "caml_named_value" -only once: +be cached in a C variable to avoid repeated name lookups. The value +pointed to cannot be changed from C. However, it might change during +garbage collection, so must always be recomputed at the point of +use. Here is a more efficient variant of "call_caml_f" above that +calls "caml_named_value" only once: \begin{verbatim} void call_caml_f(int arg) { - static value * closure_f = NULL; + static const value * closure_f = NULL; if (closure_f == NULL) { /* First time around, look up by name */ closure_f = caml_named_value("test function"); @@ -1683,14 +1683,14 @@ Here is the C stub code for calling these functions from C: int fib(int n) { - static value * fib_closure = NULL; + static const value * fib_closure = NULL; if (fib_closure == NULL) fib_closure = caml_named_value("fib"); return Int_val(caml_callback(*fib_closure, Val_int(n))); } char * format_result(int n) { - static value * format_result_closure = NULL; + static const value * format_result_closure = NULL; if (format_result_closure == NULL) format_result_closure = caml_named_value("format_result"); return strdup(String_val(caml_callback(*format_result_closure, Val_int(n)))); @@ -2286,7 +2286,7 @@ system. The following functions are declared in the include file \item "caml_c_thread_register()" registers the calling thread with the OCaml run-time system. Returns 1 on success, 0 on error. Registering an -already-register thread does nothing and returns 0. +already-registered thread does nothing and returns 0. \item "caml_c_thread_unregister()" must be called before the thread terminates, to unregister it from the OCaml run-time system. diff --git a/manual/manual/cmds/native.etex b/manual/manual/cmds/native.etex index c1f3d925..99c69d03 100644 --- a/manual/manual/cmds/native.etex +++ b/manual/manual/cmds/native.etex @@ -86,6 +86,19 @@ libraries. They are linked with the program. The output of the linking phase is a regular Unix or Windows executable file. It does not need "ocamlrun" to run. +% The following two paragraphs are a duplicate from the description of the batch compiler. + +The compiler is able to emit some information on its internal stages. +It can output ".cmt" files for the implementation of the compilation unit +and ".cmti" for signatures if the option "-bin-annot" is passed to it (see the +description of "-bin-annot" below). +Each such file contains a typed abstract syntax tree (AST), that is produced +during the type checking procedure. This tree contains all available information +about the location and the specific type of each term in the source file. +The AST is partial if type checking was unsuccessful. + +These ".cmt" and ".cmti" files are typically useful for code inspection tools. + \section{Options} The following command-line options are recognized by "ocamlopt". @@ -227,4 +240,3 @@ not referenced. See also the "Sys.opaque_identity" function from the "Sys" standard library module. \end{itemize} - diff --git a/manual/manual/cmds/ocamldep.etex b/manual/manual/cmds/ocamldep.etex index 00696681..1c2ab78e 100644 --- a/manual/manual/cmds/ocamldep.etex +++ b/manual/manual/cmds/ocamldep.etex @@ -110,14 +110,6 @@ Output one line per file, regardless of the length. Assume that module \var{module} is opened before parsing each of the following files. -\item["-plugin" \var{plugin}] -Dynamically load the code of the given \var{plugin} -(a ".cmo", ".cma" or ".cmxs" file) in "ocamldep". \var{plugin} must exist in -the same kind of code as "ocamldep" ("ocamldep.byte" must load bytecode -plugins, while "ocamldep.opt" must load native code plugins), and -extension adaptation is done automatically for ".cma" files (to ".cmxs" files -if "ocamldep" is compiled in native code). - \item["-pp" \var{command}] Cause "ocamldep" to call the given \var{command} as a preprocessor for each source file. diff --git a/manual/manual/cmds/plugins.etex b/manual/manual/cmds/plugins.etex deleted file mode 100644 index d870163f..00000000 --- a/manual/manual/cmds/plugins.etex +++ /dev/null @@ -1,87 +0,0 @@ -\chapter{Compiler plugins\label{c:plugins}} -%HEVEA\cutname{plugins.html} - -\section{Overview} - -Starting from OCaml 4.03, it is possible to extend the native and bytecode compilers -with plugins using the "-plugin" command line option of both tools. -This possibility is also available for "ocamldep" for OCaml version ulterior to 4.05. -Beware however that plugins are an advanced feature of which the design -is still in flux and breaking changes may happen in the future. Plugins features -are based on the compiler library API. In complement, new hooks have been added to -the compiler to increase its flexibility. - -In particular, hooks are available in the -\ifouthtml\ahref{compilerlibref/Pparse.html}{\texttt{Pparse} module} -\else\texttt{Pparse} module (see section~\ref{Pparse})\fi -to transform the parsed abstract syntax tree, providing similar functionality -to extension point based preprocessors. -Other hooks are available to analyze the typed tree in the -\ifouthtml\ahref{compilerlibref/Typemod.html}{\texttt{Typemod} module} -\else\texttt{Typemod} module (see section~\ref{Typemod})\fi -after the type-checking phase of the compiler. Since the typed tree relies -on numerous invariants that play a vital part in ulterior phases of the -compiler, it is not possible however to transform the typed tree. -Similarly, the intermediary lambda representation can be modified by using the -hooks provided in the -\ifouthtml\ahref{compilerlibref/Simplif.html}{\texttt{Simplif} module} -\else\texttt{Simplif} module (see section~\ref{Simplif})\fi. -A plugin can also add new options to a tool through the -"Clflags.add_arguments" function (see -\ifouthtml\ahref{compilerlibref/Clflags.html}{\texttt{Clflags} module} -\else\texttt{Clflags} module (see section~\ref{Clflags})\fi). - -Plugins are dynamically loaded and need to be compiled in the same mode (i.e. -native or bytecode) that the tool they extend. - -\section{Basic example} - -As an illustration, we shall build a simple "Hello world" plugin that adds -a simple statement "print_endline \"Hello from:$sourcefile\"" to a compiled file. - -The simplest way to implement this feature is to modify the abstract syntax -tree. We will therefore add an hooks to the "Pparse.ImplementationHooks". -Since the proposed modification is very basic, we could implement the hook -directly. However, for the sake of this illustration, we use the "Ast_mapper" -structure that provides a better path to build more interesting plugins. - -The first step is to build the AST fragment corresponding to the -evaluation of "print_endline": -\begin{verbatim} - let print_endline name = - let open Ast_helper in - let print_endline = Exp.ident - @@ Location.mknoloc @@Longident.Lident "print_endline" in - let hello = Exp.constant @@ Const.string @@ "Hello from: " ^ name in - Str.eval @@ Exp.apply print_endline [Asttypes.Nolabel, hello] -\end{verbatim}% -Then, we can construct an ast mapper that adds this fragment to the parsed -ast tree. -\begin{verbatim} -let add_hello name (mapper:Ast_mapper.mapper) structure = - let default = Ast_mapper.default_mapper in - (print_endline name) :: (default.structure default structure) - -let ast_mapper name = - { Ast_mapper.default_mapper with structure = add_hello name } -\end{verbatim}% -% -Once this AST mapper is constructed, we need to convert it to a hook and adds this -hook to the "Pparse.ImplementationsHooks". -\begin{verbatim} -let transform hook_info structure = - let astm = ast_mapper hook_info.Misc.sourcefile in - astm.structure astm structure - -let () = Pparse.ImplementationHooks.add_hook "Hello world hook" transform -\end{verbatim} -% -The resulting simplistic plugin can then be compiled with -\begin{verbatim} -$ ocamlopt -I +compiler-libs -shared plugin.ml -o plugin.cmxs -\end{verbatim} -% -Compiling other files with this plugin enabled is then as simple as -\begin{verbatim} -$ ocamlopt -plugin plugin.cmxs test.ml -o test -\end{verbatim} diff --git a/manual/manual/cmds/profil.etex b/manual/manual/cmds/profil.etex index e286f6a4..18029dbc 100644 --- a/manual/manual/cmds/profil.etex +++ b/manual/manual/cmds/profil.etex @@ -140,36 +140,7 @@ Display a short usage summary and exit. Profiling with "ocamlprof" only records execution counts, not the actual time spent within each function. There is currently no way to perform -time profiling on bytecode programs generated by "ocamlc". - -Native-code programs generated by "ocamlopt" can be profiled for time -and execution counts using the "-p" option and the standard Unix -profiler "gprof". Just add the "-p" option when compiling and linking -the program: -\begin{alltt} - ocamlopt -o myprog -p \var{other-options} \var{files} - ./myprog - gprof myprog -\end{alltt} -OCaml function names in the output of "gprof" have the following format: -\begin{alltt} - \var{Module-name}_\var{function-name}_\var{unique-number} -\end{alltt} -Other functions shown are either parts of the OCaml run-time system or -external C functions linked with the program. - -The output of "gprof" is described in the Unix manual page for -"gprof(1)". It generally consists of two parts: a ``flat'' profile -showing the time spent in each function and the number of invocation -of each function, and a ``hierarchical'' profile based on the call -graph. Currently, only the Intel x86 ports of "ocamlopt" under -Linux, BSD and MacOS X support the two profiles. On other platforms, -"gprof" will report only the ``flat'' profile with just time -information. When reading the output of "gprof", keep in mind that -the accumulated times computed by "gprof" are based on heuristics and -may not be exact. - -\paragraph{Note} The "ocamloptp" command also accepts the "-p" -option. In that case, both kinds of profiling are performed by the -program, and you can display the results with the "gprof" and "ocamlprof" -commands, respectively. +time profiling on bytecode programs generated by "ocamlc". For time +profiling of native code, users are recommended to use standard tools +such as perf (on Linux), Instruments (on macOS) and DTrace. Profiling +with "gprof" is no longer supported. diff --git a/manual/manual/cmds/unified-options.etex b/manual/manual/cmds/unified-options.etex index 0af4c2c5..81f60937 100644 --- a/manual/manual/cmds/unified-options.etex +++ b/manual/manual/cmds/unified-options.etex @@ -496,29 +496,6 @@ This option can also be used to produce a \comp{C source file (".c" extension) or a} compiled shared/dynamic library (".so" extension, ".dll" under Windows). }%notop -\nat{% -\item["-p"] -Generate extra code to write profile information when the program is -executed. The profile information can then be examined with the -analysis program "gprof". (See chapter~\ref{c:profiler} for more -information on profiling.) The "-p" option must be given both at -compile-time and at link-time. Linking object files not compiled with -"-p" is possible, but results in less precise profiling. - -\begin{unix} See the Unix manual page for "gprof(1)" for more -information about the profiles. - -Full support for "gprof" is only available for certain platforms -(currently: Intel x86 32 and 64 bits under Linux, BSD and MacOS X). -On other platforms, the "-p" option will result in a less precise -profile (no call graph information, only a time profile). -\end{unix} - -\begin{windows} -The "-p" option does not work under Windows. -\end{windows} -}%nat - \nat{% \item["-pack"] Build an object file (".cmx" and ".o"/".obj" files) and its associated compiled @@ -569,17 +546,6 @@ contents can be referenced as "P.A", "P.B" and "P.C" in the remainder of the program. }%comp - -\notop{% -\item["-plugin" \var{plugin}] -Dynamically load the code of the given \var{plugin} -(a ".cmo", ".cma" or ".cmxs" file) in the compiler. \var{plugin} must exist in -the same kind of code as the compiler ({\machine \ocamlx.byte} must load -bytecode plugins, while {\machine \ocamlx.opt} must load native code plugins), -and extension adaptation is done automatically for ".cma" files (to ".cmxs" -files if the compiler is compiled in native code). -}%notop - \notop{% \item["-pp" \var{command}] Cause the compiler to call the given \var{command} as a preprocessor @@ -723,13 +689,6 @@ Print all external commands before they are executed, \comp{in particular invocations of the C compiler and linker in "-custom" mode.} Useful to debug C library problems. -\comp{% -\item["-vmthread"] -Deprecated since OCaml 4.08.0. Compile or link multithreaded programs, -in combination with the VM-level "threads" library described in -chapter~\ref{c:threads}. -}%comp - \notop{% \item["-version" or "-vnum"] Print the version number of the compiler in short form (e.g. "3.11.0"), @@ -820,6 +779,17 @@ Show the description of all available warning numbers. Print the location of the standard library, then exit. }%notop +\notop{% +\item["-with-runtime"] +Include the runtime system in the generated program. This is the default. +} + +\notop{% +\item["-without-runtime"] +The compiler does not include the runtime system (nor a reference to it) in the +generated program; it must be supplied separately. +} + \item["-" \var{file}] \notop{Process \var{file} as a file name, even if it starts with a dash ("-") character.} diff --git a/manual/manual/library/Makefile b/manual/manual/library/Makefile index 6862df6b..a757ef53 100644 --- a/manual/manual/library/Makefile +++ b/manual/manual/library/Makefile @@ -30,7 +30,6 @@ COMPILER_LIBS_INTF = Asthelper.tex Astmapper.tex Asttypes.tex \ $(COMPILER_LIBS_PLUGIN_HOOKS) OTHERLIB_INTF = Unix.tex UnixLabels.tex Str.tex \ - Graphics.tex GraphicsX11.tex \ Thread.tex Mutex.tex Condition.tex Event.tex ThreadUnix.tex \ Dynlink.tex Bigarray.tex diff --git a/manual/manual/library/compilerlibs.etex b/manual/manual/library/compilerlibs.etex index d4919376..e4fb5e3a 100644 --- a/manual/manual/library/compilerlibs.etex +++ b/manual/manual/library/compilerlibs.etex @@ -5,8 +5,7 @@ This chapter describes the OCaml front-end, which declares the abstract syntax tree used by the compiler, provides a way to parse, print and pretty-print OCaml code, and ultimately allows one to write abstract syntax tree preprocessors invoked via the {\tt -ppx} flag (see chapters~\ref{c:camlc} -and~\ref{c:nativecomp}) and plugins invoked via the {\tt -plugin} flag -(see chapter~\ref{c:plugins}). +and~\ref{c:nativecomp}). It is important to note that the exported front-end interface follows the evolution of the OCaml language and implementation, and thus does not provide {\bf any} backwards compatibility guarantees. @@ -56,19 +55,3 @@ type\\*"#load \"compiler-libs/ocamlcommon.cma\";;". \input{Pprintast.tex} % \input{Printast.tex} \fi - -\ifouthtml -The following modules provides hooks for compiler plugins: -\begin{links} -\item \ahref{compilerlibref/Pparse.html}{Module \texttt{Pparse}: OCaml parser driver} -\item \ahref{compilerlibref/Typemod.html}{Module \texttt{Typemod}: -OCaml module type checking} -\item \ahref{compilerlibref/Simplif.html}{Module \texttt{Simplif}: Lambda simplification} -\item \ahref{compilerlibref/Clflags.html}{Module \texttt{Clflags}: command line flags} -\end{links} -\else -\input{Pparse.tex} -\input{Typemod.tex} -\input{Simplif.tex} -\input{Clflags.tex} -\fi diff --git a/manual/manual/library/libdynlink.etex b/manual/manual/library/libdynlink.etex index 4481ebd4..f7448b94 100644 --- a/manual/manual/library/libdynlink.etex +++ b/manual/manual/library/libdynlink.etex @@ -15,7 +15,12 @@ that they remain independent of the implementation of modules in the main program. Programs that use the "dynlink" library simply need to link -"dynlink.cma" or "dynlink.cmxa" with their object files and other libraries. +"dynlink.cma" or "dynlink.cmxa" with their object files and other libraries. + +\textbf{Note:} in order to insure that the dynamically-loaded modules have +access to all the libraries that are visible to the main program (and not just +to the parts of those libraries that are actually used in the main program), +programs using the "dynlink" library should be linked with "-linkall". \ifouthtml \begin{links} @@ -25,4 +30,3 @@ Programs that use the "dynlink" library simply need to link \else \input{Dynlink.tex} \fi - diff --git a/manual/manual/library/libgraph.etex b/manual/manual/library/libgraph.etex index 7b5b70b4..89568aec 100644 --- a/manual/manual/library/libgraph.etex +++ b/manual/manual/library/libgraph.etex @@ -1,99 +1,18 @@ \chapter{The graphics library} %HEVEA\cutname{libgraph.html} -The "graphics" library provides a set of portable drawing primitives. -Drawing takes place -in a separate window that is created when "Graphics.open_graph" is called. +Since OCaml 4.09, the "graphics" library is distributed as an external +package. Its new home is: -\begin{unix} -This library is implemented under the X11 windows system. -Programs that use the "graphics" library must be linked as follows: -\begin{alltt} - ocamlc \var{other options} graphics.cma \var{other files} -\end{alltt} -For interactive use of the "graphics" library, do: -\begin{alltt} - ocamlmktop -o mytop graphics.cma - ./mytop -\end{alltt} -or (if dynamic linking of C libraries is supported on your platform), -start "ocaml" and type "#load \"graphics.cma\";;". +\url{https://github.com/ocaml/graphics} -Here are the graphics mode specifications supported by -"Graphics.open_graph" on -the X11 implementation of this library: -the argument to "Graphics.open_graph" has the format -"\""{\it display-name} {\it geometry\/}"\"", -where {\it display-name} is the name of the X-windows display to -connect to, and {\it geometry} is a standard X-windows geometry -specification. The two components are separated by a space. Either can -be omitted, or both. Examples: -\begin{options} -\item["Graphics.open_graph \"foo:0\""] -connects to the display "foo:0" and creates a window with the default geometry -\item["Graphics.open_graph \"foo:0 300x100+50-0\""] -connects to the display "foo:0" and creates a window 300 pixels wide -by 100 pixels tall, at location $(50,0)$ -\item["Graphics.open_graph \" 300x100+50-0\""] -connects to the default display and creates a window 300 pixels wide -by 100 pixels tall, at location $(50,0)$ -\item["Graphics.open_graph \"\""] -connects to the default display and creates a window with the default -geometry. -\end{options} -\end{unix} +If you are using the opam package manager, you should install the +corresponding "graphics" package: -\begin{windows} -This library is available both for standalone compiled programs and -under the toplevel application "ocamlwin.exe". For the latter, this -library must be loaded in-core by typing -\begin{verbatim} - #load "graphics.cma";; -\end{verbatim} -\end{windows} - -The screen coordinates are interpreted as shown in the figure below. -Notice that the coordinate system used is the same as in mathematics: -$y$ increases from the bottom of the screen to the top of the screen, -and angles are measured counterclockwise (in degrees). -Drawing is clipped to the screen. -% -\begin{latexonly} -\begin{center} -\setlength{\unitlength}{0.5mm} -\begin{picture}(130,100)(-10,-10) -\thicklines -\put(-10,0){\vector(1,0){130}} -\put(125,0){\makebox(0,0)[l]{$x$}} -\put(0,-10){\vector(0,1){100}} -\put(0,95){\makebox(0,0){$y$}} -\thinlines -\put(100,80){\line(-1,0){105}} -\put(100,80){\line(0,-1){85}} -\put(95,75){\makebox(0,0)[tr]{Screen}} -\put(100,-10){\makebox(0,0){\tt size\_x()}} -\put(-10,80){\makebox(0,0)[r]{\tt size\_y()}} -\put(30,40){\makebox(4,4){\rule{2mm}{2mm}}} -\put(36,40){pixel at $(x,y)$} -\put(30,40){\line(-1,0){35}} -\put(30,-10){\makebox(0,0){$x$}} -\put(30,40){\line(0,-1){45}} -\put(-10,40){\makebox(0,0)[r]{$y$}} -\end{picture} -\end{center} -\end{latexonly} - -\begin{htmlonly} -\begin{center} -\imgsrc{libgraph.gif} -\end{center} -\end{htmlonly} -% +\begin{alltt} + opam install graphics +\end{alltt} -\ifouthtml -\begin{links} -\item \ahref{libref/Graphics.html}{Module \texttt{Graphics}: machine-independent graphics primitives} -\end{links} -\else -\input{Graphics.tex} -\fi +Before OCaml 4.09, this package simply ensures that the "graphics" +library was installed by the compiler, and starting from OCaml 4.09 +this package effectively provides the "graphics" library. diff --git a/manual/manual/library/libgraph.fig b/manual/manual/library/libgraph.fig deleted file mode 100644 index 55a6d1de..00000000 --- a/manual/manual/library/libgraph.fig +++ /dev/null @@ -1,29 +0,0 @@ -#FIG 3.2 -Landscape -Center -Inches -Letter -100.00 -Single --2 -1200 2 -2 1 0 1 0 7 0 0 -1 0.000 0 0 7 1 0 2 - 1 1 1.00 60.00 120.00 - 1050 3375 4575 3375 -2 1 0 1 0 7 0 0 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 1200 3525 1200 825 -2 1 0 1 0 7 0 0 -1 0.000 0 0 7 0 0 3 - 1125 1200 3750 1200 3750 3450 -2 1 0 1 0 7 0 0 -1 0.000 0 0 -1 0 0 3 - 1125 2400 2475 2400 2475 3450 -2 2 0 1 0 0 0 0 20 0.000 0 0 7 0 0 5 - 2475 2400 2550 2400 2550 2325 2475 2325 2475 2400 -4 0 0 0 0 0 12 0.0000 4 135 525 2325 1500 Screen\001 -4 0 0 0 0 0 12 0.0000 4 180 990 2175 2250 point at (x,y)\001 -4 0 0 0 0 0 12 0.0000 4 90 90 2400 3600 x\001 -4 0 0 0 0 0 12 0.0000 4 135 90 975 2475 y\001 -4 0 0 0 0 0 12 0.0000 4 180 450 1050 750 y axis\001 -4 0 0 0 0 14 12 0.0000 4 180 840 225 1200 size_y()\001 -4 0 0 0 0 14 12 0.0000 4 165 840 3375 3600 size_x()\001 -4 0 0 0 0 0 12 0.0000 4 135 450 4650 3375 x axis\001 diff --git a/manual/manual/library/libgraph.png b/manual/manual/library/libgraph.png deleted file mode 100644 index 5841bfc8..00000000 Binary files a/manual/manual/library/libgraph.png and /dev/null differ diff --git a/manual/manual/library/libthreads.etex b/manual/manual/library/libthreads.etex index 7ad9c7e6..31113c65 100644 --- a/manual/manual/library/libthreads.etex +++ b/manual/manual/library/libthreads.etex @@ -39,14 +39,6 @@ Programs that use system threads must be linked as follows: Compilation units that use the "threads" library must also be compiled with the "-I +threads" option (see chapter~\ref{c:camlc}). -Programs that use VM-level threads must be compiled with the "-vmthread" -option to "ocamlc" (see chapter~\ref{c:camlc}), and be linked as follows: -\begin{alltt} - ocamlc -vmthread \var{other options} threads.cma \var{other files} -\end{alltt} -Compilation units that use "threads" library must also be compiled with -the "-vmthread" option (see chapter~\ref{c:camlc}). - \ifouthtml \begin{links} \item \ahref{libref/Thread.html}{Module \texttt{Thread}: lightweight threads} diff --git a/manual/manual/macros.hva b/manual/manual/macros.hva index 38b816b6..bbaf4e56 100644 --- a/manual/manual/macros.hva +++ b/manual/manual/macros.hva @@ -184,7 +184,7 @@ \newcommand{\vfill}{} \def\number{} -\def\year{2013} +\def\year{2019} % Pour alltt \def\rminalltt#1{{\rm #1}} @@ -200,4 +200,4 @@ \newenvironment{maintitle}{\@open{div}{class="maintitle"}}{\@close{div}} %%% References to modules in the standard library -\newcommand{\stdmoduleref}[1]{\ahref{libref/#1.html}{\texttt{#1}}} \ No newline at end of file +\newcommand{\stdmoduleref}[1]{\ahref{libref/#1.html}{\texttt{#1}}} diff --git a/manual/manual/refman/typedecl.etex b/manual/manual/refman/typedecl.etex index 0370a73b..f3c94174 100644 --- a/manual/manual/refman/typedecl.etex +++ b/manual/manual/refman/typedecl.etex @@ -170,7 +170,9 @@ constructors or fields given in the representation remain attached to the defined type constructor. The type expression in the equation part must agree with the representation: it must be of the same kind (record or variant) and have exactly the same constructors or fields, -in the same order, with the same arguments. +in the same order, with the same arguments. Moreover, the new type +constructor must have the same arity and the same type constraints as the +original type constructor. \end{description} The type variables appearing as type parameters can optionally be diff --git a/manual/manual/tutorials/objectexamples.etex b/manual/manual/tutorials/objectexamples.etex index 919d3b7a..7298a0d4 100644 --- a/manual/manual/tutorials/objectexamples.etex +++ b/manual/manual/tutorials/objectexamples.etex @@ -16,39 +16,6 @@ in those languages. OCaml has alternatives that are often more appropriate, such as modules and functors. Indeed, many OCaml programs do not use objects at all. - -\begin{htmlonly} - -\ref{ss:classes-and-objects} Classes and objects \\ -\ref{ss:immediate-objects} Immediate objects \\ -\ref{ss:reference-to-self} Reference to self \\ -\ref{ss:initializers} Initializers \\ -\ref{ss:virtual-methods} Virtual methods \\ -\ref{ss:private-methods} Private methods \\ -\ref{ss:class-interfaces} Class interfaces \\ -\ref{ss:inheritance} Inheritance \\ -\ref{ss:multiple-inheritance} Multiple inheritance \\ -\ref{ss:parameterized-classes} Parameterized classes \\ -\ref{ss:polymorphic-methods} Polymorphic methods \\ -\ref{ss:using-coercions} Using coercions \\ -\ref{ss:functional-objects} Functional objects \\ -\ref{ss:cloning-objects} Cloning objects \\ -\ref{ss:recursive-classes} Recursive classes \\ -\ref{ss:binary-methods} Binary methods \\ -\ref{ss:friends} Friends \\ - -%%\ref{s:advanced-examples} {\bf Advanced examples} -%% -%%\ref{ss:bank-accounts} An extended example of bank accounts \\ -%%\ref{ss:modules-as-classes} Simple modules as classes: -%% \ref{module:string} Strings -%% \ref{module:stack} Stacks -%% \ref{module:hashtbl} Hash tables -%% \ref{module:set} Sets \\ -%%\ref{ss:subject-observer} The subject/observer pattern \\ - -\end{htmlonly} - \section{Classes and objects} \label{ss:classes-and-objects} diff --git a/manual/tests/Makefile b/manual/tests/Makefile index 802f43a0..80f0c506 100644 --- a/manual/tests/Makefile +++ b/manual/tests/Makefile @@ -20,7 +20,7 @@ check-cross-references: cross-reference-checker -auxfile $(MANUAL)/texstuff/manual.aux \ $(TOPDIR)/utils/warnings.ml \ $(TOPDIR)/driver/main_args.ml \ - $(TOPDIR)/bytecomp/translmod.ml + $(TOPDIR)/lambda/translmod.ml .PHONY: check-stdlib check-stdlib: diff --git a/middle_end/alias_analysis.ml b/middle_end/alias_analysis.ml deleted file mode 100755 index fe97a36f..00000000 --- a/middle_end/alias_analysis.ml +++ /dev/null @@ -1,168 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type allocation_point = - | Symbol of Symbol.t - | Variable of Variable.t - -type allocated_const = - | Normal of Allocated_const.t - | Array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t list - | Duplicate_array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t - -type constant_defining_value = - | Allocated_const of allocated_const - | Block of Tag.t * Variable.t list - | Set_of_closures of Flambda.set_of_closures - | Project_closure of Flambda.project_closure - | Move_within_set_of_closures of Flambda.move_within_set_of_closures - | Project_var of Flambda.project_var - | Field of Variable.t * int - | Symbol_field of Symbol.t * int - | Const of Flambda.const - | Symbol of Symbol.t - | Variable of Variable.t - -type initialize_symbol_field = Variable.t option - -type definitions = { - variable : constant_defining_value Variable.Tbl.t; - initialize_symbol : initialize_symbol_field list Symbol.Tbl.t; - symbol : Flambda.constant_defining_value Symbol.Tbl.t; -} - -let print_constant_defining_value ppf = function - | Allocated_const (Normal const) -> Allocated_const.print ppf const - | Allocated_const (Array (_, _, vars)) -> - Format.fprintf ppf "[| %a |]" - (Format.pp_print_list Variable.print) vars - | Allocated_const (Duplicate_array (_, _, var)) -> - Format.fprintf ppf "dup_array(%a)" Variable.print var - | Block (tag, vars) -> - Format.fprintf ppf "[|%a: %a|]" - Tag.print tag - (Format.pp_print_list Variable.print) vars - | Set_of_closures set -> Flambda.print_set_of_closures ppf set - | Project_closure project -> Flambda.print_project_closure ppf project - | Move_within_set_of_closures move -> - Flambda.print_move_within_set_of_closures ppf move - | Project_var project -> Flambda.print_project_var ppf project - | Field (var, field) -> Format.fprintf ppf "%a.(%d)" Variable.print var field - | Symbol_field (sym, field) -> - Format.fprintf ppf "%a.(%d)" Symbol.print sym field - | Const const -> Flambda.print_const ppf const - | Symbol symbol -> Symbol.print ppf symbol - | Variable var -> Variable.print ppf var - -let rec resolve_definition - (definitions: definitions) - (var: Variable.t) - (def: constant_defining_value) - ~the_dead_constant : allocation_point = - match def with - | Allocated_const _ - | Block _ - | Set_of_closures _ - | Project_closure _ - | Const _ - | Move_within_set_of_closures _ -> - Variable var - | Project_var {var} -> - fetch_variable definitions (Var_within_closure.unwrap var) - ~the_dead_constant - | Variable v -> - fetch_variable definitions v - ~the_dead_constant - | Symbol sym -> Symbol sym - | Field (v, n) -> - begin match fetch_variable definitions v ~the_dead_constant with - | Symbol s -> - fetch_symbol_field definitions s n ~the_dead_constant - | Variable v -> - fetch_variable_field definitions v n ~the_dead_constant - end - | Symbol_field (symbol, field) -> - fetch_symbol_field definitions symbol field ~the_dead_constant - -and fetch_variable - (definitions: definitions) - (var: Variable.t) - ~the_dead_constant : allocation_point = - match Variable.Tbl.find definitions.variable var with - | exception Not_found -> Variable var - | def -> resolve_definition definitions var def ~the_dead_constant - -and fetch_variable_field - (definitions: definitions) - (var: Variable.t) - (field: int) - ~the_dead_constant : allocation_point = - match Variable.Tbl.find definitions.variable var with - | Block (_, fields) -> - begin match List.nth fields field with - | exception Not_found -> Symbol the_dead_constant - | v -> fetch_variable definitions v ~the_dead_constant - end - | exception Not_found -> - Misc.fatal_errorf "No definition for field access to %a" Variable.print var - | Symbol _ | Variable _ | Project_var _ | Field _ | Symbol_field _ -> - (* Must have been resolved *) - assert false - | Const _ | Allocated_const _ - | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ -> - Symbol the_dead_constant - -and fetch_symbol_field - (definitions: definitions) - (sym: Symbol.t) - (field: int) - ~the_dead_constant : allocation_point = - match Symbol.Tbl.find definitions.symbol sym with - | Block (_, fields) -> - begin match List.nth fields field with - | exception Not_found -> Symbol the_dead_constant - | Symbol s -> Symbol s - | Const _ -> Symbol sym - end - | exception Not_found -> - begin match Symbol.Tbl.find definitions.initialize_symbol sym with - | fields -> - begin match List.nth fields field with - | None -> - Misc.fatal_errorf "Constant field access to an inconstant %a" - Symbol.print sym - | Some v -> - fetch_variable definitions v ~the_dead_constant - end - | exception Not_found -> - Misc.fatal_errorf "No definition for field access to %a" - Symbol.print sym - end - | Allocated_const _ | Set_of_closures _ | Project_closure _ -> - Symbol the_dead_constant - -let run variable initialize_symbol symbol ~the_dead_constant = - let definitions = { variable; initialize_symbol; symbol; } in - Variable.Tbl.fold (fun var definition result -> - let definition = - resolve_definition definitions var definition ~the_dead_constant - in - Variable.Map.add var definition result) - definitions.variable - Variable.Map.empty diff --git a/middle_end/alias_analysis.mli b/middle_end/alias_analysis.mli deleted file mode 100644 index 515daeff..00000000 --- a/middle_end/alias_analysis.mli +++ /dev/null @@ -1,63 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -type allocation_point = - | Symbol of Symbol.t - | Variable of Variable.t - -type allocated_const = - | Normal of Allocated_const.t - | Array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t list - | Duplicate_array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t - -type constant_defining_value = - | Allocated_const of allocated_const - | Block of Tag.t * Variable.t list - | Set_of_closures of Flambda.set_of_closures - | Project_closure of Flambda.project_closure - | Move_within_set_of_closures of Flambda.move_within_set_of_closures - | Project_var of Flambda.project_var - | Field of Variable.t * int - | Symbol_field of Symbol.t * int - | Const of Flambda.const - | Symbol of Symbol.t - | Variable of Variable.t - -type initialize_symbol_field = Variable.t option - -(** Simple alias analysis working over information about which - symbols have been assigned to variables; and which constants have - been assigned to symbols. The return value gives the assignment - of the defining values of constants to variables. - Also see comments for [Lift_constants], whose input feeds this - pass. - - Variables found to be ill-typed accesses to other constants, for - example arising from dead code, will be pointed at [the_dead_constant]. -*) -val run - : constant_defining_value Variable.Tbl.t - -> initialize_symbol_field list Symbol.Tbl.t - -> Flambda.constant_defining_value Symbol.Tbl.t - -> the_dead_constant:Symbol.t - -> allocation_point Variable.Map.t - -val print_constant_defining_value - : Format.formatter - -> constant_defining_value - -> unit diff --git a/middle_end/allocated_const.ml b/middle_end/allocated_const.ml deleted file mode 100644 index 78dc4ee1..00000000 --- a/middle_end/allocated_const.ml +++ /dev/null @@ -1,86 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type t = - | Float of float - | Int32 of int32 - | Int64 of int64 - | Nativeint of nativeint - | Float_array of float list - | Immutable_float_array of float list - | String of string - | Immutable_string of string - -let compare_floats x1 x2 = - (* It is important to compare the bit patterns here, so as not to - be subject to bugs such as GPR#295. *) - Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2) - -let compare (x : t) (y : t) = - let rec compare_float_lists l1 l2 = - match l1, l2 with - | [], [] -> 0 - | [], _::_ -> -1 - | _::_, [] -> 1 - | h1::t1, h2::t2 -> - let c = compare_floats h1 h2 in - if c <> 0 then c else compare_float_lists t1 t2 - in - match x, y with - | Float x, Float y -> compare_floats x y - | Int32 x, Int32 y -> Int32.compare x y - | Int64 x, Int64 y -> Int64.compare x y - | Nativeint x, Nativeint y -> Nativeint.compare x y - | Float_array x, Float_array y -> compare_float_lists x y - | Immutable_float_array x, Immutable_float_array y -> compare_float_lists x y - | String x, String y -> String.compare x y - | Immutable_string x, Immutable_string y -> String.compare x y - | Float _, _ -> -1 - | _, Float _ -> 1 - | Int32 _, _ -> -1 - | _, Int32 _ -> 1 - | Int64 _, _ -> -1 - | _, Int64 _ -> 1 - | Nativeint _, _ -> -1 - | _, Nativeint _ -> 1 - | Float_array _, _ -> -1 - | _, Float_array _ -> 1 - | Immutable_float_array _, _ -> -1 - | _, Immutable_float_array _ -> 1 - | String _, _ -> -1 - | _, String _ -> 1 - -let print ppf (t : t) = - let fprintf = Format.fprintf in - let floats ppf fl = - List.iter (fun f -> fprintf ppf "@ %f" f) fl - in - match t with - | String s -> fprintf ppf "%S" s - | Immutable_string s -> fprintf ppf "#%S" s - | Int32 n -> fprintf ppf "%lil" n - | Int64 n -> fprintf ppf "%LiL" n - | Nativeint n -> fprintf ppf "%nin" n - | Float f -> fprintf ppf "%f" f - | Float_array [] -> fprintf ppf "[| |]" - | Float_array (f1 :: fl) -> - fprintf ppf "@[<1>[|@[%f%a@]|]@]" f1 floats fl - | Immutable_float_array [] -> fprintf ppf "[|# |]" - | Immutable_float_array (f1 :: fl) -> - fprintf ppf "@[<1>[|# @[%f%a@]|]@]" f1 floats fl diff --git a/middle_end/allocated_const.mli b/middle_end/allocated_const.mli deleted file mode 100644 index 0bdbe49e..00000000 --- a/middle_end/allocated_const.mli +++ /dev/null @@ -1,38 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Constants that are always allocated (possibly statically). Blocks - are not included here since they are always encoded using - [Prim (Pmakeblock, ...)]. *) - -type t = - | Float of float - | Int32 of int32 - | Int64 of int64 - | Nativeint of nativeint - (* CR-someday mshinwell: consider using "float array" *) - | Float_array of float list - | Immutable_float_array of float list - | String of string - | Immutable_string of string - -val compare_floats : float -> float -> int - -val compare : t -> t -> int - -val print : Format.formatter -> t -> unit diff --git a/middle_end/augment_specialised_args.ml b/middle_end/augment_specialised_args.ml deleted file mode 100755 index c3a30785..00000000 --- a/middle_end/augment_specialised_args.ml +++ /dev/null @@ -1,762 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module E = Inline_and_simplify_aux.Env -module B = Inlining_cost.Benefit - -module Definition = struct - type t = - | Existing_inner_free_var of Variable.t - | Projection_from_existing_specialised_arg of Projection.t - - include Identifiable.Make (struct - type nonrec t = t - - let compare t1 t2 = - match t1, t2 with - | Existing_inner_free_var var1, Existing_inner_free_var var2 -> - Variable.compare var1 var2 - | Projection_from_existing_specialised_arg proj1, - Projection_from_existing_specialised_arg proj2 -> - Projection.compare proj1 proj2 - | Existing_inner_free_var _, _ -> -1 - | _, Existing_inner_free_var _ -> 1 - - let equal t1 t2 = - (compare t1 t2) = 0 - - let hash = Hashtbl.hash - - let print ppf t = - match t with - | Existing_inner_free_var var -> - Format.fprintf ppf "Existing_inner_free_var %a" - Variable.print var - | Projection_from_existing_specialised_arg projection -> - Format.fprintf ppf "Projection_from_existing_specialised_arg %a" - Projection.print projection - - let output _ _ = failwith "Definition.output not yet implemented" - end) -end - -module What_to_specialise = struct - type t = { - (* [definitions] is indexed by (fun_var, group) *) - definitions : Definition.t list Variable.Pair.Map.t; - set_of_closures : Flambda.set_of_closures; - make_direct_call_surrogates_for : Variable.Set.t; - } - - let create ~set_of_closures = - { definitions = Variable.Pair.Map.empty; - set_of_closures; - make_direct_call_surrogates_for = Variable.Set.empty; - } - - let new_specialised_arg t ~fun_var ~group ~definition = - let key = fun_var, group in - let definitions = - match Variable.Pair.Map.find key t.definitions with - | exception Not_found -> [] - | definitions -> definitions - in - let definitions = - Variable.Pair.Map.add (fun_var, group) (definition :: definitions) - t.definitions - in - { t with definitions; } - - let make_direct_call_surrogate_for t ~fun_var = - match Variable.Map.find fun_var t.set_of_closures.function_decls.funs with - | exception Not_found -> - Misc.fatal_errorf "use_direct_call_surrogate_for: %a is not a fun_var \ - from the given set of closures" - Variable.print fun_var - | _ -> - { t with - make_direct_call_surrogates_for = - Variable.Set.add fun_var t.make_direct_call_surrogates_for; - } -end - -module W = What_to_specialise - -module type S = sig - val pass_name : string - - val what_to_specialise - : env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> What_to_specialise.t -end - -module Processed_what_to_specialise = struct - type for_one_function = { - fun_var : Variable.t; - function_decl : Flambda.function_declaration; - make_direct_call_surrogates : bool; - new_definitions_indexed_by_new_inner_vars : Definition.t Variable.Map.t; - all_new_definitions : Definition.Set.t; - new_inner_to_new_outer_vars : Variable.t Variable.Map.t; - total_number_of_args : int; - existing_specialised_args : Flambda.specialised_to Variable.Map.t; - } - - type t = { - set_of_closures : Flambda.set_of_closures; - existing_definitions_via_spec_args_indexed_by_fun_var - : Definition.Set.t Variable.Map.t; - (* The following two maps' definitions have already been rewritten - into their lifted form (i.e. they reference outer rather than inner - variables). *) - new_lifted_defns_indexed_by_new_outer_vars : Projection.t Variable.Map.t; - new_outer_vars_indexed_by_new_lifted_defns : Variable.t Projection.Map.t; - functions : for_one_function Variable.Map.t; - make_direct_call_surrogates_for : Variable.Set.t; - } - - let lift_projection t ~(projection : Projection.t) = - (* The lifted definition must be in terms of outer variables, - not inner variables. *) - let find_outer_var inner_var = - match Variable.Map.find inner_var t.set_of_closures.specialised_args with - | (outer_var : Flambda.specialised_to) -> outer_var.var - | exception Not_found -> - Misc.fatal_errorf "find_outer_var: expected %a \ - to be in [specialised_args], but it is \ - not. The projection was: %a. Set of closures: %a" - Variable.print inner_var - Projection.print projection - Flambda.print_set_of_closures t.set_of_closures - in - Projection.map_projecting_from projection ~f:find_outer_var - - let really_add_new_specialised_arg t ~group ~(definition : Definition.t) - ~(for_one_function : for_one_function) = - let fun_var = for_one_function.fun_var in - (* We know here that a new specialised argument must be added. This - needs a "new inner var" and a "new outer var". However if there - is already a lifted projection being introduced around the set - of closures (corresponding to another new specialised argument), - we should re-use its "new outer var" to avoid duplication of - projection definitions. Likewise if the definition is just - [Existing_inner_free_var], in which case we can use the - corresponding existing outer free variable. *) - let new_outer_var, t = - let existing_outer_var = - match definition with - | Existing_inner_free_var _ -> None - | Projection_from_existing_specialised_arg projection -> - let projection = lift_projection t ~projection in - match - Projection.Map.find projection - t.new_outer_vars_indexed_by_new_lifted_defns - with - | new_outer_var -> Some new_outer_var - | exception Not_found -> None - in - match existing_outer_var with - | Some existing_outer_var -> existing_outer_var, t - | None -> - match definition with - | Existing_inner_free_var existing_inner_var -> - begin match - Variable.Map.find existing_inner_var - t.set_of_closures.free_vars - with - | exception Not_found -> - Misc.fatal_errorf "really_add_new_specialised_arg: \ - Existing_inner_free_var %a is not an inner free variable \ - of %a in %a" - Variable.print existing_inner_var - Variable.print fun_var - Flambda.print_set_of_closures t.set_of_closures - | existing_outer_var -> existing_outer_var.var, t - end - | Projection_from_existing_specialised_arg projection -> - let new_outer_var = Variable.rename group in - let projection = lift_projection t ~projection in - let new_outer_vars_indexed_by_new_lifted_defns = - Projection.Map.add - projection new_outer_var - t.new_outer_vars_indexed_by_new_lifted_defns - in - let new_lifted_defns_indexed_by_new_outer_vars = - Variable.Map.add - new_outer_var projection - t.new_lifted_defns_indexed_by_new_outer_vars - in - let t = - { t with - new_outer_vars_indexed_by_new_lifted_defns; - new_lifted_defns_indexed_by_new_outer_vars; - } - in - new_outer_var, t - in - let new_inner_var = Variable.rename group in - let new_inner_to_new_outer_vars = - Variable.Map.add new_inner_var new_outer_var - for_one_function.new_inner_to_new_outer_vars - in - let for_one_function : for_one_function = - { for_one_function with - new_definitions_indexed_by_new_inner_vars = - Variable.Map.add new_inner_var definition - for_one_function.new_definitions_indexed_by_new_inner_vars; - all_new_definitions = - Definition.Set.add definition - for_one_function.all_new_definitions; - new_inner_to_new_outer_vars; - total_number_of_args = for_one_function.total_number_of_args + 1; - } - in - { t with - functions = Variable.Map.add fun_var for_one_function t.functions; - } - - let new_specialised_arg t ~fun_var ~group ~definition = - let for_one_function : for_one_function = - match Variable.Map.find fun_var t.functions with - | exception Not_found -> - begin - match Variable.Map.find fun_var t.set_of_closures.function_decls.funs - with - | exception Not_found -> assert false - | (function_decl : Flambda.function_declaration) -> - let params = Parameter.Set.vars function_decl.params in - let existing_specialised_args = - Variable.Map.filter (fun inner_var _spec_to -> - Variable.Set.mem inner_var params) - t.set_of_closures.specialised_args - in - let make_direct_call_surrogates = - Variable.Set.mem fun_var t.make_direct_call_surrogates_for - in - { fun_var; - function_decl; - make_direct_call_surrogates; - new_definitions_indexed_by_new_inner_vars = Variable.Map.empty; - all_new_definitions = Definition.Set.empty; - new_inner_to_new_outer_vars = Variable.Map.empty; - (* The "+ 1" is just in case there is a closure environment - parameter added later. *) - total_number_of_args = List.length function_decl.params + 1; - existing_specialised_args; - } - end - | for_one_function -> for_one_function - in - (* Determine whether there already exists an existing specialised argument - that is known to be equal to the one proposed to this function. If so, - use that instead. (Note that we also desire to dedup against any - new specialised arguments added to the current function; but that - happens automatically since [Extract_projections] returns a set.) *) - let exists_already = - match - Variable.Map.find fun_var - t.existing_definitions_via_spec_args_indexed_by_fun_var - with - | exception Not_found -> false - | definitions -> Definition.Set.mem definition definitions - in - if exists_already then t - else really_add_new_specialised_arg t ~group ~definition ~for_one_function - - let create ~env ~(what_to_specialise : W.t) = - let existing_definitions_via_spec_args_indexed_by_fun_var = - Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> - if function_decl.stub then - Definition.Set.empty - else - let params = Parameter.Set.vars function_decl.params in - Variable.Map.fold (fun inner_var - (spec_to : Flambda.specialised_to) definitions -> - if not (Variable.Set.mem inner_var params) then - definitions - else - let definition : Definition.t = - match spec_to.projection with - | None -> Existing_inner_free_var inner_var - | Some projection -> - Projection_from_existing_specialised_arg projection - in - Definition.Set.add definition definitions) - what_to_specialise.set_of_closures.specialised_args - Definition.Set.empty) - what_to_specialise.set_of_closures.function_decls.funs - in - let t : t = - { set_of_closures = what_to_specialise.set_of_closures; - existing_definitions_via_spec_args_indexed_by_fun_var; - new_lifted_defns_indexed_by_new_outer_vars = Variable.Map.empty; - new_outer_vars_indexed_by_new_lifted_defns = Projection.Map.empty; - functions = Variable.Map.empty; - make_direct_call_surrogates_for = - what_to_specialise.make_direct_call_surrogates_for; - } - in - (* It is important to limit the number of arguments added: if arguments - end up being passed on the stack, tail call optimization will be - disabled (see asmcomp/selectgen.ml). - For each group of new specialised args provided by [T], either all or - none of them will be added. (This is to avoid the situation where we - add extra arguments but yet fail to eliminate an original one by - stopping part-way through the specialised args addition.) *) - let by_group = - Variable.Pair.Map.fold (fun (fun_var, group) definitions by_group -> - let fun_vars_and_definitions = - match Variable.Map.find group by_group with - | exception Not_found -> [] - | fun_vars_and_definitions -> fun_vars_and_definitions - in - Variable.Map.add group - ((fun_var, definitions)::fun_vars_and_definitions) - by_group) - what_to_specialise.definitions - Variable.Map.empty - in - let module Backend = (val (E.backend env) : Backend_intf.S) in - Variable.Map.fold (fun group fun_vars_and_definitions t -> - let original_t = t in - let t = - (* Try adding all specialised args in the current group. *) - List.fold_left (fun t (fun_var, definitions) -> - List.fold_left (fun t definition -> - new_specialised_arg t ~fun_var ~group ~definition) - t - definitions) - t - fun_vars_and_definitions - in - let some_function_has_too_many_args = - Variable.Map.exists (fun _ (for_one_function : for_one_function) -> - for_one_function.total_number_of_args - > Backend.max_sensible_number_of_arguments) - t.functions - in - if some_function_has_too_many_args then - original_t (* drop this group *) - else - t) - by_group - t -end - -module P = Processed_what_to_specialise - -let check_invariants ~pass_name ~(set_of_closures : Flambda.set_of_closures) - ~original_set_of_closures = - if !Clflags.flambda_invariant_checks then begin - Variable.Map.iter (fun fun_var - (function_decl : Flambda.function_declaration) -> - let params = Parameter.Set.vars function_decl.params in - Variable.Map.iter (fun inner_var - (outer_var : Flambda.specialised_to) -> - if Variable.Set.mem inner_var params then begin - assert (not (Variable.Set.mem outer_var.var - function_decl.free_variables)); - match outer_var.projection with - | None -> () - | Some projection -> - let from = Projection.projecting_from projection in - if not (Variable.Set.mem from params) then begin - Misc.fatal_errorf "Augment_specialised_args (%s): \ - specialised argument (%a -> %a) references a \ - projection variable that is not a specialised \ - argument of the function %a. @ The set of closures \ - before the transformation was:@ %a. @ The set of \ - closures after the transformation was:@ %a." - pass_name - Variable.print inner_var - Flambda.print_specialised_to outer_var - Variable.print fun_var - Flambda.print_set_of_closures original_set_of_closures - Flambda.print_set_of_closures set_of_closures - end - end) - set_of_closures.specialised_args) - set_of_closures.function_decls.funs - end - -module Make (T : S) = struct - let () = Pass_wrapper.register ~pass_name:T.pass_name - - let rename_function_and_parameters ~fun_var - ~(function_decl : Flambda.function_declaration) = - let new_fun_var = Variable.rename fun_var in - let params_renaming_list = - List.map (fun param -> - let new_param = Parameter.rename param in - param, new_param) - function_decl.params - in - let renamed_params = List.map snd params_renaming_list in - let params_renaming = - Variable.Map.of_list - (List.map (fun (param, new_param) -> - Parameter.var param, Parameter.var new_param) - params_renaming_list) - in - new_fun_var, params_renaming, renamed_params - - let create_wrapper ~(for_one_function : P.for_one_function) ~benefit = - let fun_var = for_one_function.fun_var in - let function_decl = for_one_function.function_decl in - (* To avoid increasing the free variables of the wrapper, for - general cleanliness, we restate the definitions of the - newly-specialised arguments in the wrapper itself in terms of the - original specialised arguments. The variables bound to these - definitions are called the "specialised args bound in the wrapper". - Note that the domain of [params_renaming] is a (non-strict) superset - of the "inner vars" of the original specialised args. *) - let params = Parameter.Set.vars function_decl.params in - let new_fun_var, params_renaming, wrapper_params = - rename_function_and_parameters ~fun_var ~function_decl - in - let find_wrapper_param param = - assert (Variable.Set.mem param params); - match Variable.Map.find param params_renaming with - | wrapper_param -> wrapper_param - | exception Not_found -> - Misc.fatal_errorf "find_wrapper_param: expected %a \ - to be in [params_renaming], but it is not." - Variable.print param - in - let new_inner_vars_to_spec_args_bound_in_the_wrapper_renaming = - Variable.Map.mapi (fun new_inner_var _ -> - Variable.rename new_inner_var) - for_one_function.new_definitions_indexed_by_new_inner_vars - in - let spec_args_bound_in_the_wrapper = - (* N.B.: in the order matching the new specialised argument parameters - to the main function. *) - Variable.Map.data - new_inner_vars_to_spec_args_bound_in_the_wrapper_renaming - in - (* New definitions that project from existing specialised args need - to be rewritten to use the corresponding specialised args of - the wrapper. Definitions that are just equality to existing - inner free variables do not need to be changed. Once this has - been done the wrapper body can be constructed. - We also need to rewrite definitions for any existing specialised - args; these now have corresponding wrapper parameters that must - also be specialised. *) - let wrapper_body, benefit = - let apply : Flambda.expr = - Apply { - func = new_fun_var; - args = - (Parameter.List.vars wrapper_params) @ - spec_args_bound_in_the_wrapper; - kind = Direct (Closure_id.wrap new_fun_var); - dbg = Debuginfo.none; - inline = Default_inline; - specialise = Default_specialise; - } - in - Variable.Map.fold (fun new_inner_var definition (wrapper_body, benefit) -> - let definition : Definition.t = - match (definition : Definition.t) with - | Existing_inner_free_var _ -> definition - | Projection_from_existing_specialised_arg projection -> - Projection_from_existing_specialised_arg - (Projection.map_projecting_from projection - ~f:find_wrapper_param) - in - let benefit = - match (definition : Definition.t) with - | Existing_inner_free_var _ -> benefit - | Projection_from_existing_specialised_arg projection -> - B.add_projection projection benefit - in - match - Variable.Map.find new_inner_var - new_inner_vars_to_spec_args_bound_in_the_wrapper_renaming - with - | exception Not_found -> assert false - | new_inner_var_of_wrapper -> - let named : Flambda.named = - match definition with - | Existing_inner_free_var existing_inner_var -> - Expr (Var existing_inner_var) - | Projection_from_existing_specialised_arg projection -> - Flambda_utils.projection_to_named projection - in - let wrapper_body = - Flambda.create_let new_inner_var_of_wrapper named wrapper_body - in - (wrapper_body, benefit)) - for_one_function.new_definitions_indexed_by_new_inner_vars - (apply, benefit) - in - let rewritten_existing_specialised_args = - Variable.Map.fold (fun inner_var (spec_to : Flambda.specialised_to) - result -> - let inner_var = find_wrapper_param inner_var in - let projection = - match spec_to.projection with - | None -> None - | Some projection -> - Some (Projection.map_projecting_from projection - ~f:find_wrapper_param) - in - let spec_to : Flambda.specialised_to = - { var = spec_to.var; - projection; - } - in - Variable.Map.add inner_var spec_to result) - for_one_function.existing_specialised_args - Variable.Map.empty - in - let new_function_decl = - Flambda.create_function_declaration - ~params:wrapper_params - ~body:wrapper_body - ~stub:true - ~dbg:Debuginfo.none - ~inline:Default_inline - ~specialise:Default_specialise - ~is_a_functor:false - ~closure_origin:function_decl.closure_origin - in - new_fun_var, new_function_decl, rewritten_existing_specialised_args, - benefit - - let rewrite_function_decl (t : P.t) ~env ~duplicate_function - ~(for_one_function : P.for_one_function) ~benefit = - let set_of_closures = t.set_of_closures in - let fun_var = for_one_function.fun_var in - let function_decl = for_one_function.function_decl in - let num_definitions = - Variable.Map.cardinal for_one_function. - new_definitions_indexed_by_new_inner_vars - in - if function_decl.stub - || num_definitions < 1 - || Variable.Map.mem fun_var set_of_closures.direct_call_surrogates - then - None - else - let new_fun_var, wrapper, rewritten_existing_specialised_args, benefit = - create_wrapper ~for_one_function ~benefit - in - let new_specialised_args = - Variable.Map.mapi (fun new_inner_var (definition : Definition.t) - : Flambda.specialised_to -> - assert (not (Variable.Map.mem new_inner_var - set_of_closures.specialised_args)); - match - Variable.Map.find new_inner_var - for_one_function.new_inner_to_new_outer_vars - with - | exception Not_found -> assert false - | new_outer_var -> - match definition with - | Existing_inner_free_var _ -> - { var = new_outer_var; - projection = None; - } - | Projection_from_existing_specialised_arg projection -> - let projecting_from = Projection.projecting_from projection in - assert (Variable.Map.mem projecting_from - set_of_closures.specialised_args); - assert (Variable.Set.mem projecting_from - (Parameter.Set.vars function_decl.params)); - { var = new_outer_var; - projection = Some projection; - }) - for_one_function.new_definitions_indexed_by_new_inner_vars - in - let specialised_args = - Variable.Map.disjoint_union rewritten_existing_specialised_args - new_specialised_args - in - let specialised_args, existing_function_decl = - if not for_one_function.make_direct_call_surrogates then - specialised_args, None - else - let function_decl, new_specialised_args = - duplicate_function ~env ~set_of_closures ~fun_var ~new_fun_var - in - let specialised_args = - Variable.Map.disjoint_union specialised_args new_specialised_args - in - specialised_args, Some function_decl - in - let all_params = - let new_params = - Variable.Set.elements (Variable.Map.keys - for_one_function.new_inner_to_new_outer_vars) - in - let new_params = - List.map Parameter.wrap new_params - in - function_decl.params @ new_params - in - let closure_origin = - Closure_origin.create (Closure_id.wrap new_fun_var) - in - let rewritten_function_decl = - Flambda.create_function_declaration - ~params:all_params - ~body:function_decl.body - ~stub:function_decl.stub - ~dbg:function_decl.dbg - ~inline:function_decl.inline - ~specialise:function_decl.specialise - ~is_a_functor:function_decl.is_a_functor - ~closure_origin - in - let funs, direct_call_surrogates = - if for_one_function.make_direct_call_surrogates then - let surrogate = Variable.rename fun_var in - let funs = - (* In this case, the original function declaration remains - untouched up to alpha-equivalence. Direct calls to it - (including inside the rewritten original function) will be - replaced by calls to the surrogate (i.e. the wrapper) which - will then be inlined. *) - let existing_function_decl = - match existing_function_decl with - | Some decl -> decl - | None -> assert false - in - Variable.Map.add new_fun_var rewritten_function_decl - (Variable.Map.add surrogate wrapper - (Variable.Map.add fun_var existing_function_decl - Variable.Map.empty)) - in - let direct_call_surrogates = - Variable.Map.add fun_var surrogate Variable.Map.empty - in - funs, direct_call_surrogates - else - let funs = - Variable.Map.add new_fun_var rewritten_function_decl - (Variable.Map.add fun_var wrapper Variable.Map.empty) - in - funs, Variable.Map.empty - in - let free_vars = Variable.Map.empty in - Some (funs, free_vars, specialised_args, direct_call_surrogates, benefit) - - let add_lifted_projections_around_set_of_closures - ~(set_of_closures : Flambda.set_of_closures) ~benefit - ~new_lifted_defns_indexed_by_new_outer_vars = - let body = - Flambda_utils.name_expr - ~name:Internal_variable_names.set_of_closures - (Set_of_closures set_of_closures) - in - Variable.Map.fold (fun new_outer_var (projection : Projection.t) - (expr, benefit) -> - let named = Flambda_utils.projection_to_named projection in - let benefit = B.add_projection projection benefit in - let expr = Flambda.create_let new_outer_var named expr in - expr, benefit) - new_lifted_defns_indexed_by_new_outer_vars - (body, benefit) - - let rewrite_set_of_closures_core ~env ~duplicate_function ~benefit - ~(set_of_closures : Flambda.set_of_closures) = - let what_to_specialise = - P.create ~env - ~what_to_specialise:(T.what_to_specialise ~env ~set_of_closures) - in - let original_set_of_closures = set_of_closures in - let funs, free_vars, specialised_args, direct_call_surrogates, - done_something, benefit = - Variable.Map.fold (fun fun_var function_decl - (funs, free_vars, specialised_args, direct_call_surrogates, - done_something, benefit) -> - match Variable.Map.find fun_var what_to_specialise.functions with - | exception Not_found -> - let funs = Variable.Map.add fun_var function_decl funs in - funs, free_vars, specialised_args, direct_call_surrogates, - done_something, benefit - | (for_one_function : P.for_one_function) -> - assert (Variable.equal fun_var for_one_function.fun_var); - match - rewrite_function_decl what_to_specialise ~env - ~duplicate_function ~for_one_function ~benefit - with - | None -> - let function_decl = for_one_function.function_decl in - let funs = Variable.Map.add fun_var function_decl funs in - funs, free_vars, specialised_args, direct_call_surrogates, - done_something, benefit - | Some (funs', free_vars', specialised_args', - direct_call_surrogates', benefit) -> - let funs = Variable.Map.disjoint_union funs funs' in - let direct_call_surrogates = - Variable.Map.disjoint_union direct_call_surrogates - direct_call_surrogates' - in - let free_vars = - Variable.Map.disjoint_union free_vars free_vars' - in - let specialised_args = - Variable.Map.disjoint_union specialised_args specialised_args' - in - funs, free_vars, specialised_args, direct_call_surrogates, true, - benefit) - set_of_closures.function_decls.funs - (Variable.Map.empty, set_of_closures.free_vars, - set_of_closures.specialised_args, - set_of_closures.direct_call_surrogates, false, benefit) - in - if not done_something then - None - else - let function_decls = - Flambda.update_function_declarations set_of_closures.function_decls - ~funs - in - assert (Variable.Map.cardinal specialised_args - >= Variable.Map.cardinal original_set_of_closures.specialised_args); - let set_of_closures = - Flambda.create_set_of_closures - ~function_decls - ~free_vars - ~specialised_args - ~direct_call_surrogates - in - if !Clflags.flambda_invariant_checks then begin - check_invariants ~set_of_closures ~original_set_of_closures - ~pass_name:T.pass_name - end; - let expr, benefit = - add_lifted_projections_around_set_of_closures ~set_of_closures ~benefit - ~new_lifted_defns_indexed_by_new_outer_vars: - what_to_specialise.new_lifted_defns_indexed_by_new_outer_vars - in - Some (expr, benefit) - - let rewrite_set_of_closures ~env ~duplicate_function ~set_of_closures = - Pass_wrapper.with_dump ~ppf_dump:(Inline_and_simplify_aux.Env.ppf_dump env) - ~pass_name:T.pass_name ~input:set_of_closures - ~print_input:Flambda.print_set_of_closures - ~print_output:(fun ppf (expr, _) -> Flambda.print ppf expr) - ~f:(fun () -> - rewrite_set_of_closures_core ~env ~duplicate_function - ~benefit:B.zero ~set_of_closures) -end diff --git a/middle_end/augment_specialised_args.mli b/middle_end/augment_specialised_args.mli deleted file mode 100644 index 5c48a126..00000000 --- a/middle_end/augment_specialised_args.mli +++ /dev/null @@ -1,65 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Helper module for adding specialised arguments to sets of closures. *) - -module Definition : sig - type t = - | Existing_inner_free_var of Variable.t - | Projection_from_existing_specialised_arg of Projection.t -end - -module What_to_specialise : sig - type t - - val create - : set_of_closures:Flambda.set_of_closures - -> t - - val new_specialised_arg - : t - -> fun_var:Variable.t - -> group:Variable.t - -> definition:Definition.t (* [projecting_from] "existing inner vars" *) - -> t - - val make_direct_call_surrogate_for : t -> fun_var:Variable.t -> t -end - -module type S = sig - val pass_name : string - - val what_to_specialise - : env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> What_to_specialise.t -end - -module Make (T : S) : sig - (** [duplicate_function] should be - [Inline_and_simplify.duplicate_function]. *) - val rewrite_set_of_closures - : env:Inline_and_simplify_aux.Env.t - -> duplicate_function:( - env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> fun_var:Variable.t - -> new_fun_var:Variable.t - -> Flambda.function_declaration - * Flambda.specialised_to Variable.Map.t) - -> set_of_closures:Flambda.set_of_closures - -> (Flambda.expr * Inlining_cost.Benefit.t) option -end diff --git a/middle_end/backend_intf.mli b/middle_end/backend_intf.mli old mode 100755 new mode 100644 diff --git a/middle_end/backend_var.ml b/middle_end/backend_var.ml new file mode 100644 index 00000000..39af7f60 --- /dev/null +++ b/middle_end/backend_var.ml @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, 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. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +include Ident + +type backend_var = t + +module Provenance = struct + type t = { + module_path : Path.t; + location : Debuginfo.t; + original_ident : Ident.t; + } + + let print ppf { module_path; location; original_ident; } = + Format.fprintf ppf "@[(\ + @[(module_path@ %a)@]@ \ + @[(location@ %a)@]@ \ + @[(original_ident@ %a)@]\ + )@]" + Path.print module_path + Debuginfo.print_compact location + Ident.print original_ident + + let create ~module_path ~location ~original_ident = + { module_path; + location; + original_ident; + } + + let module_path t = t.module_path + let location t = t.location + let original_ident t = t.original_ident +end + +module With_provenance = struct + type t = + | Without_provenance of backend_var + | With_provenance of { + var : backend_var; + provenance : Provenance.t; + } + + let create ?provenance var = + match provenance with + | None -> Without_provenance var + | Some provenance -> With_provenance { var; provenance; } + + let var t = + match t with + | Without_provenance var + | With_provenance { var; provenance = _; } -> var + + let provenance t = + match t with + | Without_provenance _ -> None + | With_provenance { var = _; provenance; } -> Some provenance + + let name t = name (var t) + + let rename t = + let var = rename (var t) in + match provenance t with + | None -> Without_provenance var + | Some provenance -> With_provenance { var; provenance; } + + let print ppf t = + match provenance t with + | None -> print ppf (var t) + | Some provenance -> + Format.fprintf ppf "%a[%a]" + print (var t) + Provenance.print provenance +end diff --git a/middle_end/backend_var.mli b/middle_end/backend_var.mli new file mode 100644 index 00000000..f236be1e --- /dev/null +++ b/middle_end/backend_var.mli @@ -0,0 +1,54 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, 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. *) +(* *) +(**************************************************************************) + +(** Variables used in the backend, optionally equipped with "provenance" + information, used for the emission of debugging information. *) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +include module type of struct include Ident end + +type backend_var = t + +module Provenance : sig + type t + + val create + : module_path:Path.t + -> location:Debuginfo.t + -> original_ident:Ident.t + -> t + + val module_path : t -> Path.t + val location : t -> Debuginfo.t + val original_ident : t -> Ident.t + + val print : Format.formatter -> t -> unit +end + +module With_provenance : sig + (** Values of type [t] should be used for variables in binding position. *) + type t + + val print : Format.formatter -> t -> unit + + val create : ?provenance:Provenance.t -> backend_var -> t + + val var : t -> backend_var + val provenance : t -> Provenance.t option + + val name : t -> string + + val rename : t -> t +end diff --git a/middle_end/base_types/closure_element.ml b/middle_end/base_types/closure_element.ml deleted file mode 100644 index 561e0803..00000000 --- a/middle_end/base_types/closure_element.ml +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -include Variable - -let wrap t = t -let unwrap t = t - -let wrap_map t = t -let unwrap_set t = t diff --git a/middle_end/base_types/closure_element.mli b/middle_end/base_types/closure_element.mli deleted file mode 100644 index d78dd9b3..00000000 --- a/middle_end/base_types/closure_element.mli +++ /dev/null @@ -1,32 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -include Identifiable.S - -val wrap : Variable.t -> t -val unwrap : t -> Variable.t - -val wrap_map : 'a Variable.Map.t -> 'a Map.t -val unwrap_set : Set.t -> Variable.Set.t - -val in_compilation_unit : t -> Compilation_unit.t -> bool -val get_compilation_unit : t -> Compilation_unit.t - -val unique_name : t -> string - -val output_full : out_channel -> t -> unit diff --git a/middle_end/base_types/closure_id.ml b/middle_end/base_types/closure_id.ml deleted file mode 100644 index 466f59a2..00000000 --- a/middle_end/base_types/closure_id.ml +++ /dev/null @@ -1,20 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -include Closure_element diff --git a/middle_end/base_types/closure_id.mli b/middle_end/base_types/closure_id.mli deleted file mode 100644 index 853a07f7..00000000 --- a/middle_end/base_types/closure_id.mli +++ /dev/null @@ -1,27 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** CR-someday lwhite: "Closure_id" is quite a generic name. I wonder - whether something like "Closure_label" would better capture that it is - the label of a projection. *) - -(** An identifier, unique across the whole program (not just one compilation - unit), that identifies a closure within a particular set of closures - (viz. [Project_closure]). *) - -include module type of Closure_element diff --git a/middle_end/base_types/closure_origin.ml b/middle_end/base_types/closure_origin.ml deleted file mode 100644 index 2285c687..00000000 --- a/middle_end/base_types/closure_origin.ml +++ /dev/null @@ -1,22 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell, Leo White and Fu Yong Quah, Jane Street Europe *) -(* *) -(* Copyright 2013--2017 OCamlPro SAS *) -(* Copyright 2014--2017 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -include Closure_id - -let create t = t diff --git a/middle_end/base_types/closure_origin.mli b/middle_end/base_types/closure_origin.mli deleted file mode 100644 index 86fcd56c..00000000 --- a/middle_end/base_types/closure_origin.mli +++ /dev/null @@ -1,21 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell, Leo White and Fu Yong Quah, Jane Street Europe *) -(* *) -(* Copyright 2013--2017 OCamlPro SAS *) -(* Copyright 2014--2017 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -include Identifiable.S - -val create : Closure_id.t -> t - -val get_compilation_unit : t -> Compilation_unit.t diff --git a/middle_end/base_types/compilation_unit.ml b/middle_end/base_types/compilation_unit.ml deleted file mode 100644 index 7fb48167..00000000 --- a/middle_end/base_types/compilation_unit.ml +++ /dev/null @@ -1,78 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type t = { - id : Ident.t; - linkage_name : Linkage_name.t; - hash : int; -} - -let string_for_printing t = Ident.name t.id - -include Identifiable.Make (struct - type nonrec t = t - - (* Multiple units can have the same [id] if they come from different packs. - To distinguish these we also keep the linkage name, which contains the - name of the pack. *) - let compare v1 v2 = - if v1 == v2 then 0 - else - let c = compare v1.hash v2.hash in - if c = 0 then - let v1_id = Ident.name v1.id in - let v2_id = Ident.name v2.id in - let c = String.compare v1_id v2_id in - if c = 0 then - Linkage_name.compare v1.linkage_name v2.linkage_name - else - c - else c - - let equal x y = - if x == y then true - else compare x y = 0 - - let print ppf t = Format.pp_print_string ppf (string_for_printing t) - - let output oc x = output_string oc (Ident.name x.id) - let hash x = x.hash -end) - -let create (id : Ident.t) linkage_name = - if not (Ident.persistent id) then begin - Misc.fatal_error "Compilation_unit.create with non-persistent Ident.t" - end; - { id; linkage_name; hash = Hashtbl.hash (Ident.name id); } - -let get_persistent_ident cu = cu.id -let get_linkage_name cu = cu.linkage_name - -let current = ref None -let is_current arg = - match !current with - | None -> Misc.fatal_error "Current compilation unit is not set!" - | Some cur -> equal cur arg -let set_current t = current := Some t -let get_current () = !current -let get_current_exn () = - match !current with - | Some current -> current - | None -> Misc.fatal_error "Compilation_unit.get_current_exn" -let get_current_id_exn () = get_persistent_ident (get_current_exn ()) diff --git a/middle_end/base_types/compilation_unit.mli b/middle_end/base_types/compilation_unit.mli deleted file mode 100644 index fc7d3bfd..00000000 --- a/middle_end/base_types/compilation_unit.mli +++ /dev/null @@ -1,34 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -include Identifiable.S - -(* The [Ident.t] must be persistent. This function raises an exception - if that is not the case. *) -val create : Ident.t -> Linkage_name.t -> t - -val get_persistent_ident : t -> Ident.t -val get_linkage_name : t -> Linkage_name.t - -val is_current : t -> bool -val set_current : t -> unit -val get_current : unit -> t option -val get_current_exn : unit -> t -val get_current_id_exn : unit -> Ident.t - -val string_for_printing : t -> string diff --git a/middle_end/base_types/export_id.ml b/middle_end/base_types/export_id.ml deleted file mode 100644 index 681ac955..00000000 --- a/middle_end/base_types/export_id.ml +++ /dev/null @@ -1,29 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module Id : Id_types.Id = Id_types.Id (struct end) -module Unit_id = Id_types.UnitId (Id) (Compilation_unit) - -type t = Unit_id.t - -include Identifiable.Make (Unit_id) - -let create = Unit_id.create -let get_compilation_unit = Unit_id.unit -let name = Unit_id.name diff --git a/middle_end/base_types/export_id.mli b/middle_end/base_types/export_id.mli deleted file mode 100644 index 54c14418..00000000 --- a/middle_end/base_types/export_id.mli +++ /dev/null @@ -1,28 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(* Keys representing value descriptions that may be written into - intermediate files and loaded by a dependent compilation unit. - These keys are used to ensure maximal sharing of value descriptions, - which may be substantial. *) - -include Identifiable.S - -val create : ?name:string -> Compilation_unit.t -> t -val name : t -> string option -val get_compilation_unit : t -> Compilation_unit.t diff --git a/middle_end/base_types/id_types.ml b/middle_end/base_types/id_types.ml deleted file mode 100644 index 6d2e2743..00000000 --- a/middle_end/base_types/id_types.ml +++ /dev/null @@ -1,93 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module type BaseId = sig - type t - val equal : t -> t -> bool - val compare : t -> t -> int - val hash : t -> int - val name : t -> string option - val to_string : t -> string - val output : out_channel -> t -> unit - val print : Format.formatter -> t -> unit -end - -module type Id = sig - include BaseId - val create : ?name:string -> unit -> t -end - -module type UnitId = sig - module Compilation_unit : Identifiable.Thing - include BaseId - val create : ?name:string -> Compilation_unit.t -> t - val unit : t -> Compilation_unit.t -end - -module Id(E:sig end) : Id = struct - type t = int * string - let empty_string = "" - let create = let r = ref 0 in - fun ?(name=empty_string) () -> incr r; !r, name - let equal (t1,_) (t2,_) = (t1:int) = t2 - let compare (t1,_) (t2,_) = t1 - t2 - let hash (t,_) = t - let name (_,name) = - if name == empty_string - then None - else Some name - let to_string (t,name) = - if name == empty_string - then Int.to_string t - else Printf.sprintf "%s_%i" name t - let output fd t = output_string fd (to_string t) - let print ppf v = Format.pp_print_string ppf (to_string v) -end - -module UnitId(Innerid:Id)(Compilation_unit:Identifiable.Thing) : - UnitId with module Compilation_unit := Compilation_unit = struct - type t = { - id : Innerid.t; - unit : Compilation_unit.t; - } - let compare x y = - let c = Innerid.compare x.id y.id in - if c <> 0 - then c - else Compilation_unit.compare x.unit y.unit - let output oc x = - Printf.fprintf oc "%a.%a" - Compilation_unit.output x.unit - Innerid.output x.id - let print ppf x = - Format.fprintf ppf "%a.%a" - Compilation_unit.print x.unit - Innerid.print x.id - let hash off = Hashtbl.hash off - let equal o1 o2 = compare o1 o2 = 0 - let name o = Innerid.name o.id - let to_string x = - Format.asprintf "%a.%a" - Compilation_unit.print x.unit - Innerid.print x.id - let create ?name unit = - let id = Innerid.create ?name () in - { id; unit } - let unit x = x.unit -end diff --git a/middle_end/base_types/id_types.mli b/middle_end/base_types/id_types.mli deleted file mode 100644 index 48ca037c..00000000 --- a/middle_end/base_types/id_types.mli +++ /dev/null @@ -1,56 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(* CR-soon mshinwell: This module should be removed. *) - -(** Generic identifier type *) -module type BaseId = -sig - type t - val equal : t -> t -> bool - val compare : t -> t -> int - val hash : t -> int - val name : t -> string option - val to_string : t -> string - val output : out_channel -> t -> unit - val print : Format.formatter -> t -> unit -end - -module type Id = -sig - include BaseId - val create : ?name:string -> unit -> t -end - -(** Fully qualified identifiers *) -module type UnitId = -sig - module Compilation_unit : Identifiable.Thing - include BaseId - val create : ?name:string -> Compilation_unit.t -> t - val unit : t -> Compilation_unit.t -end - -(** If applied generatively, i.e. [Id(struct end)], creates a new type - of identifiers. *) -module Id : functor (E : sig end) -> Id - -module UnitId : - functor (Id : Id) -> - functor (Compilation_unit : Identifiable.Thing) -> - UnitId with module Compilation_unit := Compilation_unit diff --git a/middle_end/base_types/linkage_name.ml b/middle_end/base_types/linkage_name.ml deleted file mode 100644 index 46febfba..00000000 --- a/middle_end/base_types/linkage_name.ml +++ /dev/null @@ -1,30 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type t = string - -include Identifiable.Make (struct - include String - let hash = Hashtbl.hash - let print ppf t = Format.pp_print_string ppf t - let output chan t = output_string chan t -end) - -let create t = t -let to_string t = t diff --git a/middle_end/base_types/linkage_name.mli b/middle_end/base_types/linkage_name.mli deleted file mode 100644 index 58731917..00000000 --- a/middle_end/base_types/linkage_name.mli +++ /dev/null @@ -1,22 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -include Identifiable.S - -val create : string -> t -val to_string : t -> string diff --git a/middle_end/base_types/mutable_variable.ml b/middle_end/base_types/mutable_variable.ml deleted file mode 100644 index 07fe3152..00000000 --- a/middle_end/base_types/mutable_variable.ml +++ /dev/null @@ -1,22 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -include Variable - -let create_from_variable = rename diff --git a/middle_end/base_types/mutable_variable.mli b/middle_end/base_types/mutable_variable.mli deleted file mode 100644 index 17fe208f..00000000 --- a/middle_end/base_types/mutable_variable.mli +++ /dev/null @@ -1,47 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -include Identifiable.S - -val create - : ?current_compilation_unit:Compilation_unit.t - -> Internal_variable_names.t - -> t - -val create_with_same_name_as_ident : Ident.t -> t - -val create_from_variable - : ?current_compilation_unit:Compilation_unit.t - -> Variable.t - -> t - -val rename - : ?current_compilation_unit:Compilation_unit.t - -> t - -> t - -val in_compilation_unit : t -> Compilation_unit.t -> bool - -val name : t -> string - -val unique_name : t -> string - -val print_list : Format.formatter -> t list -> unit -val print_opt : Format.formatter -> t option -> unit - -val output_full : out_channel -> t -> unit diff --git a/middle_end/base_types/set_of_closures_id.ml b/middle_end/base_types/set_of_closures_id.ml deleted file mode 100644 index 681ac955..00000000 --- a/middle_end/base_types/set_of_closures_id.ml +++ /dev/null @@ -1,29 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module Id : Id_types.Id = Id_types.Id (struct end) -module Unit_id = Id_types.UnitId (Id) (Compilation_unit) - -type t = Unit_id.t - -include Identifiable.Make (Unit_id) - -let create = Unit_id.create -let get_compilation_unit = Unit_id.unit -let name = Unit_id.name diff --git a/middle_end/base_types/set_of_closures_id.mli b/middle_end/base_types/set_of_closures_id.mli deleted file mode 100755 index 811cb661..00000000 --- a/middle_end/base_types/set_of_closures_id.mli +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** An identifier, unique across the whole program, that identifies a set - of closures (viz. [Set_of_closures]). *) - -include Identifiable.S - -val create : ?name:string -> Compilation_unit.t -> t -val name : t -> string option -val get_compilation_unit : t -> Compilation_unit.t diff --git a/middle_end/base_types/set_of_closures_origin.ml b/middle_end/base_types/set_of_closures_origin.ml deleted file mode 100644 index a5ef8c7c..00000000 --- a/middle_end/base_types/set_of_closures_origin.ml +++ /dev/null @@ -1,23 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -include Set_of_closures_id - -let create t = t -let rename f t = f t diff --git a/middle_end/base_types/set_of_closures_origin.mli b/middle_end/base_types/set_of_closures_origin.mli deleted file mode 100644 index 4c9cfdcf..00000000 --- a/middle_end/base_types/set_of_closures_origin.mli +++ /dev/null @@ -1,22 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -include Identifiable.S - -val create : Set_of_closures_id.t -> t - -val get_compilation_unit : t -> Compilation_unit.t -val rename : (Set_of_closures_id.t -> Set_of_closures_id.t) -> t -> t diff --git a/middle_end/base_types/static_exception.ml b/middle_end/base_types/static_exception.ml deleted file mode 100644 index 6cecae63..00000000 --- a/middle_end/base_types/static_exception.ml +++ /dev/null @@ -1,23 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -include Numbers.Int - -let create () = Lambda.next_raise_count () -let to_int t = t diff --git a/middle_end/base_types/static_exception.mli b/middle_end/base_types/static_exception.mli deleted file mode 100644 index 88f690aa..00000000 --- a/middle_end/base_types/static_exception.mli +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** An identifier that is used to label static exceptions. Its - uniqueness properties are unspecified. *) - -include Identifiable.S - -val create : unit -> t - -val to_int : t -> int diff --git a/middle_end/base_types/symbol.ml b/middle_end/base_types/symbol.ml deleted file mode 100644 index 22a2e0a7..00000000 --- a/middle_end/base_types/symbol.ml +++ /dev/null @@ -1,105 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - - -type t = - | Linkage of - { compilation_unit : Compilation_unit.t; - label : Linkage_name.t; - hash : int; } - | Variable of - { compilation_unit : Compilation_unit.t; - variable : Variable.t; } - -let label t = - match t with - | Linkage { label; _ } -> label - | Variable { variable; _ } -> - (* Use the variable's compilation unit for the label, since the - symbol's compilation unit might be a pack *) - let compilation_unit = Variable.get_compilation_unit variable in - let unit_linkage_name = - Linkage_name.to_string - (Compilation_unit.get_linkage_name compilation_unit) - in - let label = unit_linkage_name ^ "__" ^ Variable.unique_name variable in - Linkage_name.create label - -include Identifiable.Make (struct - - type nonrec t = t - - let compare t1 t2 = - if t1 == t2 then 0 - else begin - match t1, t2 with - | Linkage _, Variable _ -> 1 - | Variable _, Linkage _ -> -1 - | Linkage l1, Linkage l2 -> - let c = compare l1.hash l2.hash in - if c <> 0 then c else begin - (* Linkage names are unique across a whole project, so just comparing - those is sufficient. *) - Linkage_name.compare l1.label l2.label - end - | Variable v1, Variable v2 -> - Variable.compare v1.variable v2.variable - end - - let equal x y = - if x == y then true - else compare x y = 0 - - let output chan t = - Linkage_name.output chan (label t) - - let hash t = - match t with - | Linkage { hash; _ } -> hash - | Variable { variable } -> Variable.hash variable - - let print ppf t = - Linkage_name.print ppf (label t) - -end) - -let of_global_linkage compilation_unit label = - let hash = Linkage_name.hash label in - Linkage { compilation_unit; hash; label } - -let of_variable variable = - let compilation_unit = Variable.get_compilation_unit variable in - Variable { variable; compilation_unit } - -let import_for_pack ~pack:compilation_unit symbol = - match symbol with - | Linkage l -> Linkage { l with compilation_unit } - | Variable v -> Variable { v with compilation_unit } - -let compilation_unit t = - match t with - | Linkage { compilation_unit; _ } -> compilation_unit - | Variable { compilation_unit; _ } -> compilation_unit - -let print_opt ppf = function - | None -> Format.fprintf ppf "" - | Some t -> print ppf t - -let compare_lists l1 l2 = - Misc.Stdlib.List.compare compare l1 l2 diff --git a/middle_end/base_types/symbol.mli b/middle_end/base_types/symbol.mli deleted file mode 100644 index d2771af2..00000000 --- a/middle_end/base_types/symbol.mli +++ /dev/null @@ -1,44 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** A symbol identifies a constant provided by either: - - another compilation unit; or - - a top-level module. - - * [sym_unit] is the compilation unit containing the value. - * [sym_label] is the linkage name of the variable. - - The label must be globally unique: two compilation units linked in the - same program must not share labels. *) - -include Identifiable.S - -val of_variable : Variable.t -> t - -(* Create the symbol without prefixing with the compilation unit. - Used for global symbols like predefined exceptions *) -val of_global_linkage : Compilation_unit.t -> Linkage_name.t -> t - -val import_for_pack : pack:Compilation_unit.t -> t -> t - -val compilation_unit : t -> Compilation_unit.t -val label : t -> Linkage_name.t - -val print_opt : Format.formatter -> t option -> unit - -val compare_lists : t list -> t list -> int diff --git a/middle_end/base_types/tag.ml b/middle_end/base_types/tag.ml deleted file mode 100644 index cfa51ddb..00000000 --- a/middle_end/base_types/tag.ml +++ /dev/null @@ -1,35 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type t = int - -include Identifiable.Make (Numbers.Int) - -let create_exn tag = - if tag < 0 || tag > 255 then - Misc.fatal_error (Printf.sprintf "Tag.create_exn %d" tag) - else - tag - -let to_int t = t - -let zero = 0 -let object_tag = Obj.object_tag - -let compare : t -> t -> int = Stdlib.compare diff --git a/middle_end/base_types/tag.mli b/middle_end/base_types/tag.mli deleted file mode 100644 index 12ce5525..00000000 --- a/middle_end/base_types/tag.mli +++ /dev/null @@ -1,29 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Tags on runtime boxed values. *) - -include Identifiable.S - -val create_exn : int -> t -val to_int : t -> int - -val zero : t -val object_tag : t - -val compare : t -> t -> int diff --git a/middle_end/base_types/var_within_closure.ml b/middle_end/base_types/var_within_closure.ml deleted file mode 100644 index 466f59a2..00000000 --- a/middle_end/base_types/var_within_closure.ml +++ /dev/null @@ -1,20 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -include Closure_element diff --git a/middle_end/base_types/var_within_closure.mli b/middle_end/base_types/var_within_closure.mli deleted file mode 100644 index 56f0af0a..00000000 --- a/middle_end/base_types/var_within_closure.mli +++ /dev/null @@ -1,24 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** An identifier, unique across the whole program, that identifies a - particular variable within a particular closure. Only - [Project_var], and not [Var], nodes are tagged with these - identifiers. *) - -include module type of Closure_element diff --git a/middle_end/base_types/variable.ml b/middle_end/base_types/variable.ml deleted file mode 100644 index 64099a73..00000000 --- a/middle_end/base_types/variable.ml +++ /dev/null @@ -1,119 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type t = { - compilation_unit : Compilation_unit.t; - name : string; - name_stamp : int; - (** [name_stamp]s are unique within any given compilation unit. *) -} - -include Identifiable.Make (struct - type nonrec t = t - - let compare t1 t2 = - if t1 == t2 then 0 - else - let c = t1.name_stamp - t2.name_stamp in - if c <> 0 then c - else Compilation_unit.compare t1.compilation_unit t2.compilation_unit - - let equal t1 t2 = - if t1 == t2 then true - else - t1.name_stamp = t2.name_stamp - && Compilation_unit.equal t1.compilation_unit t2.compilation_unit - - let output chan t = - output_string chan t.name; - output_string chan "_"; - output_string chan (Int.to_string t.name_stamp) - - let hash t = t.name_stamp lxor (Compilation_unit.hash t.compilation_unit) - - let print ppf t = - if Compilation_unit.equal t.compilation_unit - (Compilation_unit.get_current_exn ()) - then begin - Format.fprintf ppf "%s/%d" - t.name t.name_stamp - end else begin - Format.fprintf ppf "%a.%s/%d" - Compilation_unit.print t.compilation_unit - t.name t.name_stamp - end -end) - -let previous_name_stamp = ref (-1) - -let create_with_name_string ?current_compilation_unit name = - let compilation_unit = - match current_compilation_unit with - | Some compilation_unit -> compilation_unit - | None -> Compilation_unit.get_current_exn () - in - let name_stamp = - incr previous_name_stamp; - !previous_name_stamp - in - { compilation_unit; - name; - name_stamp; - } - -let create ?current_compilation_unit name = - let name = (name : Internal_variable_names.t :> string) in - create_with_name_string ?current_compilation_unit name - -let create_with_same_name_as_ident ident = - create_with_name_string (Ident.name ident) - -let rename ?current_compilation_unit t = - create_with_name_string ?current_compilation_unit t.name - -let in_compilation_unit t cu = - Compilation_unit.equal cu t.compilation_unit - -let get_compilation_unit t = t.compilation_unit - -let name t = t.name - -let unique_name t = - t.name ^ "_" ^ (Int.to_string t.name_stamp) - -let print_list ppf ts = - List.iter (fun t -> Format.fprintf ppf "@ %a" print t) ts - -let debug_when_stamp_matches t ~stamp ~f = - if t.name_stamp = stamp then f () - -let print_opt ppf = function - | None -> Format.fprintf ppf "" - | Some t -> print ppf t - -type pair = t * t -module Pair = Identifiable.Make (Identifiable.Pair (T) (T)) - -let compare_lists l1 l2 = - Misc.Stdlib.List.compare compare l1 l2 - -let output_full chan t = - Compilation_unit.output chan t.compilation_unit; - output_string chan "."; - output chan t diff --git a/middle_end/base_types/variable.mli b/middle_end/base_types/variable.mli deleted file mode 100644 index b5d3f136..00000000 --- a/middle_end/base_types/variable.mli +++ /dev/null @@ -1,63 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** [Variable.t] is the equivalent of a non-persistent [Ident.t] in - the [Flambda] tree. It wraps an [Ident.t] together with its source - [compilation_unit]. As such, it is unique within a whole program, - not just one compilation unit. - - Introducing a new type helps in tracing the source of identifiers - when debugging the inliner. It also avoids Ident renaming when - importing cmx files. -*) - -include Identifiable.S - -val create - : ?current_compilation_unit:Compilation_unit.t - -> Internal_variable_names.t - -> t -val create_with_same_name_as_ident : Ident.t -> t - -val rename - : ?current_compilation_unit:Compilation_unit.t - -> t - -> t - -val in_compilation_unit : t -> Compilation_unit.t -> bool - -val name : t -> string - -val unique_name : t -> string - -val get_compilation_unit : t -> Compilation_unit.t - -val print_list : Format.formatter -> t list -> unit -val print_opt : Format.formatter -> t option -> unit - -(** If the given variable has the given stamp, call the user-supplied - function. For debugging purposes only. *) -val debug_when_stamp_matches : t -> stamp:int -> f:(unit -> unit) -> unit - -type pair = t * t -module Pair : Identifiable.S with type t := pair - -val compare_lists : t list -> t list -> int - -val output_full : out_channel -> t -> unit -(** Unlike [output], [output_full] includes the compilation unit. *) diff --git a/middle_end/clambda.ml b/middle_end/clambda.ml new file mode 100644 index 00000000..406bfbcc --- /dev/null +++ b/middle_end/clambda.ml @@ -0,0 +1,203 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* A variant of the "lambda" code with direct / indirect calls explicit + and closures explicit too *) + +open Asttypes +open Lambda + +type function_label = string + +type ustructured_constant = + | Uconst_float of float + | Uconst_int32 of int32 + | Uconst_int64 of int64 + | Uconst_nativeint of nativeint + | Uconst_block of int * uconstant list + | Uconst_float_array of float list + | Uconst_string of string + | Uconst_closure of ufunction list * string * uconstant list + +and uconstant = + | Uconst_ref of string * ustructured_constant option + | Uconst_int of int + | Uconst_ptr of int + +and uphantom_defining_expr = + | Uphantom_const of uconstant + | Uphantom_var of Backend_var.t + | Uphantom_offset_var of { var : Backend_var.t; offset_in_words : int; } + | Uphantom_read_field of { var : Backend_var.t; field : int; } + | Uphantom_read_symbol_field of { sym : string; field : int; } + | Uphantom_block of { tag : int; fields : Backend_var.t list; } + +and ulambda = + Uvar of Backend_var.t + | Uconst of uconstant + | Udirect_apply of function_label * ulambda list * Debuginfo.t + | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t + | Uclosure of ufunction list * ulambda list + | Uoffset of ulambda * int + | Ulet of mutable_flag * value_kind * Backend_var.With_provenance.t + * ulambda * ulambda + | Uphantom_let of Backend_var.With_provenance.t + * uphantom_defining_expr option * ulambda + | Uletrec of (Backend_var.With_provenance.t * ulambda) list * ulambda + | Uprim of Clambda_primitives.primitive * ulambda list * Debuginfo.t + | Uswitch of ulambda * ulambda_switch * Debuginfo.t + | Ustringswitch of ulambda * (string * ulambda) list * ulambda option + | Ustaticfail of int * ulambda list + | Ucatch of + int * + (Backend_var.With_provenance.t * value_kind) list * + ulambda * + ulambda + | Utrywith of ulambda * Backend_var.With_provenance.t * ulambda + | Uifthenelse of ulambda * ulambda * ulambda + | Usequence of ulambda * ulambda + | Uwhile of ulambda * ulambda + | Ufor of Backend_var.With_provenance.t * ulambda * ulambda + * direction_flag * ulambda + | Uassign of Backend_var.t * ulambda + | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t + | Uunreachable + +and ufunction = { + label : function_label; + arity : int; + params : (Backend_var.With_provenance.t * value_kind) list; + return : value_kind; + body : ulambda; + dbg : Debuginfo.t; + env : Backend_var.t option; +} + +and ulambda_switch = + { us_index_consts: int array; + us_actions_consts : ulambda array; + us_index_blocks: int array; + us_actions_blocks: ulambda array} + +(* Description of known functions *) + +type function_description = + { fun_label: function_label; (* Label of direct entry point *) + fun_arity: int; (* Number of arguments *) + mutable fun_closed: bool; (* True if environment not used *) + mutable fun_inline: (Backend_var.With_provenance.t list * ulambda) option; + mutable fun_float_const_prop: bool (* Can propagate FP consts *) + } + +(* Approximation of values *) + +type value_approximation = + Value_closure of function_description * value_approximation + | Value_tuple of value_approximation array + | Value_unknown + | Value_const of uconstant + | Value_global_field of string * int + +(* Preallocated globals *) + +type usymbol_provenance = { + original_idents : Ident.t list; + module_path : Path.t; +} + +type uconstant_block_field = + | Uconst_field_ref of string + | Uconst_field_int of int + +type preallocated_block = { + symbol : string; + exported : bool; + tag : int; + fields : uconstant_block_field option list; + provenance : usymbol_provenance option; +} + +type preallocated_constant = { + symbol : string; + exported : bool; + definition : ustructured_constant; + provenance : usymbol_provenance option; +} + +(* Comparison functions for constants. We must not use Stdlib.compare + because it compares "0.0" and "-0.0" equal. (PR#6442) *) + +let compare_floats x1 x2 = + Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2) + +let rec compare_float_lists l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | h1::t1, h2::t2 -> + let c = compare_floats h1 h2 in + if c <> 0 then c else compare_float_lists t1 t2 + +let compare_constants c1 c2 = + match c1, c2 with + | Uconst_ref(lbl1, _c1), Uconst_ref(lbl2, _c2) -> String.compare lbl1 lbl2 + (* Same labels -> same constants. + Different labels -> different constants, even if the contents + match, because of string constants that must not be + reshared. *) + | Uconst_int n1, Uconst_int n2 -> Stdlib.compare n1 n2 + | Uconst_ptr n1, Uconst_ptr n2 -> Stdlib.compare n1 n2 + | Uconst_ref _, _ -> -1 + | Uconst_int _, Uconst_ref _ -> 1 + | Uconst_int _, Uconst_ptr _ -> -1 + | Uconst_ptr _, _ -> 1 + +let rec compare_constant_lists l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | h1::t1, h2::t2 -> + let c = compare_constants h1 h2 in + if c <> 0 then c else compare_constant_lists t1 t2 + +let rank_structured_constant = function + | Uconst_float _ -> 0 + | Uconst_int32 _ -> 1 + | Uconst_int64 _ -> 2 + | Uconst_nativeint _ -> 3 + | Uconst_block _ -> 4 + | Uconst_float_array _ -> 5 + | Uconst_string _ -> 6 + | Uconst_closure _ -> 7 + +let compare_structured_constants c1 c2 = + match c1, c2 with + | Uconst_float x1, Uconst_float x2 -> compare_floats x1 x2 + | Uconst_int32 x1, Uconst_int32 x2 -> Int32.compare x1 x2 + | Uconst_int64 x1, Uconst_int64 x2 -> Int64.compare x1 x2 + | Uconst_nativeint x1, Uconst_nativeint x2 -> Nativeint.compare x1 x2 + | Uconst_block(t1, l1), Uconst_block(t2, l2) -> + let c = t1 - t2 (* no overflow possible here *) in + if c <> 0 then c else compare_constant_lists l1 l2 + | Uconst_float_array l1, Uconst_float_array l2 -> + compare_float_lists l1 l2 + | Uconst_string s1, Uconst_string s2 -> String.compare s1 s2 + | Uconst_closure (_,lbl1,_), Uconst_closure (_,lbl2,_) -> + String.compare lbl1 lbl2 + | _, _ -> + (* no overflow possible here *) + rank_structured_constant c1 - rank_structured_constant c2 diff --git a/middle_end/clambda.mli b/middle_end/clambda.mli new file mode 100644 index 00000000..ddd0956d --- /dev/null +++ b/middle_end/clambda.mli @@ -0,0 +1,153 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* A variant of the "lambda" code with direct / indirect calls explicit + and closures explicit too *) + +open Asttypes +open Lambda + +type function_label = string + +type ustructured_constant = + | Uconst_float of float + | Uconst_int32 of int32 + | Uconst_int64 of int64 + | Uconst_nativeint of nativeint + | Uconst_block of int * uconstant list + | Uconst_float_array of float list + | Uconst_string of string + | Uconst_closure of ufunction list * string * uconstant list + +and uconstant = + | Uconst_ref of string * ustructured_constant option + | Uconst_int of int + | Uconst_ptr of int + +and uphantom_defining_expr = + | Uphantom_const of uconstant + (** The phantom-let-bound variable is a constant. *) + | Uphantom_var of Backend_var.t + (** The phantom-let-bound variable is an alias for another variable. *) + | Uphantom_offset_var of { var : Backend_var.t; offset_in_words : int; } + (** The phantom-let-bound-variable's value is defined by adding the given + number of words to the pointer contained in the given identifier. *) + | Uphantom_read_field of { var : Backend_var.t; field : int; } + (** The phantom-let-bound-variable's value is found by adding the given + number of words to the pointer contained in the given identifier, then + dereferencing. *) + | Uphantom_read_symbol_field of { sym : string; field : int; } + (** As for [Uphantom_read_var_field], but with the pointer specified by + a symbol. *) + | Uphantom_block of { tag : int; fields : Backend_var.t list; } + (** The phantom-let-bound variable points at a block with the given + structure. *) + +and ulambda = + Uvar of Backend_var.t + | Uconst of uconstant + | Udirect_apply of function_label * ulambda list * Debuginfo.t + | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t + | Uclosure of ufunction list * ulambda list + | Uoffset of ulambda * int + | Ulet of mutable_flag * value_kind * Backend_var.With_provenance.t + * ulambda * ulambda + | Uphantom_let of Backend_var.With_provenance.t + * uphantom_defining_expr option * ulambda + | Uletrec of (Backend_var.With_provenance.t * ulambda) list * ulambda + | Uprim of Clambda_primitives.primitive * ulambda list * Debuginfo.t + | Uswitch of ulambda * ulambda_switch * Debuginfo.t + | Ustringswitch of ulambda * (string * ulambda) list * ulambda option + | Ustaticfail of int * ulambda list + | Ucatch of + int * + (Backend_var.With_provenance.t * value_kind) list * + ulambda * + ulambda + | Utrywith of ulambda * Backend_var.With_provenance.t * ulambda + | Uifthenelse of ulambda * ulambda * ulambda + | Usequence of ulambda * ulambda + | Uwhile of ulambda * ulambda + | Ufor of Backend_var.With_provenance.t * ulambda * ulambda + * direction_flag * ulambda + | Uassign of Backend_var.t * ulambda + | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t + | Uunreachable + +and ufunction = { + label : function_label; + arity : int; + params : (Backend_var.With_provenance.t * value_kind) list; + return : value_kind; + body : ulambda; + dbg : Debuginfo.t; + env : Backend_var.t option; +} + +and ulambda_switch = + { us_index_consts: int array; + us_actions_consts: ulambda array; + us_index_blocks: int array; + us_actions_blocks: ulambda array} + +(* Description of known functions *) + +type function_description = + { fun_label: function_label; (* Label of direct entry point *) + fun_arity: int; (* Number of arguments *) + mutable fun_closed: bool; (* True if environment not used *) + mutable fun_inline: (Backend_var.With_provenance.t list * ulambda) option; + mutable fun_float_const_prop: bool (* Can propagate FP consts *) + } + +(* Approximation of values *) + +type value_approximation = + Value_closure of function_description * value_approximation + | Value_tuple of value_approximation array + | Value_unknown + | Value_const of uconstant + | Value_global_field of string * int + +(* Comparison functions for constants *) + +val compare_structured_constants: + ustructured_constant -> ustructured_constant -> int +val compare_constants: + uconstant -> uconstant -> int + +type usymbol_provenance = { + original_idents : Ident.t list; + module_path : Path.t; +} + +type uconstant_block_field = + | Uconst_field_ref of string + | Uconst_field_int of int + +type preallocated_block = { + symbol : string; + exported : bool; + tag : int; + fields : uconstant_block_field option list; + provenance : usymbol_provenance option; +} + +type preallocated_constant = { + symbol : string; + exported : bool; + definition : ustructured_constant; + provenance : usymbol_provenance option; +} diff --git a/middle_end/clambda_primitives.ml b/middle_end/clambda_primitives.ml new file mode 100644 index 00000000..a7c9798f --- /dev/null +++ b/middle_end/clambda_primitives.ml @@ -0,0 +1,155 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type mutable_flag = Asttypes.mutable_flag + +type immediate_or_pointer = Lambda.immediate_or_pointer + +type initialization_or_assignment = Lambda.initialization_or_assignment + +type is_safe = Lambda.is_safe + +type boxed = + | Boxed + | Unboxed + +type memory_access_size = + | Sixteen + | Thirty_two + | Sixty_four + +type primitive = + | Pread_symbol of string + (* Operations on heap blocks *) + | Pmakeblock of int * mutable_flag * block_shape + | Pfield of int + | Pfield_computed + | Psetfield of int * immediate_or_pointer * initialization_or_assignment + | Psetfield_computed of immediate_or_pointer * initialization_or_assignment + | Pfloatfield of int + | Psetfloatfield of int * initialization_or_assignment + | Pduprecord of Types.record_representation * int + (* External call *) + | Pccall of Primitive.description + (* Exceptions *) + | Praise of raise_kind + (* Boolean operations *) + | Psequand | Psequor | Pnot + (* Integer operations *) + | Pnegint | Paddint | Psubint | Pmulint + | Pdivint of is_safe | Pmodint of is_safe + | Pandint | Porint | Pxorint + | Plslint | Plsrint | Pasrint + | Pintcomp of integer_comparison + | Poffsetint of int + | Poffsetref of int + (* Float operations *) + | Pintoffloat | Pfloatofint + | Pnegfloat | Pabsfloat + | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat + | Pfloatcomp of float_comparison + (* String operations *) + | Pstringlength | Pstringrefu | Pstringrefs + | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets + (* Array operations *) + | Pmakearray of array_kind * mutable_flag + | Pduparray of array_kind * mutable_flag + (** For [Pduparray], the argument must be an immutable array. + The arguments of [Pduparray] give the kind and mutability of the + array being *produced* by the duplication. *) + | Parraylength of array_kind + | Parrayrefu of array_kind + | Parraysetu of array_kind + | Parrayrefs of array_kind + | Parraysets of array_kind + (* Test if the argument is a block or an immediate integer *) + | Pisint + (* Test if the (integer) argument is outside an interval *) + | Pisout + (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *) + | Pbintofint of boxed_integer + | Pintofbint of boxed_integer + | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*) + | Pnegbint of boxed_integer + | Paddbint of boxed_integer + | Psubbint of boxed_integer + | Pmulbint of boxed_integer + | Pdivbint of { size : boxed_integer; is_safe : is_safe } + | Pmodbint of { size : boxed_integer; is_safe : is_safe } + | Pandbint of boxed_integer + | Porbint of boxed_integer + | Pxorbint of boxed_integer + | Plslbint of boxed_integer + | Plsrbint of boxed_integer + | Pasrbint of boxed_integer + | Pbintcomp of boxed_integer * integer_comparison + (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) + | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout + | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout + (* size of the nth dimension of a big array *) + | Pbigarraydim of int + (* load/set 16,32,64 bits from a string: (unsafe)*) + | Pstring_load of (memory_access_size * is_safe) + | Pbytes_load of (memory_access_size * is_safe) + | Pbytes_set of (memory_access_size * is_safe) + (* load/set 16,32,64 bits from a + (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *) + | Pbigstring_load of (memory_access_size * is_safe) + | Pbigstring_set of (memory_access_size * is_safe) + (* byte swap *) + | Pbswap16 + | Pbbswap of boxed_integer + (* Integer to external pointer *) + | Pint_as_pointer + (* Inhibition of optimisation *) + | Popaque + +and integer_comparison = Lambda.integer_comparison = + Ceq | Cne | Clt | Cgt | Cle | Cge + +and float_comparison = Lambda.float_comparison = + CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge + +and array_kind = Lambda.array_kind = + Pgenarray | Paddrarray | Pintarray | Pfloatarray + +and value_kind = Lambda.value_kind = + (* CR mshinwell: Pfloatval should be renamed to Pboxedfloatval *) + Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval + +and block_shape = Lambda.block_shape +and boxed_integer = Primitive.boxed_integer = + Pnativeint | Pint32 | Pint64 + +and bigarray_kind = Lambda.bigarray_kind = + Pbigarray_unknown + | Pbigarray_float32 | Pbigarray_float64 + | Pbigarray_sint8 | Pbigarray_uint8 + | Pbigarray_sint16 | Pbigarray_uint16 + | Pbigarray_int32 | Pbigarray_int64 + | Pbigarray_caml_int | Pbigarray_native_int + | Pbigarray_complex32 | Pbigarray_complex64 + +and bigarray_layout = Lambda.bigarray_layout = + Pbigarray_unknown_layout + | Pbigarray_c_layout + | Pbigarray_fortran_layout + +and raise_kind = Lambda.raise_kind = + | Raise_regular + | Raise_reraise + | Raise_notrace + +let equal (x: primitive) (y: primitive) = x = y diff --git a/middle_end/clambda_primitives.mli b/middle_end/clambda_primitives.mli new file mode 100644 index 00000000..d534ca9c --- /dev/null +++ b/middle_end/clambda_primitives.mli @@ -0,0 +1,158 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type mutable_flag = Asttypes.mutable_flag + +type immediate_or_pointer = Lambda.immediate_or_pointer + +type initialization_or_assignment = Lambda.initialization_or_assignment + +type is_safe = Lambda.is_safe + +type boxed = + | Boxed + | Unboxed + +type memory_access_size = + | Sixteen + | Thirty_two + | Sixty_four + +type primitive = + | Pread_symbol of string + (* Operations on heap blocks *) + | Pmakeblock of int * mutable_flag * block_shape + | Pfield of int + | Pfield_computed + | Psetfield of int * immediate_or_pointer * initialization_or_assignment + | Psetfield_computed of immediate_or_pointer * initialization_or_assignment + | Pfloatfield of int + | Psetfloatfield of int * initialization_or_assignment + | Pduprecord of Types.record_representation * int + (* External call *) + | Pccall of Primitive.description + (* Exceptions *) + | Praise of raise_kind + (* Boolean operations *) + | Psequand | Psequor | Pnot + (* Integer operations *) + | Pnegint | Paddint | Psubint | Pmulint + | Pdivint of is_safe | Pmodint of is_safe + | Pandint | Porint | Pxorint + | Plslint | Plsrint | Pasrint + | Pintcomp of integer_comparison + | Poffsetint of int + | Poffsetref of int + (* Float operations *) + | Pintoffloat | Pfloatofint + | Pnegfloat | Pabsfloat + | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat + | Pfloatcomp of float_comparison + (* String operations *) + | Pstringlength | Pstringrefu | Pstringrefs + | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets + (* Array operations *) + | Pmakearray of array_kind * mutable_flag + (** For [Pmakearray], the list of arguments must not be empty. The empty + array should be represented by a distinguished constant in the middle + end. *) + | Pduparray of array_kind * mutable_flag + (** For [Pduparray], the argument must be an immutable array. + The arguments of [Pduparray] give the kind and mutability of the + array being *produced* by the duplication. *) + | Parraylength of array_kind + | Parrayrefu of array_kind + | Parraysetu of array_kind + | Parrayrefs of array_kind + | Parraysets of array_kind + (* Test if the argument is a block or an immediate integer *) + | Pisint + (* Test if the (integer) argument is outside an interval *) + | Pisout + (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *) + | Pbintofint of boxed_integer + | Pintofbint of boxed_integer + | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*) + | Pnegbint of boxed_integer + | Paddbint of boxed_integer + | Psubbint of boxed_integer + | Pmulbint of boxed_integer + | Pdivbint of { size : boxed_integer; is_safe : is_safe } + | Pmodbint of { size : boxed_integer; is_safe : is_safe } + | Pandbint of boxed_integer + | Porbint of boxed_integer + | Pxorbint of boxed_integer + | Plslbint of boxed_integer + | Plsrbint of boxed_integer + | Pasrbint of boxed_integer + | Pbintcomp of boxed_integer * integer_comparison + (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) + | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout + | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout + (* size of the nth dimension of a big array *) + | Pbigarraydim of int + (* load/set 16,32,64 bits from a string: (unsafe)*) + | Pstring_load of (memory_access_size * is_safe) + | Pbytes_load of (memory_access_size * is_safe) + | Pbytes_set of (memory_access_size * is_safe) + (* load/set 16,32,64 bits from a + (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *) + | Pbigstring_load of (memory_access_size * is_safe) + | Pbigstring_set of (memory_access_size * is_safe) + (* byte swap *) + | Pbswap16 + | Pbbswap of boxed_integer + (* Integer to external pointer *) + | Pint_as_pointer + (* Inhibition of optimisation *) + | Popaque + +and integer_comparison = Lambda.integer_comparison = + Ceq | Cne | Clt | Cgt | Cle | Cge + +and float_comparison = Lambda.float_comparison = + CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge + +and array_kind = Lambda.array_kind = + Pgenarray | Paddrarray | Pintarray | Pfloatarray + +and value_kind = Lambda.value_kind = + (* CR mshinwell: Pfloatval should be renamed to Pboxedfloatval *) + Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval + +and block_shape = Lambda.block_shape +and boxed_integer = Primitive.boxed_integer = + Pnativeint | Pint32 | Pint64 + +and bigarray_kind = Lambda.bigarray_kind = + Pbigarray_unknown + | Pbigarray_float32 | Pbigarray_float64 + | Pbigarray_sint8 | Pbigarray_uint8 + | Pbigarray_sint16 | Pbigarray_uint16 + | Pbigarray_int32 | Pbigarray_int64 + | Pbigarray_caml_int | Pbigarray_native_int + | Pbigarray_complex32 | Pbigarray_complex64 + +and bigarray_layout = Lambda.bigarray_layout = + Pbigarray_unknown_layout + | Pbigarray_c_layout + | Pbigarray_fortran_layout + +and raise_kind = Lambda.raise_kind = + | Raise_regular + | Raise_reraise + | Raise_notrace + +val equal : primitive -> primitive -> bool diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml new file mode 100644 index 00000000..20767f62 --- /dev/null +++ b/middle_end/closure/closure.ml @@ -0,0 +1,1472 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Introduction of closures, uncurrying, recognition of direct calls *) + +open Misc +open Asttypes +open Primitive +open Lambda +open Switch +open Clambda +module P = Clambda_primitives + +module Int = Numbers.Int +module Storer = + Switch.Store + (struct + type t = lambda + type key = lambda + let make_key = Lambda.make_key + let compare_key = Stdlib.compare + end) + +module V = Backend_var +module VP = Backend_var.With_provenance + +(* The current backend *) + +let no_phantom_lets () = + Misc.fatal_error "Closure does not support phantom let generation" + +(* Auxiliaries for compiling functions *) + +let rec split_list n l = + if n <= 0 then ([], l) else begin + match l with + [] -> fatal_error "Closure.split_list" + | a::l -> let (l1, l2) = split_list (n-1) l in (a::l1, l2) + end + +let rec build_closure_env env_param pos = function + [] -> V.Map.empty + | id :: rem -> + V.Map.add id + (Uprim(P.Pfield pos, [Uvar env_param], Debuginfo.none)) + (build_closure_env env_param (pos+1) rem) + +(* Auxiliary for accessing globals. We change the name of the global + to the name of the corresponding asm symbol. This is done here + and no longer in Cmmgen so that approximations stored in .cmx files + contain the right names if the -for-pack option is active. *) + +let getglobal dbg id = + Uprim(P.Pread_symbol (Compilenv.symbol_for_global id), [], dbg) + +(* Check if a variable occurs in a [clambda] term. *) + +let occurs_var var u = + let rec occurs = function + Uvar v -> v = var + | Uconst _ -> false + | Udirect_apply(_lbl, args, _) -> List.exists occurs args + | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args + | Uclosure(_fundecls, clos) -> List.exists occurs clos + | Uoffset(u, _ofs) -> occurs u + | Ulet(_str, _kind, _id, def, body) -> occurs def || occurs body + | Uphantom_let _ -> no_phantom_lets () + | Uletrec(decls, body) -> + List.exists (fun (_id, u) -> occurs u) decls || occurs body + | Uprim(_p, args, _) -> List.exists occurs args + | Uswitch(arg, s, _dbg) -> + occurs arg || + occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks + | Ustringswitch(arg,sw,d) -> + occurs arg || + List.exists (fun (_,e) -> occurs e) sw || + (match d with None -> false | Some d -> occurs d) + | Ustaticfail (_, args) -> List.exists occurs args + | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr + | Utrywith(body, _exn, hdlr) -> occurs body || occurs hdlr + | Uifthenelse(cond, ifso, ifnot) -> + occurs cond || occurs ifso || occurs ifnot + | Usequence(u1, u2) -> occurs u1 || occurs u2 + | Uwhile(cond, body) -> occurs cond || occurs body + | Ufor(_id, lo, hi, _dir, body) -> occurs lo || occurs hi || occurs body + | Uassign(id, u) -> id = var || occurs u + | Usend(_, met, obj, args, _) -> + occurs met || occurs obj || List.exists occurs args + | Uunreachable -> false + and occurs_array a = + try + for i = 0 to Array.length a - 1 do + if occurs a.(i) then raise Exit + done; + false + with Exit -> + true + in occurs u + +(* Determine whether the estimated size of a clambda term is below + some threshold *) + +let prim_size prim args = + let open Clambda_primitives in + match prim with + | Pread_symbol _ -> 1 + | Pmakeblock _ -> 5 + List.length args + | Pfield _ -> 1 + | Psetfield(_f, isptr, init) -> + begin match init with + | Root_initialization -> 1 (* never causes a write barrier hit *) + | Assignment | Heap_initialization -> + match isptr with + | Pointer -> 4 + | Immediate -> 1 + end + | Pfloatfield _ -> 1 + | Psetfloatfield _ -> 1 + | Pduprecord _ -> 10 + List.length args + | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args + | Praise _ -> 4 + | Pstringlength -> 5 + | Pbyteslength -> 5 + | Pstringrefs -> 6 + | Pbytesrefs | Pbytessets -> 6 + | Pmakearray _ -> 5 + List.length args + | Parraylength kind -> if kind = Pgenarray then 6 else 2 + | Parrayrefu kind -> if kind = Pgenarray then 12 else 2 + | Parraysetu kind -> if kind = Pgenarray then 16 else 4 + | Parrayrefs kind -> if kind = Pgenarray then 18 else 8 + | Parraysets kind -> if kind = Pgenarray then 22 else 10 + | Pbigarrayref(_, ndims, _, _) -> 4 + ndims * 6 + | Pbigarrayset(_, ndims, _, _) -> 4 + ndims * 6 + | _ -> 2 (* arithmetic and comparisons *) + +(* Very raw approximation of switch cost *) + +let lambda_smaller lam threshold = + let size = ref 0 in + let rec lambda_size lam = + if !size > threshold then raise Exit; + match lam with + Uvar _ -> () + | Uconst _ -> incr size + | Udirect_apply(_, args, _) -> + size := !size + 4; lambda_list_size args + | Ugeneric_apply(fn, args, _) -> + size := !size + 6; lambda_size fn; lambda_list_size args + | Uclosure _ -> + raise Exit (* inlining would duplicate function definitions *) + | Uoffset(lam, _ofs) -> + incr size; lambda_size lam + | Ulet(_str, _kind, _id, lam, body) -> + lambda_size lam; lambda_size body + | Uphantom_let _ -> no_phantom_lets () + | Uletrec _ -> + raise Exit (* usually too large *) + | Uprim(prim, args, _) -> + size := !size + prim_size prim args; + lambda_list_size args + | Uswitch(lam, cases, _dbg) -> + if Array.length cases.us_actions_consts > 1 then size := !size + 5 ; + if Array.length cases.us_actions_blocks > 1 then size := !size + 5 ; + lambda_size lam; + lambda_array_size cases.us_actions_consts ; + lambda_array_size cases.us_actions_blocks + | Ustringswitch (lam,sw,d) -> + lambda_size lam ; + (* as ifthenelse *) + List.iter + (fun (_,lam) -> + size := !size+2 ; + lambda_size lam) + sw ; + Misc.may lambda_size d + | Ustaticfail (_,args) -> lambda_list_size args + | Ucatch(_, _, body, handler) -> + incr size; lambda_size body; lambda_size handler + | Utrywith(body, _id, handler) -> + size := !size + 8; lambda_size body; lambda_size handler + | Uifthenelse(cond, ifso, ifnot) -> + size := !size + 2; + lambda_size cond; lambda_size ifso; lambda_size ifnot + | Usequence(lam1, lam2) -> + lambda_size lam1; lambda_size lam2 + | Uwhile(cond, body) -> + size := !size + 2; lambda_size cond; lambda_size body + | Ufor(_id, low, high, _dir, body) -> + size := !size + 4; lambda_size low; lambda_size high; lambda_size body + | Uassign(_id, lam) -> + incr size; lambda_size lam + | Usend(_, met, obj, args, _) -> + size := !size + 8; + lambda_size met; lambda_size obj; lambda_list_size args + | Uunreachable -> () + and lambda_list_size l = List.iter lambda_size l + and lambda_array_size a = Array.iter lambda_size a in + try + lambda_size lam; !size <= threshold + with Exit -> + false + +let is_pure_prim p = + let open Semantics_of_primitives in + match Semantics_of_primitives.for_primitive p with + | (No_effects | Only_generative_effects), _ -> true + | Arbitrary_effects, _ -> false + +(* Check if a clambda term is ``pure'', + that is without side-effects *and* not containing function definitions *) + +let rec is_pure = function + Uvar _ -> true + | Uconst _ -> true + | Uprim(p, args, _) -> is_pure_prim p && List.for_all is_pure args + | Uoffset(arg, _) -> is_pure arg + | Ulet(Immutable, _, _var, def, body) -> + is_pure def && is_pure body + | _ -> false + +(* Simplify primitive operations on known arguments *) + +let make_const c = (Uconst c, Value_const c) +let make_const_ref c = + make_const(Uconst_ref(Compilenv.new_structured_constant ~shared:true c, + Some c)) +let make_const_int n = make_const (Uconst_int n) +let make_const_ptr n = make_const (Uconst_ptr n) +let make_const_bool b = make_const_ptr(if b then 1 else 0) + +let make_integer_comparison cmp x y = + let open Clambda_primitives in + make_const_bool + (match cmp with + Ceq -> x = y + | Cne -> x <> y + | Clt -> x < y + | Cgt -> x > y + | Cle -> x <= y + | Cge -> x >= y) + +let make_float_comparison cmp x y = + make_const_bool + (match cmp with + | CFeq -> x = y + | CFneq -> not (x = y) + | CFlt -> x < y + | CFnlt -> not (x < y) + | CFgt -> x > y + | CFngt -> not (x > y) + | CFle -> x <= y + | CFnle -> not (x <= y) + | CFge -> x >= y + | CFnge -> not (x >= y)) + +let make_const_float n = make_const_ref (Uconst_float n) +let make_const_natint n = make_const_ref (Uconst_nativeint n) +let make_const_int32 n = make_const_ref (Uconst_int32 n) +let make_const_int64 n = make_const_ref (Uconst_int64 n) + +(* The [fpc] parameter is true if constant propagation of + floating-point computations is allowed *) + +let simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg = + let module B = (val backend : Backend_intf.S) in + let open Clambda_primitives in + let default = (Uprim(p, args, dbg), Value_unknown) in + match approxs with + (* int (or enumerated type) *) + | [ Value_const(Uconst_int n1 | Uconst_ptr n1) ] -> + begin match p with + | Pnot -> make_const_bool (n1 = 0) + | Pnegint -> make_const_int (- n1) + | Poffsetint n -> make_const_int (n + n1) + | Pfloatofint when fpc -> make_const_float (float_of_int n1) + | Pbintofint Pnativeint -> make_const_natint (Nativeint.of_int n1) + | Pbintofint Pint32 -> make_const_int32 (Int32.of_int n1) + | Pbintofint Pint64 -> make_const_int64 (Int64.of_int n1) + | Pbswap16 -> make_const_int (((n1 land 0xff) lsl 8) + lor ((n1 land 0xff00) lsr 8)) + | _ -> default + end + (* int (or enumerated type), int (or enumerated type) *) + | [ Value_const(Uconst_int n1 | Uconst_ptr n1); + Value_const(Uconst_int n2 | Uconst_ptr n2) ] -> + begin match p with + | Psequand -> make_const_bool (n1 <> 0 && n2 <> 0) + | Psequor -> make_const_bool (n1 <> 0 || n2 <> 0) + | Paddint -> make_const_int (n1 + n2) + | Psubint -> make_const_int (n1 - n2) + | Pmulint -> make_const_int (n1 * n2) + | Pdivint _ when n2 <> 0 -> make_const_int (n1 / n2) + | Pmodint _ when n2 <> 0 -> make_const_int (n1 mod n2) + | Pandint -> make_const_int (n1 land n2) + | Porint -> make_const_int (n1 lor n2) + | Pxorint -> make_const_int (n1 lxor n2) + | Plslint when 0 <= n2 && n2 < 8 * B.size_int -> + make_const_int (n1 lsl n2) + | Plsrint when 0 <= n2 && n2 < 8 * B.size_int -> + make_const_int (n1 lsr n2) + | Pasrint when 0 <= n2 && n2 < 8 * B.size_int -> + make_const_int (n1 asr n2) + | Pintcomp c -> make_integer_comparison c n1 n2 + | _ -> default + end + (* float *) + | [Value_const(Uconst_ref(_, Some (Uconst_float n1)))] when fpc -> + begin match p with + | Pintoffloat -> make_const_int (int_of_float n1) + | Pnegfloat -> make_const_float (-. n1) + | Pabsfloat -> make_const_float (abs_float n1) + | _ -> default + end + (* float, float *) + | [Value_const(Uconst_ref(_, Some (Uconst_float n1))); + Value_const(Uconst_ref(_, Some (Uconst_float n2)))] when fpc -> + begin match p with + | Paddfloat -> make_const_float (n1 +. n2) + | Psubfloat -> make_const_float (n1 -. n2) + | Pmulfloat -> make_const_float (n1 *. n2) + | Pdivfloat -> make_const_float (n1 /. n2) + | Pfloatcomp c -> make_float_comparison c n1 n2 + | _ -> default + end + (* nativeint *) + | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n)))] -> + begin match p with + | Pintofbint Pnativeint -> make_const_int (Nativeint.to_int n) + | Pcvtbint(Pnativeint, Pint32) -> make_const_int32 (Nativeint.to_int32 n) + | Pcvtbint(Pnativeint, Pint64) -> make_const_int64 (Int64.of_nativeint n) + | Pnegbint Pnativeint -> make_const_natint (Nativeint.neg n) + | _ -> default + end + (* nativeint, nativeint *) + | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1))); + Value_const(Uconst_ref(_, Some (Uconst_nativeint n2)))] -> + begin match p with + | Paddbint Pnativeint -> make_const_natint (Nativeint.add n1 n2) + | Psubbint Pnativeint -> make_const_natint (Nativeint.sub n1 n2) + | Pmulbint Pnativeint -> make_const_natint (Nativeint.mul n1 n2) + | Pdivbint {size=Pnativeint} when n2 <> 0n -> + make_const_natint (Nativeint.div n1 n2) + | Pmodbint {size=Pnativeint} when n2 <> 0n -> + make_const_natint (Nativeint.rem n1 n2) + | Pandbint Pnativeint -> make_const_natint (Nativeint.logand n1 n2) + | Porbint Pnativeint -> make_const_natint (Nativeint.logor n1 n2) + | Pxorbint Pnativeint -> make_const_natint (Nativeint.logxor n1 n2) + | Pbintcomp(Pnativeint, c) -> make_integer_comparison c n1 n2 + | _ -> default + end + (* nativeint, int *) + | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1))); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int -> + make_const_natint (Nativeint.shift_left n1 n2) + | Plsrbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int -> + make_const_natint (Nativeint.shift_right_logical n1 n2) + | Pasrbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int -> + make_const_natint (Nativeint.shift_right n1 n2) + | _ -> default + end + (* int32 *) + | [Value_const(Uconst_ref(_, Some (Uconst_int32 n)))] -> + begin match p with + | Pintofbint Pint32 -> make_const_int (Int32.to_int n) + | Pcvtbint(Pint32, Pnativeint) -> make_const_natint (Nativeint.of_int32 n) + | Pcvtbint(Pint32, Pint64) -> make_const_int64 (Int64.of_int32 n) + | Pnegbint Pint32 -> make_const_int32 (Int32.neg n) + | _ -> default + end + (* int32, int32 *) + | [Value_const(Uconst_ref(_, Some (Uconst_int32 n1))); + Value_const(Uconst_ref(_, Some (Uconst_int32 n2)))] -> + begin match p with + | Paddbint Pint32 -> make_const_int32 (Int32.add n1 n2) + | Psubbint Pint32 -> make_const_int32 (Int32.sub n1 n2) + | Pmulbint Pint32 -> make_const_int32 (Int32.mul n1 n2) + | Pdivbint {size=Pint32} when n2 <> 0l -> + make_const_int32 (Int32.div n1 n2) + | Pmodbint {size=Pint32} when n2 <> 0l -> + make_const_int32 (Int32.rem n1 n2) + | Pandbint Pint32 -> make_const_int32 (Int32.logand n1 n2) + | Porbint Pint32 -> make_const_int32 (Int32.logor n1 n2) + | Pxorbint Pint32 -> make_const_int32 (Int32.logxor n1 n2) + | Pbintcomp(Pint32, c) -> make_integer_comparison c n1 n2 + | _ -> default + end + (* int32, int *) + | [Value_const(Uconst_ref(_, Some (Uconst_int32 n1))); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_left n1 n2) + | Plsrbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_right_logical n1 n2) + | Pasrbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_right n1 n2) + | _ -> default + end + (* int64 *) + | [Value_const(Uconst_ref(_, Some (Uconst_int64 n)))] -> + begin match p with + | Pintofbint Pint64 -> make_const_int (Int64.to_int n) + | Pcvtbint(Pint64, Pint32) -> make_const_int32 (Int64.to_int32 n) + | Pcvtbint(Pint64, Pnativeint) -> make_const_natint (Int64.to_nativeint n) + | Pnegbint Pint64 -> make_const_int64 (Int64.neg n) + | _ -> default + end + (* int64, int64 *) + | [Value_const(Uconst_ref(_, Some (Uconst_int64 n1))); + Value_const(Uconst_ref(_, Some (Uconst_int64 n2)))] -> + begin match p with + | Paddbint Pint64 -> make_const_int64 (Int64.add n1 n2) + | Psubbint Pint64 -> make_const_int64 (Int64.sub n1 n2) + | Pmulbint Pint64 -> make_const_int64 (Int64.mul n1 n2) + | Pdivbint {size=Pint64} when n2 <> 0L -> + make_const_int64 (Int64.div n1 n2) + | Pmodbint {size=Pint64} when n2 <> 0L -> + make_const_int64 (Int64.rem n1 n2) + | Pandbint Pint64 -> make_const_int64 (Int64.logand n1 n2) + | Porbint Pint64 -> make_const_int64 (Int64.logor n1 n2) + | Pxorbint Pint64 -> make_const_int64 (Int64.logxor n1 n2) + | Pbintcomp(Pint64, c) -> make_integer_comparison c n1 n2 + | _ -> default + end + (* int64, int *) + | [Value_const(Uconst_ref(_, Some (Uconst_int64 n1))); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_left n1 n2) + | Plsrbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_right_logical n1 n2) + | Pasrbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_right n1 n2) + | _ -> default + end + (* TODO: Pbbswap *) + (* Catch-all *) + | _ -> + default + +let field_approx n = function + | Value_tuple a when n < Array.length a -> a.(n) + | Value_const (Uconst_ref(_, Some (Uconst_block(_, l)))) + when n < List.length l -> + Value_const (List.nth l n) + | _ -> Value_unknown + +let simplif_prim_pure ~backend fpc p (args, approxs) dbg = + let open Clambda_primitives in + match p, args, approxs with + (* Block construction *) + | Pmakeblock(tag, Immutable, _kind), _, _ -> + let field = function + | Value_const c -> c + | _ -> raise Exit + in + begin try + let cst = Uconst_block (tag, List.map field approxs) in + let name = + Compilenv.new_structured_constant cst ~shared:true + in + make_const (Uconst_ref (name, Some cst)) + with Exit -> + (Uprim(p, args, dbg), Value_tuple (Array.of_list approxs)) + end + (* Field access *) + | Pfield n, _, [ Value_const(Uconst_ref(_, Some (Uconst_block(_, l)))) ] + when n < List.length l -> + make_const (List.nth l n) + | Pfield n, [ Uprim(P.Pmakeblock _, ul, _) ], [approx] + when n < List.length ul -> + (List.nth ul n, field_approx n approx) + (* Strings *) + | (Pstringlength | Pbyteslength), + _, + [ Value_const(Uconst_ref(_, Some (Uconst_string s))) ] -> + make_const_int (String.length s) + (* Kind test *) + | Pisint, _, [a1] -> + begin match a1 with + | Value_const(Uconst_int _ | Uconst_ptr _) -> make_const_bool true + | Value_const(Uconst_ref _) -> make_const_bool false + | Value_closure _ | Value_tuple _ -> make_const_bool false + | _ -> (Uprim(p, args, dbg), Value_unknown) + end + (* Catch-all *) + | _ -> + simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg + +let simplif_prim ~backend fpc p (args, approxs as args_approxs) dbg = + if List.for_all is_pure args + then simplif_prim_pure ~backend fpc p args_approxs dbg + else + (* XXX : always return the same approxs as simplif_prim_pure? *) + let approx = + match p with + | P.Pmakeblock(_, Immutable, _kind) -> + Value_tuple (Array.of_list approxs) + | _ -> + Value_unknown + in + (Uprim(p, args, dbg), approx) + +(* Substitute variables in a [ulambda] term (a body of an inlined function) + and perform some more simplifications on integer primitives. + Also perform alpha-conversion on let-bound identifiers to avoid + clashes with locally-generated identifiers, and refresh raise counts + in order to avoid clashes with inlined code from other modules. + The variables must not be assigned in the term. + This is used to substitute "trivial" arguments for parameters + during inline expansion, and also for the translation of let rec + over functions. *) + +let approx_ulam = function + Uconst c -> Value_const c + | _ -> Value_unknown + +let find_action idxs acts tag = + if 0 <= tag && tag < Array.length idxs then begin + let idx = idxs.(tag) in + assert(0 <= idx && idx < Array.length acts); + Some acts.(idx) + end else + (* Can this happen? *) + None + +let subst_debuginfo loc dbg = + if !Clflags.debug then + Debuginfo.inline loc dbg + else + dbg + +let rec substitute loc ((backend, fpc) as st) sb rn ulam = + match ulam with + Uvar v -> + begin try V.Map.find v sb with Not_found -> ulam end + | Uconst _ -> ulam + | Udirect_apply(lbl, args, dbg) -> + let dbg = subst_debuginfo loc dbg in + 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 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. + This should not happen in the current system because: + - Inlined function bodies contain no Uclosure nodes + (cf. function [lambda_smaller]) + - When we substitute offsets for idents bound by let rec + in [close], case [Lletrec], we discard the original + let rec body and use only the substituted term. *) + 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 st sb rn u1, + substitute loc st + (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2) + | Uphantom_let _ -> no_phantom_lets () + | Uletrec(bindings, body) -> + let bindings1 = + List.map (fun (id, rhs) -> + (VP.var id, VP.rename id, rhs)) bindings + in + let sb' = + List.fold_right (fun (id, id', _) s -> + V.Map.add id (Uvar (VP.var id')) s) + bindings1 sb + in + Uletrec( + List.map + (fun (_id, id', rhs) -> (id', substitute loc st sb' rn rhs)) + bindings1, + substitute loc st sb' rn body) + | Uprim(p, args, dbg) -> + let sargs = List.map (substitute loc st sb rn) args in + let dbg = subst_debuginfo loc dbg in + let (res, _) = + simplif_prim ~backend fpc p (sargs, List.map approx_ulam sargs) dbg in + res + | Uswitch(arg, sw, dbg) -> + let sarg = substitute loc st sb rn arg in + let action = + (* Unfortunately, we cannot easily deal with the + case of a constructed block (makeblock) bound to a local + identifier. This would require to keep track of + local let bindings (at least their approximations) + in this substitute function. + *) + match sarg with + | Uconst (Uconst_ref (_, Some (Uconst_block (tag, _)))) -> + find_action sw.us_index_blocks sw.us_actions_blocks tag + | Uconst (Uconst_ptr tag) -> + find_action sw.us_index_consts sw.us_actions_consts tag + | _ -> None + in + begin match action with + | Some u -> substitute loc st sb rn u + | None -> + Uswitch(sarg, + { sw with + us_actions_consts = + Array.map (substitute loc st sb rn) sw.us_actions_consts; + us_actions_blocks = + Array.map (substitute loc st sb rn) sw.us_actions_blocks; + }, + dbg) + end + | Ustringswitch(arg,sw,d) -> + Ustringswitch + (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 + | Some rn -> + begin try + Int.Map.find nfail rn + with Not_found -> + fatal_errorf "Closure.split_list: invalid nfail (%d)" nfail + end + | None -> nfail in + Ustaticfail (nfail, List.map (substitute loc st sb rn) args) + | Ucatch(nfail, ids, u1, u2) -> + let nfail, rn = + match rn with + | Some rn -> + let new_nfail = next_raise_count () in + new_nfail, Some (Int.Map.add nfail new_nfail rn) + | None -> nfail, rn in + let ids' = List.map (fun (id, k) -> VP.rename id, k) ids in + let sb' = + List.fold_right2 + (fun (id, _) (id', _) s -> + V.Map.add (VP.var id) (Uvar (VP.var id')) s + ) + ids ids' sb + in + Ucatch(nfail, ids', substitute loc st sb rn u1, + substitute loc st sb' rn u2) + | Utrywith(u1, id, u2) -> + let id' = VP.rename id in + Utrywith(substitute loc st sb rn u1, id', + substitute loc st + (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2) + | Uifthenelse(u1, u2, u3) -> + begin match substitute loc st sb rn u1 with + Uconst (Uconst_ptr n) -> + if n <> 0 then + substitute loc st sb rn u2 + else + substitute loc st sb rn u3 + | Uprim(P.Pmakeblock _, _, _) -> + substitute loc st sb rn u2 + | su1 -> + Uifthenelse(su1, substitute loc st sb rn u2, + substitute loc st sb rn u3) + end + | Usequence(u1, u2) -> + Usequence(substitute loc st sb rn u1, substitute loc st sb rn u2) + | Uwhile(u1, u2) -> + Uwhile(substitute loc st sb rn u1, substitute loc st sb rn u2) + | Ufor(id, u1, u2, dir, u3) -> + let id' = VP.rename id in + Ufor(id', substitute loc st sb rn u1, substitute loc st sb rn u2, dir, + substitute loc st + (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u3) + | Uassign(id, u) -> + let id' = + try + match V.Map.find id sb with Uvar i -> i | _ -> assert false + with Not_found -> + id in + Uassign(id', substitute loc st sb rn u) + | Usend(k, u1, u2, ul, dbg) -> + let dbg = subst_debuginfo loc dbg in + Usend(k, substitute loc st sb rn u1, substitute loc st sb rn u2, + List.map (substitute loc st sb rn) ul, dbg) + | Uunreachable -> + Uunreachable + +(* Perform an inline expansion *) + +let is_simple_argument = function + | Uvar _ | Uconst _ -> true + | _ -> false + +let no_effects = function + | Uclosure _ -> true + | u -> is_pure u + +let rec bind_params_rec loc fpc subst params args body = + match (params, args) with + ([], []) -> substitute loc fpc subst (Some Int.Map.empty) body + | (p1 :: pl, a1 :: al) -> + if is_simple_argument a1 then + bind_params_rec loc fpc (V.Map.add (VP.var p1) a1 subst) + pl al body + else begin + let p1' = VP.rename p1 in + let u1, u2 = + match VP.name p1, a1 with + | "*opt*", Uprim(P.Pmakeblock(0, Immutable, kind), [a], dbg) -> + a, Uprim(P.Pmakeblock(0, Immutable, kind), + [Uvar (VP.var p1')], dbg) + | _ -> + a1, Uvar (VP.var p1') + in + let body' = + bind_params_rec loc fpc (V.Map.add (VP.var p1) u2 subst) + pl al body in + if occurs_var (VP.var p1) body then + Ulet(Immutable, Pgenval, p1', u1, body') + else if no_effects a1 then body' + else Usequence(a1, body') + end + | (_, _) -> assert false + +let bind_params loc fpc params args body = + (* Reverse parameters and arguments to preserve right-to-left + evaluation order (PR#2910). *) + bind_params_rec loc fpc V.Map.empty (List.rev params) (List.rev args) body + +(* Check if a lambda term is ``pure'', + that is without side-effects *and* not containing function definitions *) + +let warning_if_forced_inline ~loc ~attribute warning = + if attribute = Always_inline then + Location.prerr_warning loc + (Warnings.Inlining_impossible warning) + +(* Generate a direct application *) + +let direct_apply ~backend fundesc ufunct uargs ~loc ~attribute = + let app_args = + if fundesc.fun_closed then uargs else uargs @ [ufunct] in + let app = + match fundesc.fun_inline, attribute with + | _, Never_inline | None, _ -> + let dbg = Debuginfo.from_location loc in + warning_if_forced_inline ~loc ~attribute + "Function information unavailable"; + Udirect_apply(fundesc.fun_label, app_args, dbg) + | Some(params, 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. + If the function is not closed, we evaluate ufunct as part of the + arguments. + If the function is closed, we force the evaluation of ufunct first. *) + if not fundesc.fun_closed || is_pure ufunct + then app + else Usequence(ufunct, app) + +(* Add [Value_integer] or [Value_constptr] info to the approximation + of an application *) + +let strengthen_approx appl approx = + match approx_ulam appl with + (Value_const _) as intapprox -> + intapprox + | _ -> approx + +(* If a term has approximation Value_integer or Value_constptr and is pure, + replace it by an integer constant *) + +let check_constant_result ulam approx = + match approx with + Value_const c when is_pure ulam -> make_const c + | Value_global_field (id, i) when is_pure ulam -> + begin match ulam with + | Uprim(P.Pfield _, [Uprim(P.Pread_symbol _, _, _)], _) -> (ulam, approx) + | _ -> + let glb = + Uprim(P.Pread_symbol id, [], Debuginfo.none) + in + Uprim(P.Pfield i, [glb], Debuginfo.none), approx + end + | _ -> (ulam, approx) + +(* Evaluate an expression with known value for its side effects only, + or discard it if it's pure *) + +let sequence_constant_expr ulam1 (ulam2, approx2 as res2) = + if is_pure ulam1 then res2 else (Usequence(ulam1, ulam2), approx2) + +(* Maintain the approximation of the global structure being defined *) + +let global_approx = ref([||] : value_approximation array) + +(* Maintain the nesting depth for functions *) + +let function_nesting_depth = ref 0 +let excessive_function_nesting_depth = 5 + +(* Uncurry an expression and explicitate closures. + Also return the approximation of the expression. + The approximation environment [fenv] maps idents to approximations. + Idents not bound in [fenv] approximate to [Value_unknown]. + The closure environment [cenv] maps idents to [ulambda] terms. + It is used to substitute environment accesses for free identifiers. *) + +exception NotClosed + +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 + | approx -> + let subst = try V.Map.find id cenv with Not_found -> Uvar id in + (subst, approx) + +let close_var env id = + let (ulam, _app) = close_approx_var env id in ulam + +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 = + Compilenv.new_structured_constant cst ~shared + in + Uconst_ref (name, Some cst) + in + let rec transl = function + | Const_base(Const_int n) -> Uconst_int n + | Const_base(Const_char c) -> Uconst_int (Char.code c) + | Const_pointer n -> Uconst_ptr n + | Const_block (tag, fields) -> + str (Uconst_block (tag, List.map transl fields)) + | Const_float_array sl -> + (* constant float arrays are really immutable *) + str (Uconst_float_array (List.map float_of_string sl)) + | Const_immstring s -> + str (Uconst_string s) + | Const_base (Const_string (s, _)) -> + (* Strings (even literal ones) must be assumed to be mutable... + except when OCaml has been configured with + -safe-string. Passing -safe-string at compilation + time is not enough, since the unit could be linked + with another one compiled without -safe-string, and + that one could modify our string literal. *) + str ~shared:Config.safe_string (Uconst_string s) + | Const_base(Const_float x) -> str (Uconst_float (float_of_string x)) + | Const_base(Const_int32 x) -> str (Uconst_int32 x) + | Const_base(Const_int64 x) -> str (Uconst_int64 x) + | Const_base(Const_nativeint x) -> str (Uconst_nativeint x) + in + make_const (transl cst) + | Lfunction _ as funct -> + close_one_function env (Ident.create_local "fun") funct + + (* We convert [f a] to [let a' = a in let f' = f in fun b c -> f' a' b c] + when fun_arity > nargs *) + | Lapply{ap_func = funct; ap_args = args; ap_loc = loc; + ap_inlined = attribute} -> + let nargs = List.length args in + 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 ~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 ~backend ~loc ~attribute fundesc ufunct uargs in + (app, strengthen_approx app approx_res) + + | ((ufunct, (Value_closure(fundesc, _) as fapprox)), uargs) + when nargs < fundesc.fun_arity -> + let first_args = List.map (fun arg -> + (V.create_local "arg", arg) ) uargs in + let final_args = + Array.to_list (Array.init (fundesc.fun_arity - nargs) + (fun _ -> V.create_local "arg")) in + let rec iter args body = + match args with + [] -> body + | (arg1, arg2) :: args -> + iter args + (Ulet (Immutable, Pgenval, VP.create arg1, arg2, body)) + in + let internal_args = + (List.map (fun (arg1, _arg2) -> Lvar arg1) first_args) + @ (List.map (fun arg -> Lvar arg ) final_args) + in + let funct_var = V.create_local "funct" in + let fenv = V.Map.add funct_var fapprox fenv in + let (new_fun, approx) = close { backend; fenv; cenv } + (Lfunction{ + kind = Curried; + return = Pgenval; + params = List.map (fun v -> v, Pgenval) final_args; + body = Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=(Lvar funct_var); + ap_args=internal_args; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}; + loc; + attr = default_function_attribute}) + in + let new_fun = + iter first_args + (Ulet (Immutable, Pgenval, VP.create funct_var, ufunct, new_fun)) + in + warning_if_forced_inline ~loc ~attribute "Partial application"; + (new_fun, approx) + + | ((ufunct, Value_closure(fundesc, _approx_res)), uargs) + when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity -> + let args = List.map (fun arg -> V.create_local "arg", arg) uargs in + let (first_args, rem_args) = split_list fundesc.fun_arity args in + let first_args = List.map (fun (id, _) -> Uvar id) first_args in + let rem_args = List.map (fun (id, _) -> Uvar id) rem_args in + let dbg = Debuginfo.from_location loc in + warning_if_forced_inline ~loc ~attribute "Over-application"; + let body = + Ugeneric_apply(direct_apply ~backend ~loc ~attribute + fundesc ufunct first_args, + rem_args, dbg) + in + let result = + List.fold_left (fun body (id, defining_expr) -> + Ulet (Immutable, Pgenval, VP.create id, defining_expr, body)) + body + args + in + result, Value_unknown + | ((ufunct, _), uargs) -> + let dbg = Debuginfo.from_location loc in + warning_if_forced_inline ~loc ~attribute "Unknown function"; + (Ugeneric_apply(ufunct, uargs, dbg), Value_unknown) + end + | Lsend(kind, met, obj, args, loc) -> + 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 env args, dbg), + Value_unknown) + | Llet(str, kind, id, lam, body) -> + let (ulam, alam) = close_named env id lam in + begin match (str, alam) with + (Variable, _) -> + 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 { backend; fenv = (V.Map.add id alam fenv); cenv } body + | (_, _) -> + 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) -> + if List.for_all + (function (_id, Lfunction _) -> true | _ -> false) + defs + then begin + (* Simple case: only function definitions *) + let (clos, infos) = close_functions env defs in + let clos_ident = V.create_local "clos" in + let fenv_body = + List.fold_right + (fun (id, _pos, approx) fenv -> V.Map.add id approx fenv) + infos fenv in + let (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 (backend, !Clflags.float_const_prop) sb + None ubody), + approx) + end else begin + (* General case: recursive definition of values *) + let rec clos_defs = function + [] -> ([], fenv) + | (id, lam) :: rem -> + let (udefs, fenv_body) = clos_defs rem 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 { 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 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 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 env arg), expr), approx + | Lprim((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _loc) -> + close env arg + | Lprim(Pdirapply,[funct;arg], loc) + | Lprim(Prevapply,[arg;funct], loc) -> + close env (Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=funct; + ap_args=[arg]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}) + | Lprim(Pgetglobal id, [], loc) -> + let dbg = Debuginfo.from_location loc in + check_constant_result (getglobal dbg id) + (Compilenv.global_approx id) + | Lprim(Pfield n, [lam], loc) -> + 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 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 env arg in + let dbg = Debuginfo.from_location loc in + (Uprim(P.Praise k, [ulam], dbg), + Value_unknown) + | Lprim (Pmakearray _, [], _loc) -> make_const_ref (Uconst_block (0, [])) + | Lprim(p, args, loc) -> + let p = Convert_primitives.convert p in + let dbg = Debuginfo.from_location loc in + simplif_prim ~backend !Clflags.float_const_prop + p (close_list_approx env args) dbg + | Lswitch(arg, sw, dbg) -> + let fn fail = + let (uarg, _) = close env arg in + let const_index, const_actions, fconst = + close_switch env sw.sw_consts sw.sw_numconsts fail + and block_index, block_actions, fblock = + close_switch env sw.sw_blocks sw.sw_numblocks fail in + let ulam = + Uswitch + (uarg, + {us_index_consts = const_index; + us_actions_consts = const_actions; + us_index_blocks = block_index; + us_actions_blocks = block_actions}, + Debuginfo.from_location dbg) + in + (fconst (fblock ulam),Value_unknown) in +(* NB: failaction might get copied, thus it should be some Lstaticraise *) + let fail = sw.sw_failaction in + begin match fail with + | None|Some (Lstaticraise (_,_)) -> fn fail + | Some lamfail -> + if + (sw.sw_numconsts - List.length sw.sw_consts) + + (sw.sw_numblocks - List.length sw.sw_blocks) > 1 + then + let i = next_raise_count () in + let ubody,_ = fn (Some (Lstaticraise (i,[]))) + and uhandler,_ = close env lamfail in + Ucatch (i,[],ubody,uhandler),Value_unknown + else fn fail + end + | Lstringswitch(arg,sw,d,_) -> + let uarg,_ = close env arg in + let usw = + List.map + (fun (s,act) -> + let uact,_ = close env act in + s,uact) + sw in + let ud = + Misc.may_map + (fun d -> + let ud,_ = close env d in + ud) d in + Ustringswitch (uarg,usw,ud),Value_unknown + | Lstaticraise (i, args) -> + (Ustaticfail (i, close_list env args), Value_unknown) + | Lstaticcatch(body, (i, vars), handler) -> + 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 env body in + let (uhandler, _) = close env handler in + (Utrywith(ubody, VP.create id, uhandler), Value_unknown) + | Lifthenelse(arg, ifso, ifnot) -> + begin match close env arg with + (uarg, Value_const (Uconst_ptr n)) -> + sequence_constant_expr uarg + (close env (if n = 0 then ifnot else ifso)) + | (uarg, _ ) -> + let (uifso, _) = close env ifso in + let (uifnot, _) = close env ifnot in + (Uifthenelse(uarg, uifso, uifnot), Value_unknown) + end + | Lsequence(lam1, lam2) -> + let (ulam1, _) = close env lam1 in + let (ulam2, approx) = close env lam2 in + (Usequence(ulam1, ulam2), approx) + | Lwhile(cond, body) -> + 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 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 env lam in + (Uassign(id, ulam), Value_unknown) + | Levent(lam, _) -> + close env lam + | Lifused _ -> + assert false + +and close_list env = function + [] -> [] + | lam :: rem -> + let (ulam, _) = close env lam in + ulam :: close_list env rem + +and close_list_approx env = function + [] -> ([], []) + | lam :: rem -> + let (ulam, approx) = close env lam in + let (ulams, approxs) = close_list_approx env rem in + (ulam :: ulams, approx :: approxs) + +and close_named env id = function + Lfunction _ as funct -> + close_one_function env id funct + | lam -> + close env lam + +(* Build a shared closure for a set of mutually recursive functions *) + +and close_functions { backend; fenv; cenv } fun_defs = + let fun_defs = + List.flatten + (List.map + (function + | (id, Lfunction{kind; params; return; body; attr; loc}) -> + Simplif.split_default_wrapper ~id ~kind ~params + ~body ~attr ~loc ~return + | _ -> assert false + ) + fun_defs) + in + let inline_attribute = match fun_defs with + | [_, Lfunction{attr = { inline; }}] -> inline + | _ -> Default_inline (* recursive functions can't be inlined *) + in + (* Update and check nesting depth *) + incr function_nesting_depth; + let initially_closed = + !function_nesting_depth < excessive_function_nesting_depth in + (* Determine the free variables of the functions *) + let fv = + V.Set.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in + (* Build the function descriptors for the functions. + Initially all functions are assumed not to need their environment + parameter. *) + let uncurried_defs = + List.map + (function + (id, Lfunction{kind; params; return; body; loc}) -> + let label = Compilenv.make_symbol (Some (V.unique_name id)) in + let arity = List.length params in + let fundesc = + {fun_label = label; + fun_arity = (if kind = Tupled then -arity else arity); + fun_closed = initially_closed; + fun_inline = None; + fun_float_const_prop = !Clflags.float_const_prop } in + let dbg = Debuginfo.from_location loc in + (id, params, return, body, fundesc, dbg) + | (_, _) -> fatal_error "Closure.close_functions") + fun_defs in + (* Build an approximate fenv for compiling the functions *) + let fenv_rec = + List.fold_right + (fun (id, _params, _return, _body, fundesc, _dbg) fenv -> + V.Map.add id (Value_closure(fundesc, Value_unknown)) fenv) + uncurried_defs fenv in + (* Determine the offsets of each function's closure in the shared block *) + let env_pos = ref (-1) in + let clos_offsets = + List.map + (fun (_id, _params, _return, _body, fundesc, _dbg) -> + let pos = !env_pos + 1 in + env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2); + pos) + uncurried_defs in + let fv_pos = !env_pos in + (* This reference will be set to false if the hypothesis that a function + does not use its environment parameter is invalidated. *) + let useless_env = ref initially_closed in + (* Translate each function definition *) + let clos_fundef (id, params, return, body, fundesc, dbg) env_pos = + let env_param = V.create_local "env" in + let cenv_fv = + build_closure_env env_param (fv_pos - env_pos) fv in + let cenv_body = + List.fold_right2 + (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 { 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 + then params + else params @ [env_param, Pgenval] + in + let f = + { + label = fundesc.fun_label; + arity = fundesc.fun_arity; + params = List.map (fun (var, kind) -> VP.create var, kind) fun_params; + return; + body = ubody; + dbg; + env = Some env_param; + } + in + (* give more chance of function with default parameters (i.e. + their wrapper functions) to be inlined *) + let n = + List.fold_left + (fun n (id, _) -> n + if V.name id = "*opt*" then 8 else 1) + 0 + fun_params + in + let threshold = + match inline_attribute with + | Default_inline -> + let inline_threshold = + Clflags.Float_arg_helper.get ~key:0 !Clflags.inline_threshold + in + let magic_scale_constant = 8. in + int_of_float (inline_threshold *. magic_scale_constant) + n + | Always_inline -> max_int + | Never_inline -> min_int + | Unroll _ -> assert false + in + let fun_params = List.map (fun (var, _) -> VP.create var) fun_params in + if lambda_smaller ubody threshold + then fundesc.fun_inline <- Some(fun_params, ubody); + + (f, (id, env_pos, Value_closure(fundesc, approx))) in + (* Translate all function definitions. *) + let clos_info_list = + if initially_closed then begin + let snap = Compilenv.snapshot () in + try List.map2 clos_fundef uncurried_defs clos_offsets + with NotClosed -> + (* If the hypothesis that the environment parameters are useless has been + invalidated, then set [fun_closed] to false in all descriptions and + recompile *) + Compilenv.backtrack snap; (* PR#6337 *) + List.iter + (fun (_id, _params, _return, _body, fundesc, _dbg) -> + fundesc.fun_closed <- false; + fundesc.fun_inline <- None; + ) + uncurried_defs; + useless_env := false; + List.map2 clos_fundef uncurried_defs clos_offsets + end else + (* Excessive closure nesting: assume environment parameter is used *) + List.map2 clos_fundef uncurried_defs clos_offsets + in + (* Update nesting depth *) + decr function_nesting_depth; + (* Return the Uclosure node and the list of all identifiers defined, + with offsets and approximations. *) + let (clos, infos) = List.split clos_info_list in + let fv = if !useless_env then [] else fv in + (Uclosure(clos, List.map (close_var { backend; fenv; cenv }) fv), infos) + +(* Same, for one non-recursive function *) + +and close_one_function env id funct = + match close_functions env [id, funct] with + | (clos, (i, _, approx) :: _) when id = i -> (clos, approx) + | _ -> fatal_error "Closure.close_one_function" + +(* Close a switch *) + +and close_switch env cases num_keys default = + let ncases = List.length cases in + let index = Array.make num_keys 0 + and store = Storer.mk_store () in + + (* First default case *) + begin match default with + | Some def when ncases < num_keys -> + assert (store.act_store () def = 0) + | _ -> () + end ; + (* Then all other cases *) + List.iter + (fun (key,lam) -> + index.(key) <- store.act_store () lam) + cases ; + + (* Explicit sharing with catch/exit, as switcher compilation may + later unshare *) + let acts = store.act_get_shared () in + let hs = ref (fun e -> e) in + + (* Compile actions *) + let actions = + Array.map + (function + | Single lam|Shared (Lstaticraise (_,[]) as lam) -> + let ulam,_ = close env lam in + ulam + | Shared lam -> + let ulam,_ = close env lam in + let i = next_raise_count () in +(* + let string_of_lambda e = + Printlambda.lambda Format.str_formatter e ; + Format.flush_str_formatter () in + Printf.eprintf "SHARE CLOSURE %i [%s]\n%s\n" i + (string_of_lambda arg) + (string_of_lambda lam) ; +*) + let ohs = !hs in + hs := (fun e -> Ucatch (i,[],ohs e,ulam)) ; + Ustaticfail (i,[])) + acts in + match actions with + | [| |] -> [| |], [| |], !hs (* May happen when default is None *) + | _ -> index, actions, !hs + + +(* Collect exported symbols for structured constants *) + +let collect_exported_structured_constants a = + let rec approx = function + | Value_closure (fd, a) -> + approx a; + begin match fd.fun_inline with + | Some (_, u) -> ulam u + | None -> () + end + | Value_tuple a -> Array.iter approx a + | Value_const c -> const c + | Value_unknown | Value_global_field _ -> () + and const = function + | Uconst_ref (s, (Some c)) -> + Compilenv.add_exported_constant s; + structured_constant c + | Uconst_ref (_s, None) -> assert false (* Cannot be generated *) + | Uconst_int _ | Uconst_ptr _ -> () + and structured_constant = function + | Uconst_block (_, ul) -> List.iter const ul + | Uconst_float _ | Uconst_int32 _ + | Uconst_int64 _ | Uconst_nativeint _ + | Uconst_float_array _ | Uconst_string _ -> () + | Uconst_closure _ -> assert false (* Cannot be generated *) + and ulam = function + | Uvar _ -> () + | Uconst c -> const c + | Udirect_apply (_, ul, _) -> List.iter ulam ul + | Ugeneric_apply (u, ul, _) -> ulam u; List.iter ulam ul + | Uclosure (fl, ul) -> + List.iter (fun f -> ulam f.body) fl; + List.iter ulam ul + | Uoffset(u, _) -> ulam u + | Ulet (_str, _kind, _, u1, u2) -> ulam u1; ulam u2 + | Uphantom_let _ -> no_phantom_lets () + | Uletrec (l, u) -> List.iter (fun (_, u) -> ulam u) l; ulam u + | Uprim (_, ul, _) -> List.iter ulam ul + | Uswitch (u, sl, _dbg) -> + ulam u; + Array.iter ulam sl.us_actions_consts; + Array.iter ulam sl.us_actions_blocks + | Ustringswitch (u,sw,d) -> + ulam u ; + List.iter (fun (_,act) -> ulam act) sw ; + Misc.may ulam d + | Ustaticfail (_, ul) -> List.iter ulam ul + | Ucatch (_, _, u1, u2) + | Utrywith (u1, _, u2) + | Usequence (u1, u2) + | Uwhile (u1, u2) -> ulam u1; ulam u2 + | Uifthenelse (u1, u2, u3) + | Ufor (_, u1, u2, _, u3) -> ulam u1; ulam u2; ulam u3 + | Uassign (_, u) -> ulam u + | Usend (_, u1, u2, ul, _) -> ulam u1; ulam u2; List.iter ulam ul + | Uunreachable -> () + in + approx a + +let reset () = + global_approx := [||]; + function_nesting_depth := 0 + +(* The entry point *) + +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 { backend; fenv = V.Map.empty; cenv = V.Map.empty } lam + in + let opaque = + !Clflags.opaque + || Env.is_imported_opaque (Compilenv.current_unit_name ()) + in + if opaque + then Compilenv.set_global_approx(Value_unknown) + else collect_exported_structured_constants (Value_tuple !global_approx); + global_approx := [||]; + ulam diff --git a/middle_end/closure/closure.mli b/middle_end/closure/closure.mli new file mode 100644 index 00000000..92c74732 --- /dev/null +++ b/middle_end/closure/closure.mli @@ -0,0 +1,24 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Introduction of closures, uncurrying, recognition of direct calls *) + +val intro + : backend:(module Backend_intf.S) + -> size:int + -> Lambda.lambda + -> Clambda.ulambda + +val reset : unit -> unit diff --git a/middle_end/closure_conversion.ml b/middle_end/closure_conversion.ml deleted file mode 100755 index a852ae8d..00000000 --- a/middle_end/closure_conversion.ml +++ /dev/null @@ -1,698 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module Env = Closure_conversion_aux.Env -module Function_decls = Closure_conversion_aux.Function_decls -module Function_decl = Function_decls.Function_decl -module Names = Internal_variable_names - -let name_expr = Flambda_utils.name_expr -let name_expr_from_var = Flambda_utils.name_expr_from_var - -type t = { - current_unit_id : Ident.t; - symbol_for_global' : (Ident.t -> Symbol.t); - filename : string; - mutable imported_symbols : Symbol.Set.t; - mutable declared_symbols : (Symbol.t * Flambda.constant_defining_value) list; -} - -let add_default_argument_wrappers lam = - let defs_are_all_functions (defs : (_ * Lambda.lambda) list) = - List.for_all (function (_, Lambda.Lfunction _) -> true | _ -> false) defs - in - let f (lam : Lambda.lambda) : Lambda.lambda = - match lam with - | Llet (( Strict | Alias | StrictOpt), _k, id, - Lfunction {kind; params; body = fbody; attr; loc}, body) -> - begin match - Simplif.split_default_wrapper ~id ~kind ~params - ~body:fbody ~return:Pgenval ~attr ~loc - with - | [fun_id, def] -> Llet (Alias, Pgenval, fun_id, def, body) - | [fun_id, def; inner_fun_id, def_inner] -> - Llet (Alias, Pgenval, inner_fun_id, def_inner, - Llet (Alias, Pgenval, fun_id, def, body)) - | _ -> assert false - end - | Lletrec (defs, body) as lam -> - if defs_are_all_functions defs then - let defs = - List.flatten - (List.map - (function - | (id, Lambda.Lfunction {kind; params; body; attr; loc}) -> - Simplif.split_default_wrapper ~id ~kind ~params ~body - ~return:Pgenval ~attr ~loc - | _ -> assert false) - defs) - in - Lletrec (defs, body) - else lam - | lam -> lam - in - Lambda.map f lam - -(** Generate a wrapper ("stub") function that accepts a tuple argument and - calls another function with arguments extracted in the obvious - manner from the tuple. *) -let tupled_function_call_stub original_params unboxed_version ~closure_bound_var - : Flambda.function_declaration = - let tuple_param_var = Variable.rename unboxed_version in - let params = List.map (fun p -> Variable.rename p) original_params in - let call : Flambda.t = - Apply ({ - func = unboxed_version; - args = params; - (* CR-someday mshinwell for mshinwell: investigate if there is some - redundancy here (func is also unboxed_version) *) - kind = Direct (Closure_id.wrap unboxed_version); - dbg = Debuginfo.none; - inline = Default_inline; - specialise = Default_specialise; - }) - in - let _, body = - List.fold_left (fun (pos, body) param -> - let lam : Flambda.named = - Prim (Pfield pos, [tuple_param_var], Debuginfo.none) - in - pos + 1, Flambda.create_let param lam body) - (0, call) params - in - let tuple_param = Parameter.wrap tuple_param_var in - Flambda.create_function_declaration ~params:[tuple_param] - ~body ~stub:true ~dbg:Debuginfo.none ~inline:Default_inline - ~specialise:Default_specialise ~is_a_functor:false - ~closure_origin:(Closure_origin.create (Closure_id.wrap closure_bound_var)) - -let register_const t (constant:Flambda.constant_defining_value) name - : Flambda.constant_defining_value_block_field * Internal_variable_names.t = - let var = Variable.create name in - let symbol = Symbol.of_variable var in - t.declared_symbols <- (symbol, constant) :: t.declared_symbols; - Symbol symbol, name - -let rec declare_const t (const : Lambda.structured_constant) - : Flambda.constant_defining_value_block_field * Internal_variable_names.t = - match const with - | Const_base (Const_int c) -> (Const (Int c), Names.const_int) - | Const_base (Const_char c) -> (Const (Char c), Names.const_char) - | Const_base (Const_string (s, _)) -> - let const, name = - if Config.safe_string then - (Flambda.Allocated_const (Immutable_string s), - Names.const_immstring) - else - (Flambda.Allocated_const (String s), - Names.const_string) - in - register_const t const name - | Const_base (Const_float c) -> - register_const t - (Allocated_const (Float (float_of_string c))) - Names.const_float - | Const_base (Const_int32 c) -> - register_const t (Allocated_const (Int32 c)) - Names.const_int32 - | Const_base (Const_int64 c) -> - register_const t (Allocated_const (Int64 c)) - Names.const_int64 - | Const_base (Const_nativeint c) -> - register_const t (Allocated_const (Nativeint c)) Names.const_nativeint - | Const_pointer c -> Const (Const_pointer c), Names.const_ptr - | Const_immstring c -> - register_const t (Allocated_const (Immutable_string c)) - Names.const_immstring - | Const_float_array c -> - register_const t - (Allocated_const (Immutable_float_array (List.map float_of_string c))) - Names.const_float_array - | Const_block (tag, consts) -> - let const : Flambda.constant_defining_value = - Block (Tag.create_exn tag, - List.map (fun c -> fst (declare_const t c)) consts) - in - register_const t const Names.const_block - -let close_const t (const : Lambda.structured_constant) - : Flambda.named * Internal_variable_names.t = - match declare_const t const with - | Const c, name -> - Const c, name - | Symbol s, name -> - Symbol s, name - -let rec close t env (lam : Lambda.lambda) : Flambda.t = - match lam with - | Lvar id -> - begin match Env.find_var_exn env id with - | var -> Var var - | exception Not_found -> - match Env.find_mutable_var_exn env id with - | mut_var -> - name_expr (Read_mutable mut_var) ~name:Names.read_mutable - | exception Not_found -> - Misc.fatal_errorf "Closure_conversion.close: unbound identifier %a" - Ident.print id - end - | Lconst cst -> - let cst, name = close_const t cst in - name_expr cst ~name - | Llet ((Strict | Alias | StrictOpt), _value_kind, id, defining_expr, body) -> - (* TODO: keep value_kind in flambda *) - let var = Variable.create_with_same_name_as_ident id in - let defining_expr = - close_let_bound_expression t var env defining_expr - in - let body = close t (Env.add_var env id var) body in - Flambda.create_let var defining_expr body - | Llet (Variable, block_kind, id, defining_expr, body) -> - let mut_var = Mutable_variable.create_with_same_name_as_ident id in - let var = Variable.create_with_same_name_as_ident id in - let defining_expr = - close_let_bound_expression t var env defining_expr - in - let body = close t (Env.add_mutable_var env id mut_var) body in - Flambda.create_let var defining_expr - (Let_mutable - { var = mut_var; - initial_value = var; - body; - contents_kind = block_kind }) - | Lfunction { kind; params; body; attr; loc; } -> - let name = Names.anon_fn_with_loc loc in - let closure_bound_var = Variable.create name in - (* CR-soon mshinwell: some of this is now very similar to the let rec case - below *) - let set_of_closures_var = Variable.create Names.set_of_closures in - let set_of_closures = - let decl = - Function_decl.create ~let_rec_ident:None ~closure_bound_var ~kind - ~params:(List.map fst params) ~body ~attr ~loc - in - close_functions t env (Function_decls.create [decl]) - in - let project_closure : Flambda.project_closure = - { set_of_closures = set_of_closures_var; - closure_id = Closure_id.wrap closure_bound_var; - } - in - Flambda.create_let set_of_closures_var set_of_closures - (name_expr (Project_closure (project_closure)) ~name) - | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall = _; - ap_inlined; ap_specialised; } -> - Lift_code.lifting_helper (close_list t env ap_args) - ~evaluation_order:`Right_to_left - ~name:Names.apply_arg - ~create_body:(fun args -> - let func = close t env ap_func in - let func_var = Variable.create Names.apply_funct in - Flambda.create_let func_var (Expr func) - (Apply ({ - func = func_var; - args; - kind = Indirect; - dbg = Debuginfo.from_location ap_loc; - inline = ap_inlined; - specialise = ap_specialised; - }))) - | Lletrec (defs, body) -> - let env = - List.fold_right (fun (id, _) env -> - Env.add_var env id (Variable.create_with_same_name_as_ident id)) - defs env - in - let function_declarations = - (* Identify any bindings in the [let rec] that are functions. These - will be named after the corresponding identifier in the [let rec]. *) - List.map (function - | (let_rec_ident, - Lambda.Lfunction { kind; params; body; attr; loc }) -> - let closure_bound_var = - Variable.create_with_same_name_as_ident let_rec_ident - in - let function_declaration = - Function_decl.create ~let_rec_ident:(Some let_rec_ident) - ~closure_bound_var ~kind ~params:(List.map fst params) ~body - ~attr ~loc - in - Some function_declaration - | _ -> None) - defs - in - begin match - Misc.Stdlib.List.some_if_all_elements_are_some function_declarations - with - | Some function_declarations -> - (* When all the bindings are (syntactically) functions, we can - eliminate the [let rec] construction, instead producing a normal - [Let] that binds a set of closures containing all of the functions. - *) - (* CR-someday lwhite: This is a very syntactic criteria. Adding an - unused value to a set of recursive bindings changes how - functions are represented at runtime. *) - let set_of_closures_var = Variable.create (Names.set_of_closures) in - let set_of_closures = - close_functions t env (Function_decls.create function_declarations) - in - let body = - List.fold_left (fun body decl -> - let let_rec_ident = Function_decl.let_rec_ident decl in - let closure_bound_var = Function_decl.closure_bound_var decl in - let let_bound_var = Env.find_var env let_rec_ident in - (* Inside the body of the [let], each function is referred to by - a [Project_closure] expression, which projects from the set of - closures. *) - (Flambda.create_let let_bound_var - (Project_closure { - set_of_closures = set_of_closures_var; - closure_id = Closure_id.wrap closure_bound_var; - }) - body)) - (close t env body) function_declarations - in - Flambda.create_let set_of_closures_var set_of_closures body - | None -> - (* If the condition above is not satisfied, we build a [Let_rec] - expression; any functions bound by it will have their own - individual closures. *) - let defs = - List.map (fun (id, def) -> - let var = Env.find_var env id in - var, close_let_bound_expression t ~let_rec_ident:id var env def) - defs - in - Let_rec (defs, close t env body) - end - | Lsend (kind, meth, obj, args, loc) -> - let meth_var = Variable.create Names.meth in - let obj_var = Variable.create Names.obj in - let dbg = Debuginfo.from_location loc in - Flambda.create_let meth_var (Expr (close t env meth)) - (Flambda.create_let obj_var (Expr (close t env obj)) - (Lift_code.lifting_helper (close_list t env args) - ~evaluation_order:`Right_to_left - ~name:Names.send_arg - ~create_body:(fun args -> - Send { kind; meth = meth_var; obj = obj_var; args; dbg; }))) - | Lprim ((Pdivint Safe | Pmodint Safe - | Pdivbint { is_safe = Safe } | Pmodbint { is_safe = Safe }) as prim, - [arg1; arg2], loc) - when not !Clflags.unsafe -> - let arg2 = close t env arg2 in - let arg1 = close t env arg1 in - let numerator = Variable.create Names.numerator in - let denominator = Variable.create Names.denominator in - let zero = Variable.create Names.zero in - let is_zero = Variable.create Names.is_zero in - let exn = Variable.create Names.division_by_zero in - let exn_symbol = - t.symbol_for_global' Predef.ident_division_by_zero - in - let dbg = Debuginfo.from_location loc in - let zero_const : Flambda.named = - match prim with - | Pdivint _ | Pmodint _ -> - Const (Int 0) - | Pdivbint { size = Pint32 } | Pmodbint { size = Pint32 } -> - Allocated_const (Int32 0l) - | Pdivbint { size = Pint64 } | Pmodbint { size = Pint64 } -> - Allocated_const (Int64 0L) - | Pdivbint { size = Pnativeint } | Pmodbint { size = Pnativeint } -> - Allocated_const (Nativeint 0n) - | _ -> assert false - in - let prim : Lambda.primitive = - match prim with - | Pdivint _ -> Pdivint Unsafe - | Pmodint _ -> Pmodint Unsafe - | Pdivbint { size } -> Pdivbint { size; is_safe = Unsafe } - | Pmodbint { size } -> Pmodbint { size; is_safe = Unsafe } - | _ -> assert false - in - let comparison : Lambda.primitive = - match prim with - | Pdivint _ | Pmodint _ -> Pintcomp Ceq - | Pdivbint { size } | Pmodbint { size } -> Pbintcomp (size,Ceq) - | _ -> assert false - in - t.imported_symbols <- Symbol.Set.add exn_symbol t.imported_symbols; - Flambda.create_let zero zero_const - (Flambda.create_let exn (Symbol exn_symbol) - (Flambda.create_let denominator (Expr arg2) - (Flambda.create_let numerator (Expr arg1) - (Flambda.create_let is_zero - (Prim (comparison, [zero; denominator], dbg)) - (If_then_else (is_zero, - name_expr (Prim (Praise Raise_regular, [exn], dbg)) - ~name:Names.dummy, - (* CR-someday pchambart: find the right event. - mshinwell: I briefly looked at this, and couldn't - figure it out. - lwhite: I don't think any of the existing events - are suitable. I had to add a new one for a similar - case in the array data types work. - mshinwell: deferred CR *) - name_expr ~name:Names.result - (Prim (prim, [numerator; denominator], dbg)))))))) - | Lprim ((Pdivint Safe | Pmodint Safe - | Pdivbint { is_safe = Safe } | Pmodbint { is_safe = Safe }), _, _) - when not !Clflags.unsafe -> - Misc.fatal_error "Pdivint / Pmodint must have exactly two arguments" - | Lprim (Psequor, [arg1; arg2], _) -> - let arg1 = close t env arg1 in - let arg2 = close t env arg2 in - let const_true = Variable.create Names.const_true in - let cond = Variable.create Names.cond_sequor in - Flambda.create_let const_true (Const (Const_pointer 1)) - (Flambda.create_let cond (Expr arg1) - (If_then_else (cond, Var const_true, arg2))) - | Lprim (Psequand, [arg1; arg2], _) -> - let arg1 = close t env arg1 in - let arg2 = close t env arg2 in - let const_false = Variable.create Names.const_false in - let cond = Variable.create Names.const_sequand in - Flambda.create_let const_false (Const (Const_pointer 0)) - (Flambda.create_let cond (Expr arg1) - (If_then_else (cond, arg2, Var const_false))) - | Lprim ((Psequand | Psequor), _, _) -> - Misc.fatal_error "Psequand / Psequor must have exactly two arguments" - | Lprim (Pidentity, [arg], _) -> close t env arg - | Lprim (Pdirapply, [funct; arg], loc) - | Lprim (Prevapply, [arg; funct], loc) -> - let apply : Lambda.lambda_apply = - { ap_func = funct; - ap_args = [arg]; - ap_loc = loc; - ap_should_be_tailcall = false; - (* CR-someday lwhite: it would be nice to be able to give - inlined attributes to functions applied with the application - operators. *) - ap_inlined = Default_inline; - ap_specialised = Default_specialise; - } - in - close t env (Lambda.Lapply apply) - | Lprim (Praise kind, [arg], loc) -> - let arg_var = Variable.create Names.raise_arg in - let dbg = Debuginfo.from_location loc in - Flambda.create_let arg_var (Expr (close t env arg)) - (name_expr - (Prim (Praise kind, [arg_var], dbg)) - ~name:Names.raise) - | Lprim (Pfield _, [Lprim (Pgetglobal id, [],_)], _) - when Ident.same id t.current_unit_id -> - Misc.fatal_errorf "[Pfield (Pgetglobal ...)] for the current compilation \ - unit is forbidden upon entry to the middle end" - | Lprim (Psetfield (_, _, _), [Lprim (Pgetglobal _, [], _); _], _) -> - Misc.fatal_errorf "[Psetfield (Pgetglobal ...)] is \ - forbidden upon entry to the middle end" - | Lprim (Pgetglobal id, [], _) when Ident.is_predef id -> - let symbol = t.symbol_for_global' id in - t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols; - name_expr (Symbol symbol) ~name:Names.predef_exn - | Lprim (Pgetglobal id, [], _) -> - assert (not (Ident.same id t.current_unit_id)); - let symbol = t.symbol_for_global' id in - t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols; - name_expr (Symbol symbol) ~name:Names.pgetglobal - | Lprim (p, args, loc) -> - (* One of the important consequences of the ANF-like representation - here is that we obtain names corresponding to the components of - blocks being made (with [Pmakeblock]). This information can be used - by the simplification pass to increase the likelihood of eliminating - the allocation, since some field accesses can be tracked back to known - field values. *) - let dbg = Debuginfo.from_location loc in - Lift_code.lifting_helper (close_list t env args) - ~evaluation_order:`Right_to_left - ~name:(Names.of_primitive_arg p) - ~create_body:(fun args -> - name_expr (Prim (p, args, dbg)) - ~name:(Names.of_primitive p)) - | Lswitch (arg, sw, _loc) -> - let scrutinee = Variable.create Names.switch in - let aux (i, lam) = i, close t env lam in - let nums sw_num cases default = - let module I = Numbers.Int in - match default with - | Some _ -> - I.zero_to_n (sw_num - 1) - | None -> - List.fold_left (fun set (i, _) -> I.Set.add i set) I.Set.empty cases - in - Flambda.create_let scrutinee (Expr (close t env arg)) - (Switch (scrutinee, - { numconsts = nums sw.sw_numconsts sw.sw_consts sw.sw_failaction; - consts = List.map aux sw.sw_consts; - numblocks = nums sw.sw_numblocks sw.sw_blocks sw.sw_failaction; - blocks = List.map aux sw.sw_blocks; - failaction = Misc.may_map (close t env) sw.sw_failaction; - })) - | Lstringswitch (arg, sw, def, _) -> - let scrutinee = Variable.create Names.string_switch in - Flambda.create_let scrutinee (Expr (close t env arg)) - (String_switch (scrutinee, - List.map (fun (s, e) -> s, close t env e) sw, - Misc.may_map (close t env) def)) - | Lstaticraise (i, args) -> - Lift_code.lifting_helper (close_list t env args) - ~evaluation_order:`Right_to_left - ~name:Names.staticraise_arg - ~create_body:(fun args -> - let static_exn = Env.find_static_exception env i in - Static_raise (static_exn, args)) - | Lstaticcatch (body, (i, ids), handler) -> - let st_exn = Static_exception.create () in - let env = Env.add_static_exception env i st_exn in - let ids = List.map fst ids in - let vars = List.map Variable.create_with_same_name_as_ident ids in - Static_catch (st_exn, vars, close t env body, - close t (Env.add_vars env ids vars) handler) - | Ltrywith (body, id, handler) -> - let var = Variable.create_with_same_name_as_ident id in - Try_with (close t env body, var, close t (Env.add_var env id var) handler) - | Lifthenelse (cond, ifso, ifnot) -> - let cond = close t env cond in - let cond_var = Variable.create Names.cond in - Flambda.create_let cond_var (Expr cond) - (If_then_else (cond_var, close t env ifso, close t env ifnot)) - | Lsequence (lam1, lam2) -> - let var = Variable.create Names.sequence in - let lam1 = Flambda.Expr (close t env lam1) in - let lam2 = close t env lam2 in - Flambda.create_let var lam1 lam2 - | Lwhile (cond, body) -> While (close t env cond, close t env body) - | Lfor (id, lo, hi, direction, body) -> - let bound_var = Variable.create_with_same_name_as_ident id in - let from_value = Variable.create Names.for_from in - let to_value = Variable.create Names.for_to in - let body = close t (Env.add_var env id bound_var) body in - Flambda.create_let from_value (Expr (close t env lo)) - (Flambda.create_let to_value (Expr (close t env hi)) - (For { bound_var; from_value; to_value; direction; body; })) - | Lassign (id, new_value) -> - let being_assigned = - match Env.find_mutable_var_exn env id with - | being_assigned -> being_assigned - | exception Not_found -> - Misc.fatal_errorf "Closure_conversion.close: unbound mutable \ - variable %s in assignment" - (Ident.unique_name id) - in - let new_value_var = Variable.create Names.new_value in - Flambda.create_let new_value_var (Expr (close t env new_value)) - (Assign { being_assigned; new_value = new_value_var; }) - | Levent (lam, _) -> close t env lam - | Lifused _ -> - (* [Lifused] is used to mark that this expression should be alive only if - an identifier is. Every use should have been removed by - [Simplif.simplify_lets], either by replacing by the inner expression, - or by completely removing it (replacing by unit). *) - Misc.fatal_error "[Lifused] should have been removed by \ - [Simplif.simplify_lets]" - -(** Perform closure conversion on a set of function declarations, returning a - set of closures. (The set will often only contain a single function; - the only case where it cannot is for "let rec".) *) -and close_functions t external_env function_declarations : Flambda.named = - let closure_env_without_parameters = - Function_decls.closure_env_without_parameters - external_env function_declarations - in - let all_free_idents = Function_decls.all_free_idents function_declarations in - let close_one_function map decl = - let body = Function_decl.body decl in - let loc = Function_decl.loc decl in - let dbg = Debuginfo.from_location loc in - let params = Function_decl.params decl in - (* Create fresh variables for the elements of the closure (cf. - the comment on [Function_decl.closure_env_without_parameters], above). - This induces a renaming on [Function_decl.free_idents]; the results of - that renaming are stored in [free_variables]. *) - let closure_env = - List.fold_right (fun id env -> - Env.add_var env id (Variable.create_with_same_name_as_ident id)) - params closure_env_without_parameters - in - (* If the function is the wrapper for a function with an optional - argument with a default value, make sure it always gets inlined. - CR-someday pchambart: eta-expansion wrapper for a primitive are - not marked as stub but certainly should *) - let stub = Function_decl.stub decl in - let param_vars = List.map (Env.find_var closure_env) params in - let params = List.map Parameter.wrap param_vars in - let closure_bound_var = Function_decl.closure_bound_var decl in - let unboxed_version = Variable.rename closure_bound_var in - let body = close t closure_env body in - let closure_origin = - Closure_origin.create (Closure_id.wrap unboxed_version) - in - let fun_decl = - Flambda.create_function_declaration ~params ~body ~stub ~dbg - ~inline:(Function_decl.inline decl) - ~specialise:(Function_decl.specialise decl) - ~is_a_functor:(Function_decl.is_a_functor decl) - ~closure_origin - in - match Function_decl.kind decl with - | Curried -> Variable.Map.add closure_bound_var fun_decl map - | Tupled -> - let unboxed_version = Variable.rename closure_bound_var in - let generic_function_stub = - tupled_function_call_stub param_vars unboxed_version ~closure_bound_var - in - Variable.Map.add unboxed_version fun_decl - (Variable.Map.add closure_bound_var generic_function_stub map) - in - let function_decls = - let is_classic_mode = !Clflags.classic_inlining in - let funs = - List.fold_left close_one_function Variable.Map.empty - (Function_decls.to_list function_declarations) - in - Flambda.create_function_declarations ~is_classic_mode ~funs - in - (* The closed representation of a set of functions is a "set of closures". - (For avoidance of doubt, the runtime representation of the *whole set* is - a single block with tag [Closure_tag].) *) - let set_of_closures = - let free_vars = - Ident.Set.fold (fun var map -> - let internal_var = - Env.find_var closure_env_without_parameters var - in - let external_var : Flambda.specialised_to = - { var = Env.find_var external_env var; - projection = None; - } - in - Variable.Map.add internal_var external_var map) - all_free_idents Variable.Map.empty - in - Flambda.create_set_of_closures ~function_decls ~free_vars - ~specialised_args:Variable.Map.empty - ~direct_call_surrogates:Variable.Map.empty - in - Set_of_closures set_of_closures - -and close_list t sb l = List.map (close t sb) l - -and close_let_bound_expression t ?let_rec_ident let_bound_var env - (lam : Lambda.lambda) : Flambda.named = - match lam with - | Lfunction { kind; params; body; attr; loc; } -> - (* Ensure that [let] and [let rec]-bound functions have appropriate - names. *) - let closure_bound_var = Variable.rename let_bound_var in - let decl = - Function_decl.create ~let_rec_ident ~closure_bound_var ~kind - ~params:(List.map fst params) ~body ~attr ~loc - in - let set_of_closures_var = Variable.rename let_bound_var in - let set_of_closures = - close_functions t env (Function_decls.create [decl]) - in - let project_closure : Flambda.project_closure = - { set_of_closures = set_of_closures_var; - closure_id = Closure_id.wrap closure_bound_var; - } - in - Expr (Flambda.create_let set_of_closures_var set_of_closures - (name_expr_from_var (Project_closure (project_closure)) - ~var:let_bound_var)) - | lam -> Expr (close t env lam) - -let lambda_to_flambda ~backend ~module_ident ~size ~filename lam - : Flambda.program = - let lam = add_default_argument_wrappers lam in - let module Backend = (val backend : Backend_intf.S) in - let compilation_unit = Compilation_unit.get_current_exn () in - let t = - { current_unit_id = Compilation_unit.get_persistent_ident compilation_unit; - symbol_for_global' = Backend.symbol_for_global'; - filename; - imported_symbols = Symbol.Set.empty; - declared_symbols = []; - } - in - let module_symbol = Backend.symbol_for_global' module_ident in - let block_symbol = - let var = Variable.create Internal_variable_names.module_as_block in - Symbol.of_variable var - in - (* The global module block is built by accessing the fields of all the - introduced symbols. *) - (* CR-soon mshinwell for mshinwell: Add a comment describing how modules are - compiled. *) - let fields = - Array.init size (fun pos -> - let sym_v = Variable.create Names.block_symbol in - let result_v = Variable.create Names.block_symbol_get in - let value_v = Variable.create Names.block_symbol_get_field in - Flambda.create_let - sym_v (Symbol block_symbol) - (Flambda.create_let result_v - (Prim (Pfield 0, [sym_v], Debuginfo.none)) - (Flambda.create_let value_v - (Prim (Pfield pos, [result_v], Debuginfo.none)) - (Var value_v)))) - in - let module_initializer : Flambda.program_body = - Initialize_symbol ( - block_symbol, - Tag.create_exn 0, - [close t Env.empty lam], - Initialize_symbol ( - module_symbol, - Tag.create_exn 0, - Array.to_list fields, - End module_symbol)) - in - let program_body = - List.fold_left - (fun program_body (symbol, constant) : Flambda.program_body -> - Let_symbol (symbol, constant, program_body)) - module_initializer - t.declared_symbols - in - { imported_symbols = t.imported_symbols; - program_body; - } diff --git a/middle_end/closure_conversion.mli b/middle_end/closure_conversion.mli deleted file mode 100644 index f5fab0a7..00000000 --- a/middle_end/closure_conversion.mli +++ /dev/null @@ -1,53 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Generation of [Flambda] intermediate language code from [Lambda] code - by performing a form of closure conversion. - - Function declarations (which may bind one or more variables identifying - functions, possibly with mutual recursion) are transformed to - [Set_of_closures] expressions. [Project_closure] expressions are then - used to select a closure for a particular function from a [Set_of_closures] - expression. The [Set_of_closures] expressions say nothing about the - actual runtime layout of the closures; this is handled when [Flambda] code - is translated to [Clambda] code. - - The following transformations are also performed during closure - conversion: - - Constant blocks (by which is meant things wrapped in [Lambda.Const_block]) - are converted to applications of the [Pmakeblock] primitive. - - [Levent] debugging event nodes are removed and the information within - them attached to function, method and [raise] calls. - - Tuplified functions are converted to curried functions and a stub - function emitted to call the curried version. For example: - let rec f (x, y) = f (x + 1, y + 1) - is transformed to: - let rec internal_f x y = f (x + 1,y + 1) - and f (x, y) = internal_f x y (* [f] is marked as a stub function *) - - The [Pdirapply] and [Prevapply] application primitives are removed and - converted to normal [Flambda] application nodes. - - The [lambda_to_flambda] function is not re-entrant. -*) -val lambda_to_flambda - : backend:(module Backend_intf.S) - -> module_ident:Ident.t - -> size:int - -> filename:string - -> Lambda.lambda - -> Flambda.program diff --git a/middle_end/closure_conversion_aux.ml b/middle_end/closure_conversion_aux.ml deleted file mode 100644 index cfcaf34d..00000000 --- a/middle_end/closure_conversion_aux.ml +++ /dev/null @@ -1,184 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module Env = struct - type t = { - variables : Variable.t Ident.tbl; - mutable_variables : Mutable_variable.t Ident.tbl; - static_exceptions : Static_exception.t Numbers.Int.Map.t; - globals : Symbol.t Numbers.Int.Map.t; - at_toplevel : bool; - } - - let empty = { - variables = Ident.empty; - mutable_variables = Ident.empty; - static_exceptions = Numbers.Int.Map.empty; - globals = Numbers.Int.Map.empty; - at_toplevel = true; - } - - let clear_local_bindings env = - { empty with globals = env.globals } - - let add_var t id var = { t with variables = Ident.add id var t.variables } - let add_vars t ids vars = List.fold_left2 add_var t ids vars - - let find_var t id = - try Ident.find_same id t.variables - with Not_found -> - Misc.fatal_errorf "Closure_conversion.Env.find_var: %s@ %s" - (Ident.unique_name id) - (Printexc.raw_backtrace_to_string (Printexc.get_callstack 42)) - - let find_var_exn t id = - Ident.find_same id t.variables - - let add_mutable_var t id mutable_var = - { t with mutable_variables = Ident.add id mutable_var t.mutable_variables } - - let find_mutable_var_exn t id = - Ident.find_same id t.mutable_variables - - let add_static_exception t st_exn fresh_st_exn = - { t with - static_exceptions = - Numbers.Int.Map.add st_exn fresh_st_exn t.static_exceptions } - - let find_static_exception t st_exn = - try Numbers.Int.Map.find st_exn t.static_exceptions - with Not_found -> - Misc.fatal_error ("Closure_conversion.Env.find_static_exception: exn " - ^ Int.to_string st_exn) - - let add_global t pos symbol = - { t with globals = Numbers.Int.Map.add pos symbol t.globals } - - let find_global t pos = - try Numbers.Int.Map.find pos t.globals - with Not_found -> - Misc.fatal_error ("Closure_conversion.Env.find_global: global " - ^ Int.to_string pos) - - let at_toplevel t = t.at_toplevel - - let not_at_toplevel t = { t with at_toplevel = false; } -end - -module Function_decls = struct - module Function_decl = struct - type t = { - let_rec_ident : Ident.t; - closure_bound_var : Variable.t; - kind : Lambda.function_kind; - params : Ident.t list; - body : Lambda.lambda; - free_idents_of_body : Ident.Set.t; - attr : Lambda.function_attribute; - loc : Location.t; - } - - let create ~let_rec_ident ~closure_bound_var ~kind ~params ~body - ~attr ~loc = - let let_rec_ident = - match let_rec_ident with - | None -> Ident.create_local "unnamed_function" - | Some let_rec_ident -> let_rec_ident - in - { let_rec_ident; - closure_bound_var; - kind; - params; - body; - free_idents_of_body = Lambda.free_variables body; - attr; - loc; - } - - let let_rec_ident t = t.let_rec_ident - let closure_bound_var t = t.closure_bound_var - let kind t = t.kind - let params t = t.params - let body t = t.body - let free_idents t = t.free_idents_of_body - let inline t = t.attr.inline - let specialise t = t.attr.specialise - let is_a_functor t = t.attr.is_a_functor - let stub t = t.attr.stub - let loc t = t.loc - - end - - type t = { - function_decls : Function_decl.t list; - all_free_idents : Ident.Set.t; - } - - (* All identifiers free in the bodies of the given function declarations, - indexed by the identifiers corresponding to the functions themselves. *) - let free_idents_by_function function_decls = - List.fold_right (fun decl map -> - Variable.Map.add (Function_decl.closure_bound_var decl) - (Function_decl.free_idents decl) map) - function_decls Variable.Map.empty - - let all_free_idents function_decls = - Variable.Map.fold (fun _ -> Ident.Set.union) - (free_idents_by_function function_decls) Ident.Set.empty - - (* All identifiers of simultaneously-defined functions in [ts]. *) - let let_rec_idents function_decls = - List.map Function_decl.let_rec_ident function_decls - - (* All parameters of functions in [ts]. *) - let all_params function_decls = - List.concat (List.map Function_decl.params function_decls) - - let set_diff (from : Ident.Set.t) (idents : Ident.t list) = - List.fold_right Ident.Set.remove idents from - - (* CR-someday lwhite: use a different name from above or explain the - difference *) - let all_free_idents function_decls = - set_diff (set_diff (all_free_idents function_decls) - (all_params function_decls)) - (let_rec_idents function_decls) - - let create function_decls = - { function_decls; - all_free_idents = all_free_idents function_decls; - } - - let to_list t = t.function_decls - - let all_free_idents t = t.all_free_idents - - let closure_env_without_parameters external_env t = - let closure_env = - (* For "let rec"-bound functions. *) - List.fold_right (fun function_decl env -> - Env.add_var env (Function_decl.let_rec_ident function_decl) - (Function_decl.closure_bound_var function_decl)) - t.function_decls (Env.clear_local_bindings external_env) - in - (* For free variables. *) - Ident.Set.fold (fun id env -> - Env.add_var env id (Variable.create_with_same_name_as_ident id)) - t.all_free_idents closure_env -end diff --git a/middle_end/closure_conversion_aux.mli b/middle_end/closure_conversion_aux.mli deleted file mode 100755 index f16f05f0..00000000 --- a/middle_end/closure_conversion_aux.mli +++ /dev/null @@ -1,94 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Environments and auxiliary structures used during closure conversion. *) - -(** Used to remember which [Variable.t] values correspond to which - [Ident.t] values during closure conversion, and similarly for - static exception identifiers. *) -module Env : sig - type t - - val empty : t - - val add_var : t -> Ident.t -> Variable.t -> t - val add_vars : t -> Ident.t list -> Variable.t list -> t - - val find_var : t -> Ident.t -> Variable.t - val find_var_exn : t -> Ident.t -> Variable.t - - val add_mutable_var : t -> Ident.t -> Mutable_variable.t -> t - val find_mutable_var_exn : t -> Ident.t -> Mutable_variable.t - - val add_static_exception : t -> int -> Static_exception.t -> t - val find_static_exception : t -> int -> Static_exception.t - - val add_global : t -> int -> Symbol.t -> t - val find_global : t -> int -> Symbol.t - - val at_toplevel : t -> bool - val not_at_toplevel : t -> t -end - -(** Used to represent information about a set of function declarations - during closure conversion. (The only case in which such a set may - contain more than one declaration is when processing "let rec".) *) -module Function_decls : sig - module Function_decl : sig - type t - - val create - : let_rec_ident:Ident.t option - -> closure_bound_var:Variable.t - -> kind:Lambda.function_kind - -> params:Ident.t list - -> body:Lambda.lambda - -> attr:Lambda.function_attribute - -> loc:Location.t - -> t - - val let_rec_ident : t -> Ident.t - val closure_bound_var : t -> Variable.t - val kind : t -> Lambda.function_kind - val params : t -> Ident.t list - val body : t -> Lambda.lambda - val inline : t -> Lambda.inline_attribute - val specialise : t -> Lambda.specialise_attribute - val is_a_functor : t -> bool - val stub : t -> bool - val loc : t -> Location.t - - (* Like [all_free_idents], but for just one function. *) - val free_idents : t -> Ident.Set.t - end - - type t - - val create : Function_decl.t list -> t - val to_list : t -> Function_decl.t list - - (* All identifiers free in the given function declarations after the binding - of parameters and function identifiers has been performed. *) - val all_free_idents : t -> Ident.Set.t - - (* A map from identifiers to their corresponding [Variable.t]s whose domain - is the set of all identifiers free in the bodies of the declarations that - are not bound as parameters. - It also contains the globals bindings of the provided environment. *) - val closure_env_without_parameters : Env.t -> t -> Env.t -end diff --git a/middle_end/compilation_unit.ml b/middle_end/compilation_unit.ml new file mode 100644 index 00000000..7fb48167 --- /dev/null +++ b/middle_end/compilation_unit.ml @@ -0,0 +1,78 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type t = { + id : Ident.t; + linkage_name : Linkage_name.t; + hash : int; +} + +let string_for_printing t = Ident.name t.id + +include Identifiable.Make (struct + type nonrec t = t + + (* Multiple units can have the same [id] if they come from different packs. + To distinguish these we also keep the linkage name, which contains the + name of the pack. *) + let compare v1 v2 = + if v1 == v2 then 0 + else + let c = compare v1.hash v2.hash in + if c = 0 then + let v1_id = Ident.name v1.id in + let v2_id = Ident.name v2.id in + let c = String.compare v1_id v2_id in + if c = 0 then + Linkage_name.compare v1.linkage_name v2.linkage_name + else + c + else c + + let equal x y = + if x == y then true + else compare x y = 0 + + let print ppf t = Format.pp_print_string ppf (string_for_printing t) + + let output oc x = output_string oc (Ident.name x.id) + let hash x = x.hash +end) + +let create (id : Ident.t) linkage_name = + if not (Ident.persistent id) then begin + Misc.fatal_error "Compilation_unit.create with non-persistent Ident.t" + end; + { id; linkage_name; hash = Hashtbl.hash (Ident.name id); } + +let get_persistent_ident cu = cu.id +let get_linkage_name cu = cu.linkage_name + +let current = ref None +let is_current arg = + match !current with + | None -> Misc.fatal_error "Current compilation unit is not set!" + | Some cur -> equal cur arg +let set_current t = current := Some t +let get_current () = !current +let get_current_exn () = + match !current with + | Some current -> current + | None -> Misc.fatal_error "Compilation_unit.get_current_exn" +let get_current_id_exn () = get_persistent_ident (get_current_exn ()) diff --git a/middle_end/compilation_unit.mli b/middle_end/compilation_unit.mli new file mode 100644 index 00000000..fc7d3bfd --- /dev/null +++ b/middle_end/compilation_unit.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +include Identifiable.S + +(* The [Ident.t] must be persistent. This function raises an exception + if that is not the case. *) +val create : Ident.t -> Linkage_name.t -> t + +val get_persistent_ident : t -> Ident.t +val get_linkage_name : t -> Linkage_name.t + +val is_current : t -> bool +val set_current : t -> unit +val get_current : unit -> t option +val get_current_exn : unit -> t +val get_current_id_exn : unit -> Ident.t + +val string_for_printing : t -> string diff --git a/middle_end/compilenv.ml b/middle_end/compilenv.ml new file mode 100644 index 00000000..add4e90e --- /dev/null +++ b/middle_end/compilenv.ml @@ -0,0 +1,452 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2010 Institut National de Recherche en Informatique et *) +(* en Automatique *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Compilation environments for compilation units *) + +[@@@ocaml.warning "+a-4-9-40-41-42"] + +open Config +open Cmx_format + +type error = + Not_a_unit_info of string + | Corrupted_unit_info of string + | Illegal_renaming of string * string * string + +exception Error of error + +let global_infos_table = + (Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t) +let export_infos_table = + (Hashtbl.create 10 : (string, Export_info.t) Hashtbl.t) + +let imported_sets_of_closures_table = + (Set_of_closures_id.Tbl.create 10 + : Simple_value_approx.function_declarations option + Set_of_closures_id.Tbl.t) + +module CstMap = + Map.Make(struct + type t = Clambda.ustructured_constant + let compare = Clambda.compare_structured_constants + (* PR#6442: it is incorrect to use Stdlib.compare on values of type t + because it compares "0.0" and "-0.0" equal. *) + end) + +type structured_constants = + { + strcst_shared: string CstMap.t; + strcst_all: (string * Clambda.ustructured_constant) list; + } + +let structured_constants_empty = + { + strcst_shared = CstMap.empty; + strcst_all = []; + } + +let structured_constants = ref structured_constants_empty + + +let exported_constants = Hashtbl.create 17 + +let merged_environment = ref Export_info.empty + +let default_ui_export_info = + if Config.flambda then + Cmx_format.Flambda Export_info.empty + else + Cmx_format.Clambda Value_unknown + +let current_unit = + { ui_name = ""; + ui_symbol = ""; + ui_defines = []; + ui_imports_cmi = []; + ui_imports_cmx = []; + ui_curry_fun = []; + ui_apply_fun = []; + ui_send_fun = []; + ui_force_link = false; + ui_export_info = default_ui_export_info } + +let symbolname_for_pack pack name = + match pack with + | None -> name + | Some p -> + let b = Buffer.create 64 in + for i = 0 to String.length p - 1 do + match p.[i] with + | '.' -> Buffer.add_string b "__" + | c -> Buffer.add_char b c + done; + Buffer.add_string b "__"; + Buffer.add_string b name; + Buffer.contents b + +let unit_id_from_name name = Ident.create_persistent name + +let concat_symbol unitname id = + unitname ^ "__" ^ id + +let make_symbol ?(unitname = current_unit.ui_symbol) idopt = + let prefix = "caml" ^ unitname in + match idopt with + | None -> prefix + | Some id -> concat_symbol prefix id + +let current_unit_linkage_name () = + Linkage_name.create (make_symbol ~unitname:current_unit.ui_symbol None) + +let reset ?packname name = + Hashtbl.clear global_infos_table; + Set_of_closures_id.Tbl.clear imported_sets_of_closures_table; + let symbol = symbolname_for_pack packname name in + current_unit.ui_name <- name; + current_unit.ui_symbol <- symbol; + current_unit.ui_defines <- [symbol]; + current_unit.ui_imports_cmi <- []; + current_unit.ui_imports_cmx <- []; + current_unit.ui_curry_fun <- []; + current_unit.ui_apply_fun <- []; + current_unit.ui_send_fun <- []; + current_unit.ui_force_link <- !Clflags.link_everything; + Hashtbl.clear exported_constants; + structured_constants := structured_constants_empty; + current_unit.ui_export_info <- default_ui_export_info; + merged_environment := Export_info.empty; + Hashtbl.clear export_infos_table; + let compilation_unit = + Compilation_unit.create + (Ident.create_persistent name) + (current_unit_linkage_name ()) + in + Compilation_unit.set_current compilation_unit + +let current_unit_infos () = + current_unit + +let current_unit_name () = + current_unit.ui_name + +let symbol_in_current_unit name = + let prefix = "caml" ^ current_unit.ui_symbol in + name = prefix || + (let lp = String.length prefix in + String.length name >= 2 + lp + && String.sub name 0 lp = prefix + && name.[lp] = '_' + && name.[lp + 1] = '_') + +let read_unit_info filename = + let ic = open_in_bin filename in + try + let buffer = really_input_string ic (String.length cmx_magic_number) in + if buffer <> cmx_magic_number then begin + close_in ic; + raise(Error(Not_a_unit_info filename)) + end; + let ui = (input_value ic : unit_infos) in + let crc = Digest.input ic in + close_in ic; + (ui, crc) + with End_of_file | Failure _ -> + close_in ic; + raise(Error(Corrupted_unit_info(filename))) + +let read_library_info filename = + let ic = open_in_bin filename in + let buffer = really_input_string ic (String.length cmxa_magic_number) in + if buffer <> cmxa_magic_number then + raise(Error(Not_a_unit_info filename)); + let infos = (input_value ic : library_infos) in + close_in ic; + infos + + +(* Read and cache info on global identifiers *) + +let get_global_info global_ident = ( + let modname = Ident.name global_ident in + if modname = current_unit.ui_name then + Some current_unit + else begin + try + Hashtbl.find global_infos_table modname + with Not_found -> + let (infos, crc) = + if Env.is_imported_opaque modname then (None, None) + else begin + try + let filename = + Load_path.find_uncap (modname ^ ".cmx") in + let (ui, crc) = read_unit_info filename in + if ui.ui_name <> modname then + raise(Error(Illegal_renaming(modname, ui.ui_name, filename))); + (Some ui, Some crc) + with Not_found -> + let warn = Warnings.No_cmx_file modname in + Location.prerr_warning Location.none warn; + (None, None) + end + in + current_unit.ui_imports_cmx <- + (modname, crc) :: current_unit.ui_imports_cmx; + Hashtbl.add global_infos_table modname infos; + infos + end +) + +let cache_unit_info ui = + Hashtbl.add global_infos_table ui.ui_name (Some ui) + +(* Return the approximation of a global identifier *) + +let get_clambda_approx ui = + assert(not Config.flambda); + match ui.ui_export_info with + | Flambda _ -> assert false + | Clambda approx -> approx + +let toplevel_approx : + (string, Clambda.value_approximation) Hashtbl.t = Hashtbl.create 16 + +let record_global_approx_toplevel () = + Hashtbl.add toplevel_approx current_unit.ui_name + (get_clambda_approx current_unit) + +let global_approx id = + if Ident.is_predef id then Clambda.Value_unknown + else try Hashtbl.find toplevel_approx (Ident.name id) + with Not_found -> + match get_global_info id with + | None -> Clambda.Value_unknown + | Some ui -> get_clambda_approx ui + +(* Return the symbol used to refer to a global identifier *) + +let symbol_for_global id = + if Ident.is_predef id then + "caml_exn_" ^ Ident.name id + else begin + let unitname = Ident.name id in + match + try ignore (Hashtbl.find toplevel_approx unitname); None + with Not_found -> get_global_info id + with + | None -> make_symbol ~unitname:(Ident.name id) None + | Some ui -> make_symbol ~unitname:ui.ui_symbol None + end + +(* Register the approximation of the module being compiled *) + +let unit_for_global id = + let sym_label = Linkage_name.create (symbol_for_global id) in + Compilation_unit.create id sym_label + +let predefined_exception_compilation_unit = + Compilation_unit.create (Ident.create_persistent "__dummy__") + (Linkage_name.create "__dummy__") + +let is_predefined_exception sym = + Compilation_unit.equal + predefined_exception_compilation_unit + (Symbol.compilation_unit sym) + +let symbol_for_global' id = + let sym_label = Linkage_name.create (symbol_for_global id) in + if Ident.is_predef id then + Symbol.of_global_linkage predefined_exception_compilation_unit sym_label + else + Symbol.of_global_linkage (unit_for_global id) sym_label + +let set_global_approx approx = + assert(not Config.flambda); + current_unit.ui_export_info <- Clambda approx + +(* Exporting and importing cross module information *) + +let get_flambda_export_info ui = + assert(Config.flambda); + match ui.ui_export_info with + | Clambda _ -> assert false + | Flambda ei -> ei + +let set_export_info export_info = + assert(Config.flambda); + current_unit.ui_export_info <- Flambda export_info + +let approx_for_global comp_unit = + let id = Compilation_unit.get_persistent_ident comp_unit in + if (Compilation_unit.equal + predefined_exception_compilation_unit + comp_unit) + || Ident.is_predef id + || not (Ident.global id) + then invalid_arg (Format.asprintf "approx_for_global %a" Ident.print id); + let modname = Ident.name id in + match Hashtbl.find export_infos_table modname with + | otherwise -> Some otherwise + | exception Not_found -> + match get_global_info id with + | None -> None + | Some ui -> + let exported = get_flambda_export_info ui in + Hashtbl.add export_infos_table modname exported; + merged_environment := Export_info.merge !merged_environment exported; + Some exported + +let approx_env () = !merged_environment + +(* Record that a currying function or application function is needed *) + +let need_curry_fun n = + if not (List.mem n current_unit.ui_curry_fun) then + current_unit.ui_curry_fun <- n :: current_unit.ui_curry_fun + +let need_apply_fun n = + assert(n > 0); + if not (List.mem n current_unit.ui_apply_fun) then + current_unit.ui_apply_fun <- n :: current_unit.ui_apply_fun + +let need_send_fun n = + if not (List.mem n current_unit.ui_send_fun) then + current_unit.ui_send_fun <- n :: current_unit.ui_send_fun + +(* Write the description of the current unit *) + +let write_unit_info info filename = + let oc = open_out_bin filename in + output_string oc cmx_magic_number; + output_value oc info; + flush oc; + let crc = Digest.file filename in + Digest.output oc crc; + close_out oc + +let save_unit_info filename = + current_unit.ui_imports_cmi <- Env.imports(); + write_unit_info current_unit filename + +let current_unit () = + match Compilation_unit.get_current () with + | Some current_unit -> current_unit + | None -> Misc.fatal_error "Compilenv.current_unit" + +let current_unit_symbol () = + Symbol.of_global_linkage (current_unit ()) (current_unit_linkage_name ()) + +let const_label = ref 0 + +let new_const_symbol () = + incr const_label; + make_symbol (Some (Int.to_string !const_label)) + +let snapshot () = !structured_constants +let backtrack s = structured_constants := s + +let new_structured_constant cst ~shared = + let {strcst_shared; strcst_all} = !structured_constants in + if shared then + try + CstMap.find cst strcst_shared + with Not_found -> + let lbl = new_const_symbol() in + structured_constants := + { + strcst_shared = CstMap.add cst lbl strcst_shared; + strcst_all = (lbl, cst) :: strcst_all; + }; + lbl + else + let lbl = new_const_symbol() in + structured_constants := + { + strcst_shared; + strcst_all = (lbl, cst) :: strcst_all; + }; + lbl + +let add_exported_constant s = + Hashtbl.replace exported_constants s () + +let clear_structured_constants () = + structured_constants := structured_constants_empty + +let structured_constants () = + let provenance : Clambda.usymbol_provenance = + { original_idents = []; + module_path = + Path.Pident (Ident.create_persistent (current_unit_name ())); + } + in + List.map + (fun (symbol, definition) -> + { + Clambda.symbol; + exported = Hashtbl.mem exported_constants symbol; + definition; + provenance = Some provenance; + }) + (!structured_constants).strcst_all + +let closure_symbol fv = + let compilation_unit = Closure_id.get_compilation_unit fv in + let unitname = + Linkage_name.to_string (Compilation_unit.get_linkage_name compilation_unit) + in + let linkage_name = + concat_symbol unitname ((Closure_id.unique_name fv) ^ "_closure") + in + Symbol.of_global_linkage compilation_unit (Linkage_name.create linkage_name) + +let function_label fv = + let compilation_unit = Closure_id.get_compilation_unit fv in + let unitname = + Linkage_name.to_string + (Compilation_unit.get_linkage_name compilation_unit) + in + (concat_symbol unitname (Closure_id.unique_name fv)) + +let require_global global_ident = + if not (Ident.is_predef global_ident) then + ignore (get_global_info global_ident : Cmx_format.unit_infos option) + +(* Error report *) + +open Format + +let report_error ppf = function + | Not_a_unit_info filename -> + fprintf ppf "%a@ is not a compilation unit description." + Location.print_filename filename + | Corrupted_unit_info filename -> + fprintf ppf "Corrupted compilation unit description@ %a" + Location.print_filename filename + | Illegal_renaming(name, modname, filename) -> + fprintf ppf "%a@ contains the description for unit\ + @ %s when %s was expected" + Location.print_filename filename name modname + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/middle_end/compilenv.mli b/middle_end/compilenv.mli new file mode 100644 index 00000000..569d51ea --- /dev/null +++ b/middle_end/compilenv.mli @@ -0,0 +1,153 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2010 Institut National de Recherche en Informatique et *) +(* en Automatique *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Compilation environments for compilation units *) + +open Cmx_format + +(* CR-soon mshinwell: this is a bit ugly + mshinwell: deferred CR, this has been addressed in the export info + improvement feature. +*) +val imported_sets_of_closures_table + : Simple_value_approx.function_declarations option Set_of_closures_id.Tbl.t + (* flambda-only *) + +val reset: ?packname:string -> string -> unit + (* Reset the environment and record the name of the unit being + compiled (arg). Optional argument is [-for-pack] prefix. *) + +val unit_id_from_name: string -> Ident.t + (* flambda-only *) + +val current_unit_infos: unit -> unit_infos + (* Return the infos for the unit being compiled *) + +val current_unit_name: unit -> string + (* Return the name of the unit being compiled + clambda-only *) + +val current_unit_linkage_name: unit -> Linkage_name.t + (* Return the linkage_name of the unit being compiled. + flambda-only *) + +val current_unit: unit -> Compilation_unit.t + (* flambda-only *) + +val current_unit_symbol: unit -> Symbol.t + (* flambda-only *) + +val make_symbol: ?unitname:string -> string option -> string + (* [make_symbol ~unitname:u None] returns the asm symbol that + corresponds to the compilation unit [u] (default: the current unit). + [make_symbol ~unitname:u (Some id)] returns the asm symbol that + corresponds to symbol [id] in the compilation unit [u] + (or the current unit). *) + +val symbol_in_current_unit: string -> bool + (* Return true if the given asm symbol belongs to the + current compilation unit, false otherwise. *) + +val is_predefined_exception: Symbol.t -> bool + (* flambda-only *) + +val unit_for_global: Ident.t -> Compilation_unit.t + (* flambda-only *) + +val symbol_for_global: Ident.t -> string + (* Return the asm symbol that refers to the given global identifier + flambda-only *) +val symbol_for_global': Ident.t -> Symbol.t + (* flambda-only *) +val global_approx: Ident.t -> Clambda.value_approximation + (* Return the approximation for the given global identifier + clambda-only *) +val set_global_approx: Clambda.value_approximation -> unit + (* Record the approximation of the unit being compiled + clambda-only *) +val record_global_approx_toplevel: unit -> unit + (* Record the current approximation for the current toplevel phrase + clambda-only *) + +val set_export_info: Export_info.t -> unit + (* Record the information of the unit being compiled + flambda-only *) +val approx_env: unit -> Export_info.t + (* Returns all the information loaded from external compilation units + flambda-only *) +val approx_for_global: Compilation_unit.t -> Export_info.t option + (* Loads the exported information declaring the compilation_unit + flambda-only *) + +val need_curry_fun: int -> unit +val need_apply_fun: int -> unit +val need_send_fun: int -> unit + (* Record the need of a currying (resp. application, + message sending) function with the given arity *) + +val new_const_symbol : unit -> string +val closure_symbol : Closure_id.t -> Symbol.t + (* Symbol of a function if the function is + closed (statically allocated) + flambda-only *) +val function_label : Closure_id.t -> string + (* linkage name of the code of a function + flambda-only *) + +val new_structured_constant: + Clambda.ustructured_constant -> + shared:bool -> (* can be shared with another structurally equal constant *) + string +val structured_constants: + unit -> Clambda.preallocated_constant list +val clear_structured_constants: unit -> unit +val add_exported_constant: string -> unit + (* clambda-only *) +type structured_constants + (* clambda-only *) +val snapshot: unit -> structured_constants + (* clambda-only *) +val backtrack: structured_constants -> unit + (* clambda-only *) + +val read_unit_info: string -> unit_infos * Digest.t + (* Read infos and MD5 from a [.cmx] file. *) +val write_unit_info: unit_infos -> string -> unit + (* Save the given infos in the given file *) +val save_unit_info: string -> unit + (* Save the infos for the current unit in the given file *) +val cache_unit_info: unit_infos -> unit + (* Enter the given infos in the cache. The infos will be + honored by [symbol_for_global] and [global_approx] + without looking at the corresponding .cmx file. *) + +val require_global: Ident.t -> unit + (* Enforce a link dependency of the current compilation + unit to the required module *) + +val read_library_info: string -> library_infos + +type error = + Not_a_unit_info of string + | Corrupted_unit_info of string + | Illegal_renaming of string * string * string + +exception Error of error + +val report_error: Format.formatter -> error -> unit diff --git a/middle_end/convert_primitives.ml b/middle_end/convert_primitives.ml new file mode 100644 index 00000000..17d17ea8 --- /dev/null +++ b/middle_end/convert_primitives.ml @@ -0,0 +1,153 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2017 OCamlPro SAS *) +(* Copyright 2017 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +let convert_unsafety is_unsafe : Clambda_primitives.is_safe = + if is_unsafe then + Unsafe + else + Safe + +let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = + match prim with + | Pmakeblock (tag, mutability, shape) -> + Pmakeblock (tag, mutability, shape) + | Pfield field -> Pfield field + | Pfield_computed -> Pfield_computed + | Psetfield (field, imm_or_pointer, init_or_assign) -> + Psetfield (field, imm_or_pointer, init_or_assign) + | Psetfield_computed (imm_or_pointer, init_or_assign) -> + Psetfield_computed (imm_or_pointer, init_or_assign) + | Pfloatfield field -> Pfloatfield field + | Psetfloatfield (field, init_or_assign) -> + Psetfloatfield (field, init_or_assign) + | Pduprecord (repr, size) -> Pduprecord (repr, size) + | Pccall prim -> Pccall prim + | Praise kind -> Praise kind + | Psequand -> Psequand + | Psequor -> Psequor + | Pnot -> Pnot + | Pnegint -> Pnegint + | Paddint -> Paddint + | Psubint -> Psubint + | Pmulint -> Pmulint + | Pdivint is_safe -> Pdivint is_safe + | Pmodint is_safe -> Pmodint is_safe + | Pandint -> Pandint + | Porint -> Porint + | Pxorint -> Pxorint + | Plslint -> Plslint + | Plsrint -> Plsrint + | Pasrint -> Pasrint + | Pintcomp comp -> Pintcomp comp + | Poffsetint offset -> Poffsetint offset + | Poffsetref offset -> Poffsetref offset + | Pintoffloat -> Pintoffloat + | Pfloatofint -> Pfloatofint + | Pnegfloat -> Pnegfloat + | Pabsfloat -> Pabsfloat + | Paddfloat -> Paddfloat + | Psubfloat -> Psubfloat + | Pmulfloat -> Pmulfloat + | Pdivfloat -> Pdivfloat + | Pfloatcomp comp -> Pfloatcomp comp + | Pstringlength -> Pstringlength + | Pstringrefu -> Pstringrefu + | Pstringrefs -> Pstringrefs + | Pbyteslength -> Pbyteslength + | Pbytesrefu -> Pbytesrefu + | Pbytessetu -> Pbytessetu + | Pbytesrefs -> Pbytesrefs + | Pbytessets -> Pbytessets + | Pmakearray (kind, mutability) -> Pmakearray (kind, mutability) + | Pduparray (kind, mutability) -> Pduparray (kind, mutability) + | Parraylength kind -> Parraylength kind + | Parrayrefu kind -> Parrayrefu kind + | Parraysetu kind -> Parraysetu kind + | Parrayrefs kind -> Parrayrefs kind + | Parraysets kind -> Parraysets kind + | Pisint -> Pisint + | Pisout -> Pisout + | Pcvtbint (src, dest) -> Pcvtbint (src, dest) + | Pnegbint bi -> Pnegbint bi + | Paddbint bi -> Paddbint bi + | Psubbint bi -> Psubbint bi + | Pmulbint bi -> Pmulbint bi + | Pbintofint bi -> Pbintofint bi + | Pintofbint bi -> Pintofbint bi + | Pandbint bi -> Pandbint bi + | Porbint bi -> Porbint bi + | Pxorbint bi -> Pxorbint bi + | Plslbint bi -> Plslbint bi + | Plsrbint bi -> Plsrbint bi + | Pasrbint bi -> Pasrbint bi + | Pbbswap bi -> Pbbswap bi + | Pdivbint { size; is_safe } -> Pdivbint { size; is_safe } + | Pmodbint { size; is_safe } -> Pmodbint { size; is_safe } + | Pbintcomp (bi, comp) -> Pbintcomp (bi, comp) + | Pbigarrayref (safe, dims, kind, layout) -> + Pbigarrayref (safe, dims, kind, layout) + | Pbigarrayset (safe, dims, kind, layout) -> + Pbigarrayset (safe, dims, kind, layout) + | Pstring_load_16 is_unsafe -> + Pstring_load (Sixteen, convert_unsafety is_unsafe) + | Pstring_load_32 is_unsafe -> + Pstring_load (Thirty_two, convert_unsafety is_unsafe) + | Pstring_load_64 is_unsafe -> + Pstring_load (Sixty_four, convert_unsafety is_unsafe) + | Pbytes_load_16 is_unsafe -> + Pbytes_load (Sixteen, convert_unsafety is_unsafe) + | Pbytes_load_32 is_unsafe -> + Pbytes_load (Thirty_two, convert_unsafety is_unsafe) + | Pbytes_load_64 is_unsafe -> + Pbytes_load (Sixty_four, convert_unsafety is_unsafe) + | Pbytes_set_16 is_unsafe -> + Pbytes_set (Sixteen, convert_unsafety is_unsafe) + | Pbytes_set_32 is_unsafe -> + Pbytes_set (Thirty_two, convert_unsafety is_unsafe) + | Pbytes_set_64 is_unsafe -> + Pbytes_set (Sixty_four, convert_unsafety is_unsafe) + | Pbigstring_load_16 is_unsafe -> + Pbigstring_load (Sixteen, convert_unsafety is_unsafe) + | Pbigstring_load_32 is_unsafe -> + Pbigstring_load (Thirty_two, convert_unsafety is_unsafe) + | Pbigstring_load_64 is_unsafe -> + Pbigstring_load (Sixty_four, convert_unsafety is_unsafe) + | Pbigstring_set_16 is_unsafe -> + Pbigstring_set (Sixteen, convert_unsafety is_unsafe) + | Pbigstring_set_32 is_unsafe -> + Pbigstring_set (Thirty_two, convert_unsafety is_unsafe) + | Pbigstring_set_64 is_unsafe -> + Pbigstring_set (Sixty_four, convert_unsafety is_unsafe) + | Pbigarraydim dim -> Pbigarraydim dim + | Pbswap16 -> Pbswap16 + | Pint_as_pointer -> Pint_as_pointer + | Popaque -> Popaque + + | Pbytes_to_string + | Pbytes_of_string + | Pctconst _ + | Pignore + | Prevapply + | Pdirapply + | Pidentity + | Pgetglobal _ + | Psetglobal _ + -> + Misc.fatal_errorf "lambda primitive %a can't be converted to \ + clambda primitive" + Printlambda.primitive prim diff --git a/middle_end/convert_primitives.mli b/middle_end/convert_primitives.mli new file mode 100644 index 00000000..8c369126 --- /dev/null +++ b/middle_end/convert_primitives.mli @@ -0,0 +1,17 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2017 OCamlPro SAS *) +(* Copyright 2017 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +val convert : Lambda.primitive -> Clambda_primitives.primitive diff --git a/middle_end/debuginfo.ml b/middle_end/debuginfo.ml deleted file mode 100644 index 7a339022..00000000 --- a/middle_end/debuginfo.ml +++ /dev/null @@ -1,145 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open! Int_replace_polymorphic_compare -open Lexing -open Location - -type item = { - dinfo_file: string; - dinfo_line: int; - dinfo_char_start: int; - dinfo_char_end: int; - dinfo_start_bol: int; - dinfo_end_bol: int; - dinfo_end_line: int; -} - -type t = item list - -let none = [] - -let is_none = function - | [] -> true - | _ :: _ -> false - -let to_string dbg = - match dbg with - | [] -> "" - | ds -> - let items = - List.map - (fun d -> - Printf.sprintf "%s:%d,%d-%d" - d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end) - ds - in - "{" ^ String.concat ";" items ^ "}" - -let item_from_location loc = - let valid_endpos = - String.equal loc.loc_end.pos_fname loc.loc_start.pos_fname in - { dinfo_file = loc.loc_start.pos_fname; - dinfo_line = loc.loc_start.pos_lnum; - dinfo_char_start = loc.loc_start.pos_cnum - loc.loc_start.pos_bol; - dinfo_char_end = - if valid_endpos - then loc.loc_end.pos_cnum - loc.loc_start.pos_bol - else loc.loc_start.pos_cnum - loc.loc_start.pos_bol; - dinfo_start_bol = loc.loc_start.pos_bol; - dinfo_end_bol = - if valid_endpos then loc.loc_end.pos_bol - else loc.loc_start.pos_bol; - dinfo_end_line = - if valid_endpos then loc.loc_end.pos_lnum - else loc.loc_start.pos_lnum; - } - -let from_location loc = - if loc == Location.none then [] else [item_from_location loc] - -let to_location = function - | [] -> Location.none - | d :: _ -> - let loc_start = - { pos_fname = d.dinfo_file; - pos_lnum = d.dinfo_line; - pos_bol = d.dinfo_start_bol; - pos_cnum = d.dinfo_start_bol + d.dinfo_char_start; - } in - let loc_end = - { pos_fname = d.dinfo_file; - pos_lnum = d.dinfo_end_line; - pos_bol = d.dinfo_end_bol; - pos_cnum = d.dinfo_start_bol + d.dinfo_char_end; - } in - { loc_ghost = false; loc_start; loc_end; } - -let inline loc t = - if loc == Location.none then t - else (item_from_location loc) :: t - -let concat dbg1 dbg2 = - dbg1 @ dbg2 - -(* CR-someday afrisch: FWIW, the current compare function does not seem very - good, since it reverses the two lists. I don't know how long the lists are, - nor if the specific currently implemented ordering is useful in other - contexts, but if one wants to use Map, a more efficient comparison should - be considered. *) -let compare dbg1 dbg2 = - let rec loop ds1 ds2 = - match ds1, ds2 with - | [], [] -> 0 - | _ :: _, [] -> 1 - | [], _ :: _ -> -1 - | d1 :: ds1, d2 :: ds2 -> - let c = String.compare d1.dinfo_file d2.dinfo_file in - if c <> 0 then c else - let c = compare d1.dinfo_line d2.dinfo_line in - if c <> 0 then c else - let c = compare d1.dinfo_char_end d2.dinfo_char_end in - if c <> 0 then c else - let c = compare d1.dinfo_char_start d2.dinfo_char_start in - if c <> 0 then c else - let c = compare d1.dinfo_start_bol d2.dinfo_start_bol in - if c <> 0 then c else - let c = compare d1.dinfo_end_bol d2.dinfo_end_bol in - if c <> 0 then c else - let c = compare d1.dinfo_end_line d2.dinfo_end_line in - if c <> 0 then c else - loop ds1 ds2 - in - loop (List.rev dbg1) (List.rev dbg2) - -let hash t = - List.fold_left (fun hash item -> Hashtbl.hash (hash, item)) 0 t - -let rec print_compact ppf t = - let print_item item = - Format.fprintf ppf "%a:%i" - Location.print_filename item.dinfo_file - item.dinfo_line; - if item.dinfo_char_start >= 0 then begin - Format.fprintf ppf ",%i--%i" item.dinfo_char_start item.dinfo_char_end - end - in - match t with - | [] -> () - | [item] -> print_item item - | item::t -> - print_item item; - Format.fprintf ppf ";"; - print_compact ppf t diff --git a/middle_end/debuginfo.mli b/middle_end/debuginfo.mli deleted file mode 100644 index 4dc5e599..00000000 --- a/middle_end/debuginfo.mli +++ /dev/null @@ -1,46 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type item = private { - dinfo_file: string; - dinfo_line: int; - dinfo_char_start: int; - dinfo_char_end: int; - dinfo_start_bol: int; - dinfo_end_bol: int; - dinfo_end_line: int; -} - -type t = item list - -val none : t - -val is_none : t -> bool - -val to_string : t -> string - -val from_location : Location.t -> t - -val to_location : t -> Location.t - -val concat: t -> t -> t - -val inline: Location.t -> t -> t - -val compare : t -> t -> int - -val hash : t -> int - -val print_compact : Format.formatter -> t -> unit diff --git a/middle_end/effect_analysis.ml b/middle_end/effect_analysis.ml deleted file mode 100644 index b5ab6186..00000000 --- a/middle_end/effect_analysis.ml +++ /dev/null @@ -1,60 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let no_effects_prim (prim : Lambda.primitive) = - match Semantics_of_primitives.for_primitive prim with - | (No_effects | Only_generative_effects), (No_coeffects | Has_coeffects) -> - true - | _ -> false - -let rec no_effects (flam : Flambda.t) = - match flam with - | Var _ -> true - | Let { defining_expr; body; _ } -> - no_effects_named defining_expr && no_effects body - | Let_mutable { body } -> no_effects body - | Let_rec (defs, body) -> - no_effects body - && List.for_all (fun (_, def) -> no_effects_named def) defs - | If_then_else (_, ifso, ifnot) -> no_effects ifso && no_effects ifnot - | Switch (_, sw) -> - let aux (_, flam) = no_effects flam in - List.for_all aux sw.blocks - && List.for_all aux sw.consts - && Misc.Stdlib.Option.value_default no_effects sw.failaction - ~default:true - | String_switch (_, sw, def) -> - List.for_all (fun (_, lam) -> no_effects lam) sw - && Misc.Stdlib.Option.value_default no_effects def - ~default:true - | Static_catch (_, _, body, _) | Try_with (body, _, _) -> - (* If there is a [raise] in [body], the whole [Try_with] may have an - effect, so there is no need to test the handler. *) - no_effects body - | While _ | For _ | Apply _ | Send _ | Assign _ | Static_raise _ -> false - | Proved_unreachable -> true - -and no_effects_named (named : Flambda.named) = - match named with - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ - | Set_of_closures _ | Project_closure _ | Project_var _ - | Move_within_set_of_closures _ -> true - | Prim (prim, _, _) -> no_effects_prim prim - | Expr flam -> no_effects flam diff --git a/middle_end/effect_analysis.mli b/middle_end/effect_analysis.mli deleted file mode 100644 index b025bf0f..00000000 --- a/middle_end/effect_analysis.mli +++ /dev/null @@ -1,27 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Simple side effect analysis. *) - -(* CR-someday pchambart: Replace by call to [Purity] module. - mshinwell: Where is the [Purity] module? *) -(** Conservative approximation as to whether a given Flambda expression may - have any side effects. *) -val no_effects : Flambda.t -> bool - -val no_effects_named : Flambda.named -> bool diff --git a/middle_end/extract_projections.ml b/middle_end/extract_projections.ml deleted file mode 100644 index 33cd473e..00000000 --- a/middle_end/extract_projections.ml +++ /dev/null @@ -1,190 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module A = Simple_value_approx -module E = Inline_and_simplify_aux.Env - -(* CR-soon pchambart: should we restrict only to cases - when the field is aliased to a variable outside - of the closure (i.e. when we can certainly remove - the allocation of the block) ? - Note that this may prevent cases with imbricated - closures from benefiting from this transformations. - mshinwell: What word was "imbricated" supposed to be? - (The code this referred to has been deleted, but the same thing is - probably still happening). -*) - -let known_valid_projections ~env ~projections ~which_variables = - Projection.Set.filter (fun projection -> - let from = Projection.projecting_from projection in - let outer_var = - match Variable.Map.find from which_variables with - | exception Not_found -> assert false - | (outer_var : Flambda.specialised_to) -> - Freshening.apply_variable (E.freshening env) outer_var.var - in - let approx = E.find_exn env outer_var in - match projection with - | Project_var project_var -> - begin match A.check_approx_for_closure approx with - | Ok (_value_closure, _approx_var, _approx_sym, - value_set_of_closures) -> - Var_within_closure.Map.mem project_var.var - value_set_of_closures.bound_vars - | Wrong -> false - end - | Project_closure project_closure -> - begin match A.strict_check_approx_for_set_of_closures approx with - | Ok (_var, value_set_of_closures) -> - Variable.Set.mem (Closure_id.unwrap project_closure.closure_id) - (Variable.Map.keys value_set_of_closures.function_decls.funs) - | Wrong -> false - end - | Move_within_set_of_closures move -> - begin match A.check_approx_for_closure approx with - | Ok (value_closure, _approx_var, _approx_sym, - _value_set_of_closures) -> - (* We could check that [move.move_to] is in [value_set_of_closures], - but this is unnecessary, since [Closure_id]s are unique. *) - Closure_id.equal value_closure.closure_id move.start_from - | Wrong -> false - end - | Field (field_index, _) -> - match A.check_approx_for_block approx with - | Wrong -> false - | Ok (_tag, fields) -> - field_index >= 0 && field_index < Array.length fields) - projections - -let rec analyse_expr ~which_variables expr = - let projections = ref Projection.Set.empty in - let used_which_variables = ref Variable.Set.empty in - let check_free_variable var = - if Variable.Map.mem var which_variables then begin - used_which_variables := Variable.Set.add var !used_which_variables - end - in - let for_expr (expr : Flambda.expr) = - match expr with - | Var var - | Let_mutable { initial_value = var } -> - check_free_variable var - (* CR-soon mshinwell: We don't handle [Apply] for the moment to - avoid disabling unboxing optimizations whenever we see a recursive - call. We should improve this analysis. Leo says this can be - done by a similar thing to the unused argument analysis. *) - | Apply _ -> () - | Send { meth; obj; args; _ } -> - check_free_variable meth; - check_free_variable obj; - List.iter check_free_variable args - | Assign { new_value; _ } -> - check_free_variable new_value - | If_then_else (var, _, _) - | Switch (var, _) - | String_switch (var, _, _) -> - check_free_variable var - | Static_raise (_, args) -> - List.iter check_free_variable args - | For { from_value; to_value; _ } -> - check_free_variable from_value; - check_free_variable to_value - | Let _ | Let_rec _ | Static_catch _ | While _ | Try_with _ - | Proved_unreachable -> () - in - let for_named (named : Flambda.named) = - match named with - | Project_var project_var - when Variable.Map.mem project_var.closure which_variables -> - projections := - Projection.Set.add (Project_var project_var) !projections - | Project_closure project_closure - when Variable.Map.mem project_closure.set_of_closures - which_variables -> - projections := - Projection.Set.add (Project_closure project_closure) !projections - | Move_within_set_of_closures move - when Variable.Map.mem move.closure which_variables -> - projections := - Projection.Set.add (Move_within_set_of_closures move) !projections - | Prim (Pfield field_index, [var], _dbg) - when Variable.Map.mem var which_variables -> - projections := - Projection.Set.add (Field (field_index, var)) !projections - | Set_of_closures set_of_closures -> - let aliasing_free_vars = - Variable.Map.filter (fun _ (spec_to : Flambda.specialised_to) -> - Variable.Map.mem spec_to.var which_variables) - set_of_closures.free_vars - in - let aliasing_specialised_args = - Variable.Map.filter (fun _ (spec_to : Flambda.specialised_to) -> - Variable.Map.mem spec_to.var which_variables) - set_of_closures.specialised_args - in - let aliasing_vars = - Variable.Map.disjoint_union - aliasing_free_vars aliasing_specialised_args - in - if not (Variable.Map.is_empty aliasing_vars) then begin - Variable.Map.iter (fun _ (fun_decl : Flambda.function_declaration) -> - (* We ignore projections from within nested sets of closures. *) - let _, used = - analyse_expr fun_decl.body ~which_variables:aliasing_vars - in - Variable.Set.iter (fun var -> - match Variable.Map.find var aliasing_vars with - | exception Not_found -> assert false - | spec_to -> check_free_variable spec_to.var) - used) - set_of_closures.function_decls.funs - end - | Prim (_, vars, _) -> - List.iter check_free_variable vars - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ | Project_var _ | Project_closure _ - | Move_within_set_of_closures _ - | Expr _ -> () - in - Flambda_iterators.iter_toplevel for_expr for_named expr; - let projections = !projections in - let used_which_variables = !used_which_variables in - projections, used_which_variables - -let from_function_decl ~env ~which_variables - ~(function_decl : Flambda.function_declaration) = - let projections, used_which_variables = - analyse_expr ~which_variables function_decl.body - in - (* We must use approximation information to determine which projections - are actually valid in the current environment, other we might lift - expressions too far. *) - let projections = - known_valid_projections ~env ~projections ~which_variables - in - (* Don't extract projections whose [projecting_from] variable is also - used boxed. We could in the future consider being more sophisticated - about this based on the uses in the body, but given we are not doing - that yet, it seems safest in performance terms not to (e.g.) unbox a - specialised argument whose boxed version is used. *) - Projection.Set.filter (fun projection -> - let projecting_from = Projection.projecting_from projection in - not (Variable.Set.mem projecting_from used_which_variables)) - projections diff --git a/middle_end/extract_projections.mli b/middle_end/extract_projections.mli deleted file mode 100644 index 47456bda..00000000 --- a/middle_end/extract_projections.mli +++ /dev/null @@ -1,33 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Identify projections from variables used in function bodies (free - variables or specialised args, for example, according to [which_variables] - below). Projections from variables that are also used boxed are not - returned. *) - -(** [which_variables] maps (existing) inner variables to (existing) outer - variables in the manner of [free_vars] and [specialised_args] in - [Flambda.set_of_closures]. - - The returned projections are [projecting_from] (cf. projection.mli) - the "existing inner vars". -*) -val from_function_decl - : env:Inline_and_simplify_aux.Env.t - -> which_variables:Flambda.specialised_to Variable.Map.t - -> function_decl:Flambda.function_declaration - -> Projection.Set.t diff --git a/middle_end/find_recursive_functions.ml b/middle_end/find_recursive_functions.ml deleted file mode 100644 index e6943303..00000000 --- a/middle_end/find_recursive_functions.ml +++ /dev/null @@ -1,34 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let in_function_declarations (function_decls : Flambda.function_declarations) - ~backend = - let module VCC = Strongly_connected_components.Make (Variable) in - let directed_graph = - let module B = (val backend : Backend_intf.S) in - Flambda_utils.fun_vars_referenced_in_decls function_decls - ~closure_symbol:B.closure_symbol - in - let connected_components = - VCC.connected_components_sorted_from_roots_to_leaf directed_graph - in - Array.fold_left (fun rec_fun -> function - | VCC.No_loop _ -> rec_fun - | VCC.Has_loop elts -> List.fold_right Variable.Set.add elts rec_fun) - Variable.Set.empty connected_components diff --git a/middle_end/find_recursive_functions.mli b/middle_end/find_recursive_functions.mli deleted file mode 100644 index 3c2dd5b1..00000000 --- a/middle_end/find_recursive_functions.mli +++ /dev/null @@ -1,37 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** "Recursive functions" are those functions [f] that might call either: - - themselves, or - - another function that in turn might call [f]. - - For example in the following simultaneous definition of [f] [g] and [h], - [f] and [g] are recursive functions, but not [h]: - [let rec f x = g x - and g x = f x - and h x = g x] -*) - -(** Determine the recursive functions, if any, bound by the given set of - function declarations. - This is only intended to be used by [Flambda.create_function_declarations]. -*) -val in_function_declarations - : Flambda.function_declarations - -> backend:(module Backend_intf.S) - -> Variable.Set.t diff --git a/middle_end/flambda.ml b/middle_end/flambda.ml deleted file mode 100644 index a16b51a1..00000000 --- a/middle_end/flambda.ml +++ /dev/null @@ -1,1272 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type call_kind = - | Indirect - | Direct of Closure_id.t - -type const = - | Int of int - | Char of char - | Const_pointer of int - -type apply = { - func : Variable.t; - args : Variable.t list; - kind : call_kind; - dbg : Debuginfo.t; - inline : Lambda.inline_attribute; - specialise : Lambda.specialise_attribute; -} - -type assign = { - being_assigned : Mutable_variable.t; - new_value : Variable.t; -} - -type send = { - kind : Lambda.meth_kind; - meth : Variable.t; - obj : Variable.t; - args : Variable.t list; - dbg : Debuginfo.t; -} - -type project_closure = Projection.project_closure -type move_within_set_of_closures = Projection.move_within_set_of_closures -type project_var = Projection.project_var - -type specialised_to = { - var : Variable.t; - projection : Projection.t option; -} - -type t = - | Var of Variable.t - | Let of let_expr - | Let_mutable of let_mutable - | Let_rec of (Variable.t * named) list * t - | Apply of apply - | Send of send - | Assign of assign - | If_then_else of Variable.t * t * t - | Switch of Variable.t * switch - | String_switch of Variable.t * (string * t) list * t option - | Static_raise of Static_exception.t * Variable.t list - | Static_catch of Static_exception.t * Variable.t list * t * t - | Try_with of t * Variable.t * t - | While of t * t - | For of for_loop - | Proved_unreachable - -and named = - | Symbol of Symbol.t - | Const of const - | Allocated_const of Allocated_const.t - | Read_mutable of Mutable_variable.t - | Read_symbol_field of Symbol.t * int - | Set_of_closures of set_of_closures - | Project_closure of project_closure - | Move_within_set_of_closures of move_within_set_of_closures - | Project_var of project_var - | Prim of Lambda.primitive * Variable.t list * Debuginfo.t - | Expr of t - -and let_expr = { - var : Variable.t; - defining_expr : named; - body : t; - free_vars_of_defining_expr : Variable.Set.t; - free_vars_of_body : Variable.Set.t; -} - -and let_mutable = { - var : Mutable_variable.t; - initial_value : Variable.t; - contents_kind : Lambda.value_kind; - body : t; -} - -and set_of_closures = { - function_decls : function_declarations; - free_vars : specialised_to Variable.Map.t; - specialised_args : specialised_to Variable.Map.t; - direct_call_surrogates : Variable.t Variable.Map.t; -} - -and function_declarations = { - is_classic_mode : bool; - set_of_closures_id : Set_of_closures_id.t; - set_of_closures_origin : Set_of_closures_origin.t; - funs : function_declaration Variable.Map.t; -} - -and function_declaration = { - closure_origin: Closure_origin.t; - params : Parameter.t list; - body : t; - free_variables : Variable.Set.t; - free_symbols : Symbol.Set.t; - stub : bool; - dbg : Debuginfo.t; - inline : Lambda.inline_attribute; - specialise : Lambda.specialise_attribute; - is_a_functor : bool; -} - -and switch = { - numconsts : Numbers.Int.Set.t; - consts : (int * t) list; - numblocks : Numbers.Int.Set.t; - blocks : (int * t) list; - failaction : t option; -} - -and for_loop = { - bound_var : Variable.t; - from_value : Variable.t; - to_value : Variable.t; - direction : Asttypes.direction_flag; - body : t -} - -and constant_defining_value = - | Allocated_const of Allocated_const.t - | Block of Tag.t * constant_defining_value_block_field list - | Set_of_closures of set_of_closures (* [free_vars] must be empty *) - | Project_closure of Symbol.t * Closure_id.t - -and constant_defining_value_block_field = - | Symbol of Symbol.t - | Const of const - -type expr = t - -type program_body = - | Let_symbol of Symbol.t * constant_defining_value * program_body - | Let_rec_symbol of (Symbol.t * constant_defining_value) list * program_body - | Initialize_symbol of Symbol.t * Tag.t * t list * program_body - | Effect of t * program_body - | End of Symbol.t - -type program = { - imported_symbols : Symbol.Set.t; - program_body : program_body; -} - -let fprintf = Format.fprintf -module Int = Numbers.Int - -let print_specialised_to ppf (spec_to : specialised_to) = - match spec_to.projection with - | None -> fprintf ppf "%a" Variable.print spec_to.var - | Some projection -> - fprintf ppf "%a(= %a)" - Variable.print spec_to.var - Projection.print projection - -(* CR-soon mshinwell: delete uses of old names *) -let print_project_var = Projection.print_project_var -let print_move_within_set_of_closures = - Projection.print_move_within_set_of_closures -let print_project_closure = Projection.print_project_closure - -(** CR-someday lwhite: use better name than this *) -let rec lam ppf (flam : t) = - match flam with - | Var (id) -> - Variable.print ppf id - | Apply({func; args; kind; inline; dbg}) -> - let direct ppf () = - match kind with - | Indirect -> () - | Direct closure_id -> fprintf ppf "*[%a]" Closure_id.print closure_id - in - let inline ppf () = - match inline with - | Always_inline -> fprintf ppf "" - | Never_inline -> fprintf ppf "" - | Unroll i -> fprintf ppf "" i - | Default_inline -> () - in - fprintf ppf "@[<2>(apply%a%a<%s>@ %a%a)@]" direct () inline () - (Debuginfo.to_string dbg) - Variable.print func Variable.print_list args - | Assign { being_assigned; new_value; } -> - fprintf ppf "@[<2>(assign@ %a@ %a)@]" - Mutable_variable.print being_assigned - Variable.print new_value - | Send { kind; meth; obj; args; dbg = _; } -> - let print_args ppf args = - List.iter (fun l -> fprintf ppf "@ %a" Variable.print l) args - in - let kind = - match kind with - | Self -> "self" - | Public -> "public" - | Cached -> "cached" - in - fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind - Variable.print obj Variable.print meth - print_args args - | Proved_unreachable -> - fprintf ppf "unreachable" - | Let { var = id; defining_expr = arg; body; _ } -> - let rec letbody (ul : t) = - match ul with - | Let { var = id; defining_expr = arg; body; _ } -> - fprintf ppf "@ @[<2>%a@ %a@]" Variable.print id print_named arg; - letbody body - | _ -> ul - in - fprintf ppf "@[<2>(let@ @[(@[<2>%a@ %a@]" - Variable.print id print_named arg; - let expr = letbody body in - fprintf ppf ")@]@ %a)@]" lam expr - | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> - let print_kind ppf (kind : Lambda.value_kind) = - match kind with - | Pgenval -> () - | _ -> Format.fprintf ppf " %a" Printlambda.value_kind kind - in - fprintf ppf "@[<2>(let_mutable%a@ @[<2>%a@ %a@]@ %a)@]" - print_kind contents_kind - Mutable_variable.print mut_var - Variable.print var - lam body - | Let_rec(id_arg_list, body) -> - let bindings ppf id_arg_list = - let spc = ref false in - List.iter - (fun (id, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<2>%a@ %a@]" Variable.print id print_named l) - id_arg_list in - fprintf ppf - "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body - | Switch(larg, sw) -> - let switch ppf (sw : switch) = - let spc = ref false in - List.iter - (fun (n, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case int %i:@ %a@]" n lam l) - sw.consts; - List.iter - (fun (n, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case tag %i:@ %a@]" n lam l) - sw.blocks ; - begin match sw.failaction with - | None -> () - | Some l -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam l - end in - fprintf ppf - "@[<1>(%s(%i,%i) %a@ @[%a@])@]" - (match sw.failaction with None -> "switch*" | _ -> "switch") - (Int.Set.cardinal sw.numconsts) - (Int.Set.cardinal sw.numblocks) - Variable.print larg switch sw - | String_switch(arg, cases, default) -> - let switch ppf cases = - let spc = ref false in - List.iter - (fun (s, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) - cases; - begin match default with - | Some default -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam default - | None -> () - end in - fprintf ppf - "@[<1>(stringswitch %a@ @[%a@])@]" Variable.print arg switch cases - | Static_raise (i, ls) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" Variable.print l) largs in - fprintf ppf "@[<2>(exit@ %a%a)@]" Static_exception.print i lams ls; - | Static_catch(i, vars, lbody, lhandler) -> - fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%a%a)@ %a)@]" - lam lbody Static_exception.print i - (fun ppf vars -> match vars with - | [] -> () - | _ -> - List.iter - (fun x -> fprintf ppf " %a" Variable.print x) - vars) - vars - lam lhandler - | Try_with(lbody, param, lhandler) -> - fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" - lam lbody Variable.print param lam lhandler - | If_then_else(lcond, lif, lelse) -> - fprintf ppf "@[<2>(if@ %a@ then begin@ %a@ end else begin@ %a@ end)@]" - Variable.print lcond - lam lif lam lelse - | While(lcond, lbody) -> - fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody - | For { bound_var; from_value; to_value; direction; body; } -> - fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" - Variable.print bound_var Variable.print from_value - (match direction with - Asttypes.Upto -> "to" | Asttypes.Downto -> "downto") - Variable.print to_value lam body -and print_named ppf (named : named) = - match named with - | Symbol (symbol) -> Symbol.print ppf symbol - | Const (cst) -> fprintf ppf "Const(%a)" print_const cst - | Allocated_const (cst) -> fprintf ppf "Aconst(%a)" Allocated_const.print cst - | Read_mutable mut_var -> - fprintf ppf "Read_mut(%a)" Mutable_variable.print mut_var - | Read_symbol_field (symbol, field) -> - fprintf ppf "%a.(%d)" Symbol.print symbol field - | Project_closure (project_closure) -> - print_project_closure ppf project_closure - | Project_var (project_var) -> print_project_var ppf project_var - | Move_within_set_of_closures (move_within_set_of_closures) -> - print_move_within_set_of_closures ppf move_within_set_of_closures - | Set_of_closures (set_of_closures) -> - print_set_of_closures ppf set_of_closures - | Prim(prim, args, dbg) -> - fprintf ppf "@[<2>(%a<%s>%a)@]" Printlambda.primitive prim - (Debuginfo.to_string dbg) - Variable.print_list args - | Expr expr -> - fprintf ppf "*%a" lam expr - (* lam ppf expr *) - -and print_function_declaration ppf var (f : function_declaration) = - let param ppf p = - Variable.print ppf (Parameter.var p) - in - let params ppf = - List.iter (fprintf ppf "@ %a" param) in - let stub = - if f.stub then - " *stub*" - else - "" - in - let is_a_functor = - if f.is_a_functor then - " *functor*" - else - "" - in - let inline = - match f.inline with - | Always_inline -> " *inline*" - | Never_inline -> " *never_inline*" - | Unroll _ -> " *unroll*" - | Default_inline -> "" - in - let specialise = - match f.specialise with - | Always_specialise -> " *specialise*" - | Never_specialise -> " *never_specialise*" - | Default_specialise -> "" - in - fprintf ppf "@[<2>(%a%s%s%s%s@ =@ fun@[<2>%a@] ->@ @[<2>%a@])@]@ " - Variable.print var stub is_a_functor inline specialise - params f.params lam f.body - -and print_set_of_closures ppf (set_of_closures : set_of_closures) = - match set_of_closures with - | { function_decls; free_vars; specialised_args} -> - let funs ppf = - Variable.Map.iter (print_function_declaration ppf) - in - let vars ppf = - Variable.Map.iter (fun id v -> - fprintf ppf "@ %a -rename-> %a" - Variable.print id print_specialised_to v) - in - let spec ppf spec_args = - if not (Variable.Map.is_empty spec_args) - then begin - fprintf ppf "@ "; - Variable.Map.iter (fun id (spec_to : specialised_to) -> - fprintf ppf "@ %a := %a" - Variable.print id print_specialised_to spec_to) - spec_args - end - in - fprintf ppf "@[<2>(set_of_closures id=%a@ %a@ @[<2>free_vars={%a@ }@]@ \ - @[<2>specialised_args={%a})@]@ \ - @[<2>direct_call_surrogates=%a@]@ \ - @[<2>set_of_closures_origin=%a@]@]]" - Set_of_closures_id.print function_decls.set_of_closures_id - funs function_decls.funs - vars free_vars - spec specialised_args - (Variable.Map.print Variable.print) - set_of_closures.direct_call_surrogates - Set_of_closures_origin.print function_decls.set_of_closures_origin - -and print_const ppf (c : const) = - match c with - | Int n -> fprintf ppf "%i" n - | Char c -> fprintf ppf "%C" c - | Const_pointer n -> fprintf ppf "%ia" n - -let print_function_declarations ppf (fd : function_declarations) = - let funs ppf = - Variable.Map.iter (print_function_declaration ppf) - in - fprintf ppf "@[<2>(%a)(origin = %a)@]" funs fd.funs - Set_of_closures_origin.print fd.set_of_closures_origin - -let print ppf flam = - fprintf ppf "%a@." lam flam - -let print_function_declaration ppf (var, decl) = - print_function_declaration ppf var decl - -let print_constant_defining_value ppf (const : constant_defining_value) = - match const with - | Allocated_const const -> - fprintf ppf "(Allocated_const %a)" Allocated_const.print const - | Block (tag, []) -> fprintf ppf "(Atom (tag %d))" (Tag.to_int tag) - | Block (tag, fields) -> - let print_field ppf (field : constant_defining_value_block_field) = - match field with - | Symbol symbol -> Symbol.print ppf symbol - | Const const -> print_const ppf const - in - let print_fields ppf = - List.iter (fprintf ppf "@ %a" print_field) - in - fprintf ppf "(Block (tag %d, %a))" (Tag.to_int tag) - print_fields fields - | Set_of_closures set_of_closures -> - fprintf ppf "@[<2>(Set_of_closures (@ %a))@]" print_set_of_closures - set_of_closures - | Project_closure (set_of_closures, closure_id) -> - fprintf ppf "(Project_closure (%a, %a))" Symbol.print set_of_closures - Closure_id.print closure_id - -let rec print_program_body ppf (program : program_body) = - let symbol_binding ppf (symbol, constant_defining_value) = - fprintf ppf "@[<2>(%a@ %a)@]" - Symbol.print symbol - print_constant_defining_value constant_defining_value - in - match program with - | Let_symbol (symbol, constant_defining_value, body) -> - let rec extract acc (ul : program_body) = - match ul with - | Let_symbol (symbol, constant_defining_value, body) -> - extract ((symbol, constant_defining_value) :: acc) body - | _ -> - List.rev acc, ul - in - let defs, program = extract [symbol, constant_defining_value] body in - fprintf ppf - "@[<2>let_symbol@ @[%a@]@]@." - (Format.pp_print_list symbol_binding) defs; - print_program_body ppf program - | Let_rec_symbol (defs, program) -> - fprintf ppf - "@[<2>let_rec_symbol@ @[%a@]@]@." - (Format.pp_print_list symbol_binding) defs; - print_program_body ppf program - | Initialize_symbol (symbol, tag, fields, program) -> - fprintf ppf "@[<2>initialize_symbol@ (@[<2>%a@ %a@ %a@])@]@." - Symbol.print symbol - Tag.print tag - (Format.pp_print_list lam) fields; - print_program_body ppf program - | Effect (expr, program) -> - fprintf ppf "@[<2>effect@ %a@]@." - lam expr; - print_program_body ppf program; - | End root -> fprintf ppf "End %a" Symbol.print root - -let print_program ppf program = - Symbol.Set.iter (fun symbol -> - fprintf ppf "@[import_symbol@ %a@]@." Symbol.print symbol) - program.imported_symbols; - print_program_body ppf program.program_body - -let rec variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument - ?ignore_uses_in_project_var ~all_used_variables tree = - match tree with - | Var var -> Variable.Set.singleton var - | _ -> - let free = ref Variable.Set.empty in - let bound = ref Variable.Set.empty in - let free_variables ids = free := Variable.Set.union ids !free in - let free_variable fv = free := Variable.Set.add fv !free in - let bound_variable id = bound := Variable.Set.add id !bound in - (* N.B. This function assumes that all bound identifiers are distinct. *) - let rec aux (flam : t) : unit = - match flam with - | Var var -> free_variable var - | Apply { func; args; kind = _; dbg = _} -> - begin match ignore_uses_as_callee with - | None -> free_variable func - | Some () -> () - end; - begin match ignore_uses_as_argument with - | None -> List.iter free_variable args - | Some () -> () - end - | Let { var; free_vars_of_defining_expr; free_vars_of_body; - defining_expr; body; _ } -> - bound_variable var; - if all_used_variables - || Misc.Stdlib.Option.is_some ignore_uses_as_callee - || Misc.Stdlib.Option.is_some ignore_uses_as_argument - || Misc.Stdlib.Option.is_some ignore_uses_in_project_var - then begin - (* In these cases we can't benefit from the pre-computed free - variable sets. *) - free_variables - (variables_usage_named ?ignore_uses_in_project_var - ?ignore_uses_as_callee ?ignore_uses_as_argument - ~all_used_variables defining_expr); - aux body - end else begin - free_variables free_vars_of_defining_expr; - free_variables free_vars_of_body - end - | Let_mutable { initial_value = var; body; _ } -> - free_variable var; - aux body - | Let_rec (bindings, body) -> - List.iter (fun (var, defining_expr) -> - bound_variable var; - free_variables - (variables_usage_named ?ignore_uses_in_project_var - ~all_used_variables defining_expr)) - bindings; - aux body - | Switch (scrutinee, switch) -> - free_variable scrutinee; - List.iter (fun (_, e) -> aux e) switch.consts; - List.iter (fun (_, e) -> aux e) switch.blocks; - Misc.may aux switch.failaction - | String_switch (scrutinee, cases, failaction) -> - free_variable scrutinee; - List.iter (fun (_, e) -> aux e) cases; - Misc.may aux failaction - | Static_raise (_, es) -> - List.iter free_variable es - | Static_catch (_, vars, e1, e2) -> - List.iter bound_variable vars; - aux e1; - aux e2 - | Try_with (e1, var, e2) -> - aux e1; - bound_variable var; - aux e2 - | If_then_else (var, e1, e2) -> - free_variable var; - aux e1; - aux e2 - | While (e1, e2) -> - aux e1; - aux e2 - | For { bound_var; from_value; to_value; direction = _; body; } -> - bound_variable bound_var; - free_variable from_value; - free_variable to_value; - aux body - | Assign { being_assigned = _; new_value; } -> - free_variable new_value - | Send { kind = _; meth; obj; args; dbg = _ } -> - free_variable meth; - free_variable obj; - List.iter free_variable args; - | Proved_unreachable -> () - in - aux tree; - if all_used_variables then - !free - else - Variable.Set.diff !free !bound - -and variables_usage_named ?ignore_uses_in_project_var - ?ignore_uses_as_callee ?ignore_uses_as_argument - ~all_used_variables named = - let free = ref Variable.Set.empty in - let free_variable fv = free := Variable.Set.add fv !free in - begin match named with - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ -> () - | Set_of_closures { free_vars; specialised_args; _ } -> - (* Sets of closures are, well, closed---except for the free variable and - specialised argument lists, which may identify variables currently in - scope outside of the closure. *) - Variable.Map.iter (fun _ (renamed_to : specialised_to) -> - (* We don't need to do anything with [renamed_to.projectee.var], if - it is present, since it would only be another free variable - in the same set of closures. *) - free_variable renamed_to.var) - free_vars; - Variable.Map.iter (fun _ (spec_to : specialised_to) -> - (* We don't need to do anything with [spec_to.projectee.var], if - it is present, since it would only be another specialised arg - in the same set of closures. *) - free_variable spec_to.var) - specialised_args - | Project_closure { set_of_closures; closure_id = _ } -> - free_variable set_of_closures - | Project_var { closure; closure_id = _; var = _ } -> - begin match ignore_uses_in_project_var with - | None -> free_variable closure - | Some () -> () - end - | Move_within_set_of_closures { closure; start_from = _; move_to = _ } -> - free_variable closure - | Prim (_, args, _) -> List.iter free_variable args - | Expr flam -> - free := Variable.Set.union - (variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument - ~all_used_variables flam) !free - end; - !free - -let free_variables ?ignore_uses_as_callee ?ignore_uses_as_argument - ?ignore_uses_in_project_var tree = - variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument - ?ignore_uses_in_project_var ~all_used_variables:false tree - -let free_variables_named ?ignore_uses_in_project_var named = - variables_usage_named ?ignore_uses_in_project_var - ~all_used_variables:false named - -let used_variables ?ignore_uses_as_callee ?ignore_uses_as_argument - ?ignore_uses_in_project_var tree = - variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument - ?ignore_uses_in_project_var ~all_used_variables:true tree - -let used_variables_named ?ignore_uses_in_project_var named = - variables_usage_named ?ignore_uses_in_project_var - ~all_used_variables:true named - -let create_let var defining_expr body : t = - begin match !Clflags.dump_flambda_let with - | None -> () - | Some stamp -> - Variable.debug_when_stamp_matches var ~stamp ~f:(fun () -> - Printf.eprintf "Creation of [Let] with stamp %d:\n%s\n%!" - stamp - (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int))) - end; - let defining_expr, free_vars_of_defining_expr = - match defining_expr with - | Expr (Let { var = var1; defining_expr; body = Var var2; - free_vars_of_defining_expr; _ }) when Variable.equal var1 var2 -> - defining_expr, free_vars_of_defining_expr - | _ -> defining_expr, free_variables_named defining_expr - in - Let { - var; - defining_expr; - body; - free_vars_of_defining_expr; - free_vars_of_body = free_variables body; - } - -let map_defining_expr_of_let let_expr ~f = - let defining_expr = f let_expr.defining_expr in - if defining_expr == let_expr.defining_expr then - Let let_expr - else - let free_vars_of_defining_expr = - free_variables_named defining_expr - in - Let { - var = let_expr.var; - defining_expr; - body = let_expr.body; - free_vars_of_defining_expr; - free_vars_of_body = let_expr.free_vars_of_body; - } - -let iter_lets t ~for_defining_expr ~for_last_body ~for_each_let = - let rec loop (t : t) = - match t with - | Let { var; defining_expr; body; _ } -> - for_each_let t; - for_defining_expr var defining_expr; - loop body - | t -> - for_last_body t - in - loop t - -let map_lets t ~for_defining_expr ~for_last_body ~after_rebuild = - let rec loop (t : t) ~rev_lets = - match t with - | Let { var; defining_expr; body; _ } -> - let new_defining_expr = - for_defining_expr var defining_expr - in - let original = - if new_defining_expr == defining_expr then - Some t - else - None - in - let rev_lets = (var, new_defining_expr, original) :: rev_lets in - loop body ~rev_lets - | t -> - let last_body = for_last_body t in - (* As soon as we see a change, we have to rebuild that [Let] and every - outer one. *) - let seen_change = ref (not (last_body == t)) in - List.fold_left (fun t (var, defining_expr, original) -> - let let_expr = - match original with - | Some original when not !seen_change -> original - | Some _ | None -> - seen_change := true; - create_let var defining_expr t - in - let new_let = after_rebuild let_expr in - if not (new_let == let_expr) then begin - seen_change := true - end; - new_let) - last_body - rev_lets - in - loop t ~rev_lets:[] - -(** CR-someday lwhite: Why not use two functions? *) -type maybe_named = - | Is_expr of t - | Is_named of named - -let iter_general ~toplevel f f_named maybe_named = - let rec aux (t : t) = - match t with - | Let _ -> - iter_lets t - ~for_defining_expr:(fun _var named -> aux_named named) - ~for_last_body:aux - ~for_each_let:f - | _ -> - f t; - match t with - | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable - | Static_raise _ -> () - | Let _ -> assert false - | Let_mutable { body; _ } -> - aux body - | Let_rec (defs, body) -> - List.iter (fun (_,l) -> aux_named l) defs; - aux body - | Try_with (f1,_,f2) - | While (f1,f2) - | Static_catch (_,_,f1,f2) -> - aux f1; aux f2 - | For { body; _ } -> aux body - | If_then_else (_, f1, f2) -> - aux f1; aux f2 - | Switch (_, sw) -> - List.iter (fun (_,l) -> aux l) sw.consts; - List.iter (fun (_,l) -> aux l) sw.blocks; - Misc.may aux sw.failaction - | String_switch (_, sw, def) -> - List.iter (fun (_,l) -> aux l) sw; - Misc.may aux def - and aux_named (named : named) = - f_named named; - match named with - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ - | Project_closure _ | Project_var _ | Move_within_set_of_closures _ - | Prim _ -> () - | Set_of_closures ({ function_decls = funcs; free_vars = _; - specialised_args = _}) -> - if not toplevel then begin - Variable.Map.iter (fun _ (decl : function_declaration) -> - aux decl.body) - funcs.funs - end - | Expr flam -> aux flam - in - match maybe_named with - | Is_expr expr -> aux expr - | Is_named named -> aux_named named - -module With_free_variables = struct - type 'a t = - | Expr : expr * Variable.Set.t -> expr t - | Named : named * Variable.Set.t -> named t - - let of_defining_expr_of_let let_expr = - Named (let_expr.defining_expr, let_expr.free_vars_of_defining_expr) - - let of_body_of_let let_expr = - Expr (let_expr.body, let_expr.free_vars_of_body) - - let of_expr expr = - Expr (expr, free_variables expr) - - let of_named named = - Named (named, free_variables_named named) - - let create_let_reusing_defining_expr var (t : named t) body = - match t with - | Named (defining_expr, free_vars_of_defining_expr) -> - Let { - var; - defining_expr; - body; - free_vars_of_defining_expr; - free_vars_of_body = free_variables body; - } - - let create_let_reusing_body var defining_expr (t : expr t) = - match t with - | Expr (body, free_vars_of_body) -> - Let { - var; - defining_expr; - body; - free_vars_of_defining_expr = free_variables_named defining_expr; - free_vars_of_body; - } - - let create_let_reusing_both var (t1 : named t) (t2 : expr t) = - match t1, t2 with - | Named (defining_expr, free_vars_of_defining_expr), - Expr (body, free_vars_of_body) -> - Let { - var; - defining_expr; - body; - free_vars_of_defining_expr; - free_vars_of_body; - } - - let expr (t : expr t) = - match t with - | Expr (expr, free_vars) -> Named (Expr expr, free_vars) - - let contents (type a) (t : a t) : a = - match t with - | Expr (expr, _) -> expr - | Named (named, _) -> named - - let free_variables (type a) (t : a t) = - match t with - | Expr (_, free_vars) -> free_vars - | Named (_, free_vars) -> free_vars -end - -let fold_lets_option - t ~init - ~(for_defining_expr:('a -> Variable.t -> named -> 'a * Variable.t * named)) - ~for_last_body - ~(filter_defining_expr:('b -> Variable.t -> named -> Variable.Set.t -> - 'b * Variable.t * named option)) = - let finish ~last_body ~acc ~rev_lets = - let module W = With_free_variables in - let acc, t = - List.fold_left (fun (acc, t) (var, defining_expr) -> - let free_vars_of_body = W.free_variables t in - let acc, var, defining_expr = - filter_defining_expr acc var defining_expr free_vars_of_body - in - match defining_expr with - | None -> acc, t - | Some defining_expr -> - let let_expr = - W.create_let_reusing_body var defining_expr t - in - acc, W.of_expr let_expr) - (acc, W.of_expr last_body) - rev_lets - in - W.contents t, acc - in - let rec loop (t : t) ~acc ~rev_lets = - match t with - | Let { var; defining_expr; body; _ } -> - let acc, var, defining_expr = - for_defining_expr acc var defining_expr - in - let rev_lets = (var, defining_expr) :: rev_lets in - loop body ~acc ~rev_lets - | t -> - let last_body, acc = for_last_body acc t in - finish ~last_body ~acc ~rev_lets - in - loop t ~acc:init ~rev_lets:[] - -let free_symbols_helper symbols (named : named) = - match named with - | Symbol symbol - | Read_symbol_field (symbol, _) -> symbols := Symbol.Set.add symbol !symbols - | Set_of_closures set_of_closures -> - Variable.Map.iter (fun _ (function_decl : function_declaration) -> - symbols := Symbol.Set.union function_decl.free_symbols !symbols) - set_of_closures.function_decls.funs - | _ -> () - -let free_symbols expr = - let symbols = ref Symbol.Set.empty in - iter_general ~toplevel:true - (fun (_ : t) -> ()) - (fun (named : named) -> free_symbols_helper symbols named) - (Is_expr expr); - !symbols - -let free_symbols_named named = - let symbols = ref Symbol.Set.empty in - iter_general ~toplevel:true - (fun (_ : t) -> ()) - (fun (named : named) -> free_symbols_helper symbols named) - (Is_named named); - !symbols - -let free_symbols_allocated_constant_helper symbols - (const : constant_defining_value) = - match const with - | Allocated_const _ -> () - | Block (_, fields) -> - List.iter - (function - | (Symbol s : constant_defining_value_block_field) -> - symbols := Symbol.Set.add s !symbols - | (Const _ : constant_defining_value_block_field) -> ()) - fields - | Set_of_closures set_of_closures -> - symbols := Symbol.Set.union !symbols - (free_symbols_named (Set_of_closures set_of_closures)) - | Project_closure (s, _) -> - symbols := Symbol.Set.add s !symbols - -let free_symbols_program (program : program) = - let symbols = ref Symbol.Set.empty in - let rec loop (program : program_body) = - match program with - | Let_symbol (_, const, program) -> - free_symbols_allocated_constant_helper symbols const; - loop program - | Let_rec_symbol (defs, program) -> - List.iter (fun (_, const) -> - free_symbols_allocated_constant_helper symbols const) - defs; - loop program - | Initialize_symbol (_, _, fields, program) -> - List.iter (fun field -> - symbols := Symbol.Set.union !symbols (free_symbols field)) - fields; - loop program - | Effect (expr, program) -> - symbols := Symbol.Set.union !symbols (free_symbols expr); - loop program - | End symbol -> symbols := Symbol.Set.add symbol !symbols - in - (* Note that there is no need to count the [imported_symbols]. *) - loop program.program_body; - !symbols - -let update_body_of_function_declaration (func_decl: function_declaration) - ~body : function_declaration = - { closure_origin = func_decl.closure_origin; - params = func_decl.params; - body; - free_variables = free_variables body; - free_symbols = free_symbols body; - stub = func_decl.stub; - dbg = func_decl.dbg; - inline = func_decl.inline; - specialise = func_decl.specialise; - is_a_functor = func_decl.is_a_functor; - } - -let update_function_decl's_params_and_body - (func_decl : function_declaration) ~params ~body = - { closure_origin = func_decl.closure_origin; - params; - body; - free_variables = free_variables body; - free_symbols = free_symbols body; - stub = func_decl.stub; - dbg = func_decl.dbg; - inline = func_decl.inline; - specialise = func_decl.specialise; - is_a_functor = func_decl.is_a_functor; - } - - -let create_function_declaration ~params ~body ~stub ~dbg - ~(inline : Lambda.inline_attribute) - ~(specialise : Lambda.specialise_attribute) ~is_a_functor - ~closure_origin - : function_declaration = - begin match stub, inline with - | true, (Never_inline | Default_inline) - | false, (Never_inline | Default_inline | Always_inline | Unroll _) -> () - | true, (Always_inline | Unroll _) -> - Misc.fatal_errorf - "Stubs may not be annotated as [Always_inline] or [Unroll]: %a" - print body - end; - begin match stub, specialise with - | true, (Never_specialise | Default_specialise) - | false, (Never_specialise | Default_specialise | Always_specialise) -> () - | true, Always_specialise -> - Misc.fatal_errorf - "Stubs may not be annotated as [Always_specialise]: %a" - print body - end; - { closure_origin; - params; - body; - free_variables = free_variables body; - free_symbols = free_symbols body; - stub; - dbg; - inline; - specialise; - is_a_functor; - } - -let update_function_declaration fun_decl ~params ~body = - let free_variables = free_variables body in - let free_symbols = free_symbols body in - { fun_decl with params; body; free_variables; free_symbols } - -let create_function_declarations ~is_classic_mode ~funs = - let compilation_unit = Compilation_unit.get_current_exn () in - let set_of_closures_id = Set_of_closures_id.create compilation_unit in - let set_of_closures_origin = - Set_of_closures_origin.create set_of_closures_id - in - { is_classic_mode; - set_of_closures_id; - set_of_closures_origin; - funs; - } - -let create_function_declarations_with_origin - ~is_classic_mode ~funs ~set_of_closures_origin = - let compilation_unit = Compilation_unit.get_current_exn () in - let set_of_closures_id = Set_of_closures_id.create compilation_unit in - { is_classic_mode; - set_of_closures_id; - set_of_closures_origin; - funs; - } - -let update_function_declarations function_decls ~funs = - let is_classic_mode = function_decls.is_classic_mode in - let compilation_unit = Compilation_unit.get_current_exn () in - let set_of_closures_id = Set_of_closures_id.create compilation_unit in - let set_of_closures_origin = function_decls.set_of_closures_origin in - { is_classic_mode; - set_of_closures_id; - set_of_closures_origin; - funs; - } - -let create_function_declarations_with_closures_origin - ~is_classic_mode ~funs ~set_of_closures_origin = - let compilation_unit = Compilation_unit.get_current_exn () in - let set_of_closures_id = Set_of_closures_id.create compilation_unit in - { is_classic_mode; - set_of_closures_id; - set_of_closures_origin; - funs - } - -let import_function_declarations_for_pack function_decls - import_set_of_closures_id import_set_of_closures_origin = - let is_classic_mode = function_decls.is_classic_mode in - let set_of_closures_id = - import_set_of_closures_id function_decls.set_of_closures_id - in - let set_of_closures_origin = - import_set_of_closures_origin function_decls.set_of_closures_origin - in - let funs = function_decls.funs in - { is_classic_mode; - set_of_closures_id; - set_of_closures_origin; - funs; - } - -let create_set_of_closures ~function_decls ~free_vars ~specialised_args - ~direct_call_surrogates = - if !Clflags.flambda_invariant_checks then begin - let all_fun_vars = Variable.Map.keys function_decls.funs in - let expected_free_vars = - Variable.Map.fold (fun _fun_var function_decl expected_free_vars -> - let free_vars = - Variable.Set.diff function_decl.free_variables - (Variable.Set.union (Parameter.Set.vars function_decl.params) - all_fun_vars) - in - Variable.Set.union free_vars expected_free_vars) - function_decls.funs - Variable.Set.empty - in - (* CR-soon pchambart: We do not seem to be able to maintain the - invariant that if a variable is not used inside the closure, it - is not used outside either. This would be a nice property for - better dead code elimination during inline_and_simplify, but it - is not obvious how to ensure that. - - This would be true when the function is known never to have - been inlined. - - Note that something like that may maybe enforcable in - inline_and_simplify, but there is no way to do that on other - passes. - - mshinwell: see CR in Flambda_invariants about this too - *) - let free_vars_domain = Variable.Map.keys free_vars in - if not (Variable.Set.subset expected_free_vars free_vars_domain) then begin - Misc.fatal_errorf "create_set_of_closures: [free_vars] mapping of \ - variables bound by the closure(s) is wrong. (Must map at least \ - %a but only maps %a.)@ \nfunction_decls:@ %a" - Variable.Set.print expected_free_vars - Variable.Set.print free_vars_domain - print_function_declarations function_decls - end; - let all_params = - Variable.Map.fold (fun _fun_var function_decl all_params -> - Variable.Set.union (Parameter.Set.vars function_decl.params) - all_params) - function_decls.funs - Variable.Set.empty - in - let spec_args_domain = Variable.Map.keys specialised_args in - if not (Variable.Set.subset spec_args_domain all_params) then begin - Misc.fatal_errorf "create_set_of_closures: [specialised_args] \ - maps variable(s) that are not parameters of the given function \ - declarations. specialised_args domain=%a all_params=%a \n\ - function_decls:@ %a" - Variable.Set.print spec_args_domain - Variable.Set.print all_params - print_function_declarations function_decls - end - end; - { function_decls; - free_vars; - specialised_args; - direct_call_surrogates; - } - -let used_params function_decl = - Variable.Set.filter - (fun param -> Variable.Set.mem param function_decl.free_variables) - (Parameter.Set.vars function_decl.params) - -let compare_const (c1:const) (c2:const) = - match c1, c2 with - | Int i1, Int i2 -> compare i1 i2 - | Char i1, Char i2 -> Char.compare i1 i2 - | Const_pointer i1, Const_pointer i2 -> compare i1 i2 - | Int _, (Char _ | Const_pointer _) -> -1 - | (Char _ | Const_pointer _), Int _ -> 1 - | Char _, Const_pointer _ -> -1 - | Const_pointer _, Char _ -> 1 - -let compare_constant_defining_value_block_field - (c1:constant_defining_value_block_field) - (c2:constant_defining_value_block_field) = - match c1, c2 with - | Symbol s1, Symbol s2 -> Symbol.compare s1 s2 - | Const c1, Const c2 -> compare_const c1 c2 - | Symbol _, Const _ -> -1 - | Const _, Symbol _ -> 1 - -module Constant_defining_value = struct - type t = constant_defining_value - - include Identifiable.Make (struct - type nonrec t = t - - let compare (t1 : t) (t2 : t) = - match t1, t2 with - | Allocated_const c1, Allocated_const c2 -> - Allocated_const.compare c1 c2 - | Block (tag1, fields1), Block (tag2, fields2) -> - let c = Tag.compare tag1 tag2 in - if c <> 0 then c - else - Misc.Stdlib.List.compare compare_constant_defining_value_block_field - fields1 fields2 - | Set_of_closures set1, Set_of_closures set2 -> - Set_of_closures_id.compare set1.function_decls.set_of_closures_id - set2.function_decls.set_of_closures_id - | Project_closure (set1, closure_id1), - Project_closure (set2, closure_id2) -> - let c = Symbol.compare set1 set2 in - if c <> 0 then c - else Closure_id.compare closure_id1 closure_id2 - | Allocated_const _, Block _ -> -1 - | Allocated_const _, Set_of_closures _ -> -1 - | Allocated_const _, Project_closure _ -> -1 - | Block _, Allocated_const _ -> 1 - | Block _, Set_of_closures _ -> -1 - | Block _, Project_closure _ -> -1 - | Set_of_closures _, Allocated_const _ -> 1 - | Set_of_closures _, Block _ -> 1 - | Set_of_closures _, Project_closure _ -> -1 - | Project_closure _, Allocated_const _ -> 1 - | Project_closure _, Block _ -> 1 - | Project_closure _, Set_of_closures _ -> 1 - - let equal t1 t2 = - t1 == t2 || compare t1 t2 = 0 - - let hash = Hashtbl.hash - - let print = print_constant_defining_value - - let output o v = - output_string o (Format.asprintf "%a" print v) - end) -end - -let equal_call_kind (call_kind1 : call_kind) (call_kind2 : call_kind) = - match call_kind1, call_kind2 with - | Indirect, Indirect -> true - | Direct cid1, Direct cid2 -> Closure_id.equal cid1 cid2 - | (Indirect | Direct _), _ -> false - -let equal_specialised_to (spec_to1 : specialised_to) - (spec_to2 : specialised_to) = - Variable.equal spec_to1.var spec_to2.var - && begin - match spec_to1.projection, spec_to2.projection with - | None, None -> true - | Some _, None | None, Some _ -> false - | Some proj1, Some proj2 -> Projection.equal proj1 proj2 - end - -let compare_project_var = Projection.compare_project_var -let compare_project_closure = Projection.compare_project_closure -let compare_move_within_set_of_closures = - Projection.compare_move_within_set_of_closures diff --git a/middle_end/flambda.mli b/middle_end/flambda.mli deleted file mode 100755 index a301dd47..00000000 --- a/middle_end/flambda.mli +++ /dev/null @@ -1,713 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Intermediate language used for tree-based analysis and optimization. *) - -(** Whether the callee in a function application is known at compile time. *) -type call_kind = - | Indirect - | Direct of Closure_id.t - -(** Simple constants. ("Structured constants" are rewritten to invocations - of [Pmakeblock] so that they easily take part in optimizations.) *) -type const = - | Int of int - | Char of char - (** [Char] is kept separate from [Int] to improve printing *) - | Const_pointer of int - (** [Const_pointer] is an immediate value of a type whose values may be - boxed (typically a variant type with both constant and non-constant - constructors). *) - -(** The application of a function to a list of arguments. *) -type apply = { - (* CR-soon mshinwell: rename func -> callee, and - lhs_of_application -> callee *) - func : Variable.t; - args : Variable.t list; - kind : call_kind; - dbg : Debuginfo.t; - inline : Lambda.inline_attribute; - (** Instructions from the source code as to whether the callee should - be inlined. *) - specialise : Lambda.specialise_attribute; - (** Instructions from the source code as to whether the callee should - be specialised. *) -} - -(** The update of a mutable variable. Mutable variables are distinct from - immutable variables in Flambda. *) -type assign = { - being_assigned : Mutable_variable.t; - new_value : Variable.t; -} - -(** The invocation of a method. *) -type send = { - kind : Lambda.meth_kind; - meth : Variable.t; - obj : Variable.t; - args : Variable.t list; - dbg : Debuginfo.t; -} - -(** For details on these types, see projection.mli. *) -type project_closure = Projection.project_closure -type move_within_set_of_closures = Projection.move_within_set_of_closures -type project_var = Projection.project_var - -(** See [free_vars] and [specialised_args], below. *) -(* CR-someday mshinwell: move to separate module and make [Identifiable]. - (Or maybe nearly Identifiable; having a special map that enforces invariants - might be good.) *) -type specialised_to = { - var : Variable.t; - (** The "outer variable". *) - projection : Projection.t option; - (** The [projecting_from] value (see projection.mli) of any [projection] - must be another free variable or specialised argument (depending on - whether this record type is involved in [free_vars] or - [specialised_args] respectively) in the same set of closures. - As such, this field describes a relation of projections between - either the [free_vars] or the [specialised_args]. *) -} - -(** Flambda terms are partitioned in a pseudo-ANF manner; many terms are - required to be [let]-bound. This in particular ensures there is always - a variable name for an expression that may be lifted out (for example - if it is found to be constant). - Note: All bound variables in Flambda terms must be distinct. - [Flambda_invariants] verifies this. *) -type t = - | Var of Variable.t - | Let of let_expr - | Let_mutable of let_mutable - | Let_rec of (Variable.t * named) list * t - (** CR-someday lwhite: give Let_rec the same fields as Let. *) - | Apply of apply - | Send of send - | Assign of assign - | If_then_else of Variable.t * t * t - | Switch of Variable.t * switch - | String_switch of Variable.t * (string * t) list * t option - (** Restrictions on [Lambda.Lstringswitch] also apply to [String_switch]. *) - | Static_raise of Static_exception.t * Variable.t list - | Static_catch of Static_exception.t * Variable.t list * t * t - | Try_with of t * Variable.t * t - | While of t * t - | For of for_loop - | Proved_unreachable - -(** Values of type [named] will always be [let]-bound to a [Variable.t]. *) -and named = - | Symbol of Symbol.t - | Const of const - | Allocated_const of Allocated_const.t - | Read_mutable of Mutable_variable.t - | Read_symbol_field of Symbol.t * int - (** During the lifting of [let] bindings to [program] constructions after - closure conversion, we generate symbols and their corresponding - definitions (which may or may not be constant), together with field - accesses to such symbols. We would like it to be the case that such - field accesses are simplified to the relevant component of the - symbol concerned. (The rationale is to generate efficient code and - share constants as expected: see e.g. tests/asmcomp/staticalloc.ml.) - The components of the symbol would be identified by other symbols. - This sort of access pattern is feasible because the top-level structure - of symbols is statically allocated and fixed at compile time. - It may seem that [Prim (Pfield, ...)] expressions could be used to - perform the field accesses. However for simplicity, to avoid having to - keep track of properties of individual fields of blocks, - [Inconstant_idents] never deems a [Prim (Pfield, ...)] expression to be - constant. This would in general prevent field accesses to symbols from - being simplified in the way we would like, since [Lift_constants] would - not assign new symbols (i.e. the things we would like to simplify to) - to the various projections from the symbols in question. - To circumvent this problem we use [Read_symbol_field] when generating - projections from the top level of symbols. Owing to the properties of - symbols described above, such expressions may be eligible for declaration - as constant by [Inconstant_idents] (and thus themselves lifted to another - symbol), without any further complication. - [Read_symbol_field] may only be used when the definition of the symbol - is in scope in the [program]. For external unresolved symbols, [Pfield] - may still be used; it will be changed to [Read_symbol_field] by - [Inline_and_simplify] when (and if) the symbol is imported. *) - | Set_of_closures of set_of_closures - | Project_closure of project_closure - | Move_within_set_of_closures of move_within_set_of_closures - | Project_var of project_var - | Prim of Lambda.primitive * Variable.t list * Debuginfo.t - | Expr of t (** ANF escape hatch. *) - -(* CR-someday mshinwell: use [letcont]-style construct to remove e.g. - [While] and [For]. *) -(* CR-someday mshinwell: try to produce a tighter definition of a "switch" - (and translate to that earlier) so that middle- and back-end code for - these can be reduced. *) -(* CR-someday mshinwell: remove [Expr], but to do this easily would probably - require a continuation-binding construct. *) -(* CR-someday mshinwell: Since we lack expression identifiers on every term, - we should probably introduce [Mutable_var] into [named] if we introduce - more complicated analyses on these in the future. Alternatively, maybe - consider removing mutable variables altogether. *) - -and let_expr = private { - var : Variable.t; - defining_expr : named; - body : t; - (* CR-someday mshinwell: we could consider having these be keys into some - kind of global cache, to reduce memory usage. *) - free_vars_of_defining_expr : Variable.Set.t; - (** A cache of the free variables in the defining expression of the [let]. *) - free_vars_of_body : Variable.Set.t; - (** A cache of the free variables of the body of the [let]. This is an - important optimization. *) -} - -and let_mutable = { - var : Mutable_variable.t; - initial_value : Variable.t; - contents_kind : Lambda.value_kind; - body : t; -} - -(** The representation of a set of function declarations (possibly mutually - recursive). Such a set encapsulates the declarations themselves, - information about their defining environment, and information used - specifically for optimization. - Before a function can be applied it must be "projected" from a set of - closures to yield a "closure". This is done using [Project_closure] - (see above). Given a closure, not only can it be applied, but information - about its defining environment can be retrieved (using [Project_var], - see above). - At runtime, a [set_of_closures] corresponds to an OCaml value with tag - [Closure_tag] (possibly with inline [Infix_tag](s)). As an optimization, - an operation ([Move_within_set_of_closures]) is provided (see above) - which enables one closure within a set to be located given another - closure in the same set. This avoids keeping a pointer to the whole set - of closures alive when compiling, for example, mutually-recursive - functions. -*) -and set_of_closures = private { - function_decls : function_declarations; - (* CR-soon mshinwell: consider renaming [free_vars]. Also, it's still really - confusing which side of this map to use when. "Vars bound by the - closure" is the domain. - Another example of when this is confusing: - let bound_vars_approx = - Variable.Map.map (Env.find_approx env) set.free_vars - in - in [Build_export_info]. *) - (* CR-soon mshinwell: I'd like to arrange these maps so that it's impossible - to put invalid projection information into them (in particular, so that - we enforce that the relation stays within the domain of the map). *) - free_vars : specialised_to Variable.Map.t; - (** Mapping from all variables free in the body of the [function_decls] to - variables in scope at the definition point of the [set_of_closures]. - The domain of this map is sometimes known as the "variables bound by - the closure". *) - specialised_args : specialised_to Variable.Map.t; - (** Parameters whose corresponding arguments are known to always alias a - particular value. These are the only parameters that may, during - [Inline_and_simplify], have non-unknown approximations. - - An argument may only be specialised to a variable in the scope of the - corresponding set of closures declaration. Usually, that variable - itself also appears in the position of the specialised argument at - all call sites of the function. However it may also be the case (for - example in code generated as a result of [Augment_specialised_args]) - that the various call sites of such a function have differing - variables in the position of the specialised argument. This is - permissible *so long as it is certain they all alias the same value*. - Great care must be taken in transformations that result in this - situation since there are no invariant checks for correctness. - - As an example, supposing all call sites of f are represented here: - [let x = ... in - let f a b c = ... in - let y = ... in - f x y 1; - f x y 1] - the specialised arguments of f can (but does not necessarily) contain - the association [a] -> [x], but cannot contain [b] -> [y] because [f] - is not in the scope of [y]. If f were the recursive function - [let rec f a b c = f a 1 2 in], [a] -> [x] would still be a valid - specialised argument because all recursive calls maintain the invariant. - - This information is used for optimization purposes, if such a binding is - known, it is possible to specialise the body of the function according - to its parameter. This is usually introduced when specialising a - recursive function, for instance. - [let rec map f = function - | [] -> [] - | h :: t -> f h :: map f t - let map_succ l = - let succ x = x + 1 in - map succ l] - [map] can be duplicated in [map_succ] to be specialised for the argument - [f]. This will result in - [let map_succ l = - let succ x = x + 1 in - let rec map f = function - | [] -> [] - | h :: t -> f h :: map f t in - map succ l] - with map having [f] -> [succ] in its [specialised_args] field. - - Specialised argument information for arguments that are used must - never be erased. This ensures that specialised arguments whose - approximations describe closures maintain those approximations, which - is essential to transport the closure freshening information to the - point of use (e.g. a [Project_var] from such an argument). - *) - direct_call_surrogates : Variable.t Variable.Map.t; - (** If [direct_call_surrogates] maps [fun_var1] to [fun_var2] then direct - calls to [fun_var1] should be redirected to [fun_var2]. This is used - to reduce the overhead of transformations that introduce wrapper - functions (which will be inlined at direct call sites, but will - penalise indirect call sites). - [direct_call_surrogates] may not be transitively closed. *) -} - -and function_declarations = private { - is_classic_mode: bool; - (** Indicates whether this [function_declarations] was compiled - with -Oclassic. *) - set_of_closures_id : Set_of_closures_id.t; - (** An identifier (unique across all Flambda trees currently in memory) - of the set of closures associated with this set of function - declarations. *) - set_of_closures_origin : Set_of_closures_origin.t; - (** An identifier of the original set of closures on which this set of - function declarations is based. Used to prevent different - specialisations of the same functions from being inlined/specialised - within each other. *) - funs : function_declaration Variable.Map.t; - (** The function(s) defined by the set of function declarations. The - keys of this map are often referred to in the code as "fun_var"s. *) -} - -and function_declaration = private { - closure_origin: Closure_origin.t; - params : Parameter.t list; - body : t; - (* CR-soon mshinwell: inconsistent naming free_variables/free_vars here and - above *) - free_variables : Variable.Set.t; - (** All variables free in the *body* of the function. For example, a - variable that is bound as one of the function's parameters will still - be included in this set. This field is present as an optimization. *) - free_symbols : Symbol.Set.t; - (** All symbols that occur in the function's body. (Symbols can never be - bound in a function's body; the only thing that binds symbols is the - [program] constructions below.) *) - stub : bool; - (** A stub function is a generated function used to prepare arguments or - return values to allow indirect calls to functions with a special calling - convention. For instance indirect calls to tuplified functions must go - through a stub. Stubs will be unconditionally inlined. *) - dbg : Debuginfo.t; - (** Debug info for the function declaration. *) - inline : Lambda.inline_attribute; - (** Inlining requirements from the source code. *) - specialise : Lambda.specialise_attribute; - (** Specialising requirements from the source code. *) - is_a_functor : bool; - (** Whether the function is known definitively to be a functor. *) -} - -(** Equivalent to the similar type in [Lambda]. *) -and switch = { - numconsts : Numbers.Int.Set.t; (** Integer cases *) - consts : (int * t) list; (** Integer cases *) - numblocks : Numbers.Int.Set.t; (** Number of tag block cases *) - blocks : (int * t) list; (** Tag block cases *) - failaction : t option; (** Action to take if none matched *) -} - -(** Equivalent to the similar type in [Lambda]. *) -and for_loop = { - bound_var : Variable.t; - from_value : Variable.t; - to_value : Variable.t; - direction : Asttypes.direction_flag; - body : t -} - -(** Like a subset of [Flambda.named], except that instead of [Variable.t]s we - have [Symbol.t]s, and everything is a constant (i.e. with a fixed value - known at compile time). Values of this type describe constants that will - be directly assigned to symbols in the object file (see below). *) -and constant_defining_value = - | Allocated_const of Allocated_const.t - (** A single constant. These are never "simple constants" (type [const]) - but instead more complicated constructions. *) - | Block of Tag.t * constant_defining_value_block_field list - (** A pre-allocated block full of constants (either simple constants - or references to other constants, see below). *) - | Set_of_closures of set_of_closures - (** A closed (and thus constant) set of closures. (That is to say, - [free_vars] must be empty.) *) - | Project_closure of Symbol.t * Closure_id.t - (** Selection of one closure from a constant set of closures. - Analogous to the equivalent operation on expressions. *) - -and constant_defining_value_block_field = - | Symbol of Symbol.t - | Const of const - -module Constant_defining_value : - Identifiable.S with type t = constant_defining_value - -type expr = t - -(** A "program" is the contents of one compilation unit. It describes the - various values that are assigned to symbols (and in some cases fields of - such symbols) in the object file. As such, it is closely related to - the compilation of toplevel modules. *) -type program_body = - | Let_symbol of Symbol.t * constant_defining_value * program_body - (** Define the given symbol to have the given constant value. *) - | Let_rec_symbol of (Symbol.t * constant_defining_value) list * program_body - (** As for [Let_symbol], but recursive. This is needed to treat examples - like this, where a constant set of closures is lifted to toplevel: - - let rec f x = f x - - After lifting this produces (in pseudo-Flambda): - - Let_rec_symbol set_of_closures_symbol = - (Set_of_closures { f x -> - let applied_function = Symbol f_closure in - Apply (applied_function, x) }) - and f_closure = Project_closure (set_of_closures_symbol, f) - - Use of [Let_rec_symbol], by virtue of the special handling in - [Inline_and_simplify.define_let_rec_symbol_approx], enables the - approximation of the set of closures to be present in order to - correctly simplify the [Project_closure] construction. (See - [Inline_and_simplify.simplify_project_closure] for that part.) *) - | Initialize_symbol of Symbol.t * Tag.t * t list * program_body - (** Define the given symbol as a constant block of the given size and - tag; but with a possibly non-constant initializer. The initializer - will be executed at most once (from the entry point of the compilation - unit). *) - | Effect of t * program_body - (** Cause the given expression, which may have a side effect, to be - executed. The resulting value is discarded. [Effect] constructions - are never re-ordered. *) - | End of Symbol.t - (** [End] accepts the root symbol: the only symbol that can never be - eliminated. *) - -type program = { - imported_symbols : Symbol.Set.t; - program_body : program_body; -} - -(** Compute the free variables of a term. (This is O(1) for [Let]s). - If [ignore_uses_as_callee], all free variables inside [Apply] expressions - are ignored. Likewise [ignore_uses_in_project_var] for [Project_var] - expressions. -*) -val free_variables - : ?ignore_uses_as_callee:unit - -> ?ignore_uses_as_argument:unit - -> ?ignore_uses_in_project_var:unit - -> t - -> Variable.Set.t - -(** Compute the free variables of a named expression. *) -val free_variables_named - : ?ignore_uses_in_project_var:unit - -> named - -> Variable.Set.t - -(** Compute _all_ variables occurring inside an expression. *) -val used_variables - : ?ignore_uses_as_callee:unit - -> ?ignore_uses_as_argument:unit - -> ?ignore_uses_in_project_var:unit - -> t - -> Variable.Set.t - -(** Compute _all_ variables occurring inside a named expression. *) -val used_variables_named - : ?ignore_uses_in_project_var:unit - -> named - -> Variable.Set.t - -val free_symbols : expr -> Symbol.Set.t - -val free_symbols_named : named -> Symbol.Set.t - -val free_symbols_program : program -> Symbol.Set.t - -(** Used to avoid exceeding the stack limit when handling expressions with - multiple consecutive nested [Let]-expressions. This saves rewriting large - simplification functions in CPS. This function provides for the - rewriting or elimination of expressions during the fold. *) -val fold_lets_option - : t - -> init:'a - -> for_defining_expr:('a -> Variable.t -> named -> 'a * Variable.t * named) - -> for_last_body:('a -> t -> t * 'b) - (* CR-someday mshinwell: consider making [filter_defining_expr] - optional *) - -> filter_defining_expr:('b -> Variable.t -> named -> Variable.Set.t -> - 'b * Variable.t * named option) - -> t * 'b - -(** Like [fold_lets_option], but just a map. *) -val map_lets - : t - -> for_defining_expr:(Variable.t -> named -> named) - -> for_last_body:(t -> t) - -> after_rebuild:(t -> t) - -> t - -(** Like [map_lets], but just an iterator. *) -val iter_lets - : t - -> for_defining_expr:(Variable.t -> named -> unit) - -> for_last_body:(t -> unit) - -> for_each_let:(t -> unit) - -> unit - -(** Creates a [Let] expression. (This computes the free variables of the - defining expression and the body.) *) -val create_let : Variable.t -> named -> t -> t - -(** Apply the specified function [f] to the defining expression of the given - [Let]-expression, returning a new [Let]. *) -val map_defining_expr_of_let : let_expr -> f:(named -> named) -> t - -(** A module for the manipulation of terms where the recomputation of free - variable sets is to be kept to a minimum. *) -module With_free_variables : sig - type 'a t - - (** O(1) time. *) - val of_defining_expr_of_let : let_expr -> named t - - (** O(1) time. *) - val of_body_of_let : let_expr -> expr t - - (** Takes the time required to calculate the free variables of the given - term (proportional to the size of the term, except that the calculation - for [Let] is O(1)). *) - val of_expr : expr -> expr t - - val of_named : named -> named t - - (** Takes the time required to calculate the free variables of the given - [expr]. *) - val create_let_reusing_defining_expr - : Variable.t - -> named t - -> expr - -> expr - - (** Takes the time required to calculate the free variables of the given - [named]. *) - val create_let_reusing_body - : Variable.t - -> named - -> expr t - -> expr - - (** O(1) time. *) - val create_let_reusing_both - : Variable.t - -> named t - -> expr t - -> expr - - (** The equivalent of the [Expr] constructor. *) - val expr : expr t -> named t - - val contents : 'a t -> 'a - - (** O(1) time. *) - val free_variables : _ t -> Variable.Set.t -end - -(** Create a function declaration. This calculates the free variables and - symbols occurring in the specified [body]. *) -val create_function_declaration - : params:Parameter.t list - -> body:t - -> stub:bool - -> dbg:Debuginfo.t - -> inline:Lambda.inline_attribute - -> specialise:Lambda.specialise_attribute - -> is_a_functor:bool - -> closure_origin:Closure_origin.t - -> function_declaration - -(** Create a function declaration based on another function declaration *) -val update_function_declaration - : function_declaration - -> params:Parameter.t list - -> body:t - -> function_declaration - -(** Create a set of function declarations given the individual declarations. *) -val create_function_declarations - : is_classic_mode:bool - -> funs:function_declaration Variable.Map.t - -> function_declarations - -(** Create a set of function declarations with a given set of closures - origin. *) -val create_function_declarations_with_origin - : is_classic_mode:bool - -> funs:function_declaration Variable.Map.t - -> set_of_closures_origin:Set_of_closures_origin.t - -> function_declarations - -(** Change only the code of a function declaration. *) -val update_body_of_function_declaration - : function_declaration - -> body:expr - -> function_declaration - -(** Change only the code and parameters of a function declaration. *) -(* CR-soon mshinwell: rename this to match new update function above *) -val update_function_decl's_params_and_body - : function_declaration - -> params:Parameter.t list - -> body:expr - -> function_declaration - -(** Create a set of function declarations based on another set of function - declarations. *) -val update_function_declarations - : function_declarations - -> funs:function_declaration Variable.Map.t - -> function_declarations - -val create_function_declarations_with_closures_origin - : is_classic_mode: bool - -> funs:function_declaration Variable.Map.t - -> set_of_closures_origin:Set_of_closures_origin.t - -> function_declarations - -val import_function_declarations_for_pack - : function_declarations - -> (Set_of_closures_id.t -> Set_of_closures_id.t) - -> (Set_of_closures_origin.t -> Set_of_closures_origin.t) - -> function_declarations - -(** Create a set of closures. Checks are made to ensure that [free_vars] - and [specialised_args] are reasonable. *) -val create_set_of_closures - : function_decls:function_declarations - -> free_vars:specialised_to Variable.Map.t - -> specialised_args:specialised_to Variable.Map.t - -> direct_call_surrogates:Variable.t Variable.Map.t - -> set_of_closures - -(** Given a function declaration, find which of its parameters (if any) - are used in the body. *) -val used_params : function_declaration -> Variable.Set.t - -type maybe_named = - | Is_expr of t - | Is_named of named - -(** This function is designed for the internal use of [Flambda_iterators]. - See that module for iterators to be used over Flambda terms. *) -val iter_general - : toplevel:bool - -> (t -> unit) - -> (named -> unit) - -> maybe_named - -> unit - -val print : Format.formatter -> t -> unit - -val print_named : Format.formatter -> named -> unit - -val print_program : Format.formatter -> program -> unit - -val print_const : Format.formatter -> const -> unit - -val print_constant_defining_value - : Format.formatter - -> constant_defining_value - -> unit - -val print_function_declaration - : Format.formatter - -> Variable.t * function_declaration - -> unit - -val print_function_declarations - : Format.formatter - -> function_declarations - -> unit - -val print_project_closure - : Format.formatter - -> project_closure - -> unit - -val print_move_within_set_of_closures - : Format.formatter - -> move_within_set_of_closures - -> unit - -val print_project_var - : Format.formatter - -> project_var - -> unit - -val print_set_of_closures - : Format.formatter - -> set_of_closures - -> unit - -val print_specialised_to - : Format.formatter - -> specialised_to - -> unit - -val equal_call_kind - : call_kind - -> call_kind - -> bool - -val equal_specialised_to - : specialised_to - -> specialised_to - -> bool - -val compare_const - : const - -> const - -> int - -val compare_project_var : project_var -> project_var -> int - -val compare_move_within_set_of_closures - : move_within_set_of_closures - -> move_within_set_of_closures - -> int - -val compare_project_closure : project_closure -> project_closure -> int diff --git a/middle_end/flambda/alias_analysis.ml b/middle_end/flambda/alias_analysis.ml new file mode 100644 index 00000000..fe97a36f --- /dev/null +++ b/middle_end/flambda/alias_analysis.ml @@ -0,0 +1,168 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type allocation_point = + | Symbol of Symbol.t + | Variable of Variable.t + +type allocated_const = + | Normal of Allocated_const.t + | Array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t list + | Duplicate_array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t + +type constant_defining_value = + | Allocated_const of allocated_const + | Block of Tag.t * Variable.t list + | Set_of_closures of Flambda.set_of_closures + | Project_closure of Flambda.project_closure + | Move_within_set_of_closures of Flambda.move_within_set_of_closures + | Project_var of Flambda.project_var + | Field of Variable.t * int + | Symbol_field of Symbol.t * int + | Const of Flambda.const + | Symbol of Symbol.t + | Variable of Variable.t + +type initialize_symbol_field = Variable.t option + +type definitions = { + variable : constant_defining_value Variable.Tbl.t; + initialize_symbol : initialize_symbol_field list Symbol.Tbl.t; + symbol : Flambda.constant_defining_value Symbol.Tbl.t; +} + +let print_constant_defining_value ppf = function + | Allocated_const (Normal const) -> Allocated_const.print ppf const + | Allocated_const (Array (_, _, vars)) -> + Format.fprintf ppf "[| %a |]" + (Format.pp_print_list Variable.print) vars + | Allocated_const (Duplicate_array (_, _, var)) -> + Format.fprintf ppf "dup_array(%a)" Variable.print var + | Block (tag, vars) -> + Format.fprintf ppf "[|%a: %a|]" + Tag.print tag + (Format.pp_print_list Variable.print) vars + | Set_of_closures set -> Flambda.print_set_of_closures ppf set + | Project_closure project -> Flambda.print_project_closure ppf project + | Move_within_set_of_closures move -> + Flambda.print_move_within_set_of_closures ppf move + | Project_var project -> Flambda.print_project_var ppf project + | Field (var, field) -> Format.fprintf ppf "%a.(%d)" Variable.print var field + | Symbol_field (sym, field) -> + Format.fprintf ppf "%a.(%d)" Symbol.print sym field + | Const const -> Flambda.print_const ppf const + | Symbol symbol -> Symbol.print ppf symbol + | Variable var -> Variable.print ppf var + +let rec resolve_definition + (definitions: definitions) + (var: Variable.t) + (def: constant_defining_value) + ~the_dead_constant : allocation_point = + match def with + | Allocated_const _ + | Block _ + | Set_of_closures _ + | Project_closure _ + | Const _ + | Move_within_set_of_closures _ -> + Variable var + | Project_var {var} -> + fetch_variable definitions (Var_within_closure.unwrap var) + ~the_dead_constant + | Variable v -> + fetch_variable definitions v + ~the_dead_constant + | Symbol sym -> Symbol sym + | Field (v, n) -> + begin match fetch_variable definitions v ~the_dead_constant with + | Symbol s -> + fetch_symbol_field definitions s n ~the_dead_constant + | Variable v -> + fetch_variable_field definitions v n ~the_dead_constant + end + | Symbol_field (symbol, field) -> + fetch_symbol_field definitions symbol field ~the_dead_constant + +and fetch_variable + (definitions: definitions) + (var: Variable.t) + ~the_dead_constant : allocation_point = + match Variable.Tbl.find definitions.variable var with + | exception Not_found -> Variable var + | def -> resolve_definition definitions var def ~the_dead_constant + +and fetch_variable_field + (definitions: definitions) + (var: Variable.t) + (field: int) + ~the_dead_constant : allocation_point = + match Variable.Tbl.find definitions.variable var with + | Block (_, fields) -> + begin match List.nth fields field with + | exception Not_found -> Symbol the_dead_constant + | v -> fetch_variable definitions v ~the_dead_constant + end + | exception Not_found -> + Misc.fatal_errorf "No definition for field access to %a" Variable.print var + | Symbol _ | Variable _ | Project_var _ | Field _ | Symbol_field _ -> + (* Must have been resolved *) + assert false + | Const _ | Allocated_const _ + | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ -> + Symbol the_dead_constant + +and fetch_symbol_field + (definitions: definitions) + (sym: Symbol.t) + (field: int) + ~the_dead_constant : allocation_point = + match Symbol.Tbl.find definitions.symbol sym with + | Block (_, fields) -> + begin match List.nth fields field with + | exception Not_found -> Symbol the_dead_constant + | Symbol s -> Symbol s + | Const _ -> Symbol sym + end + | exception Not_found -> + begin match Symbol.Tbl.find definitions.initialize_symbol sym with + | fields -> + begin match List.nth fields field with + | None -> + Misc.fatal_errorf "Constant field access to an inconstant %a" + Symbol.print sym + | Some v -> + fetch_variable definitions v ~the_dead_constant + end + | exception Not_found -> + Misc.fatal_errorf "No definition for field access to %a" + Symbol.print sym + end + | Allocated_const _ | Set_of_closures _ | Project_closure _ -> + Symbol the_dead_constant + +let run variable initialize_symbol symbol ~the_dead_constant = + let definitions = { variable; initialize_symbol; symbol; } in + Variable.Tbl.fold (fun var definition result -> + let definition = + resolve_definition definitions var definition ~the_dead_constant + in + Variable.Map.add var definition result) + definitions.variable + Variable.Map.empty diff --git a/middle_end/flambda/alias_analysis.mli b/middle_end/flambda/alias_analysis.mli new file mode 100644 index 00000000..515daeff --- /dev/null +++ b/middle_end/flambda/alias_analysis.mli @@ -0,0 +1,63 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +type allocation_point = + | Symbol of Symbol.t + | Variable of Variable.t + +type allocated_const = + | Normal of Allocated_const.t + | Array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t list + | Duplicate_array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t + +type constant_defining_value = + | Allocated_const of allocated_const + | Block of Tag.t * Variable.t list + | Set_of_closures of Flambda.set_of_closures + | Project_closure of Flambda.project_closure + | Move_within_set_of_closures of Flambda.move_within_set_of_closures + | Project_var of Flambda.project_var + | Field of Variable.t * int + | Symbol_field of Symbol.t * int + | Const of Flambda.const + | Symbol of Symbol.t + | Variable of Variable.t + +type initialize_symbol_field = Variable.t option + +(** Simple alias analysis working over information about which + symbols have been assigned to variables; and which constants have + been assigned to symbols. The return value gives the assignment + of the defining values of constants to variables. + Also see comments for [Lift_constants], whose input feeds this + pass. + + Variables found to be ill-typed accesses to other constants, for + example arising from dead code, will be pointed at [the_dead_constant]. +*) +val run + : constant_defining_value Variable.Tbl.t + -> initialize_symbol_field list Symbol.Tbl.t + -> Flambda.constant_defining_value Symbol.Tbl.t + -> the_dead_constant:Symbol.t + -> allocation_point Variable.Map.t + +val print_constant_defining_value + : Format.formatter + -> constant_defining_value + -> unit diff --git a/middle_end/flambda/allocated_const.ml b/middle_end/flambda/allocated_const.ml new file mode 100644 index 00000000..78dc4ee1 --- /dev/null +++ b/middle_end/flambda/allocated_const.ml @@ -0,0 +1,86 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type t = + | Float of float + | Int32 of int32 + | Int64 of int64 + | Nativeint of nativeint + | Float_array of float list + | Immutable_float_array of float list + | String of string + | Immutable_string of string + +let compare_floats x1 x2 = + (* It is important to compare the bit patterns here, so as not to + be subject to bugs such as GPR#295. *) + Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2) + +let compare (x : t) (y : t) = + let rec compare_float_lists l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | h1::t1, h2::t2 -> + let c = compare_floats h1 h2 in + if c <> 0 then c else compare_float_lists t1 t2 + in + match x, y with + | Float x, Float y -> compare_floats x y + | Int32 x, Int32 y -> Int32.compare x y + | Int64 x, Int64 y -> Int64.compare x y + | Nativeint x, Nativeint y -> Nativeint.compare x y + | Float_array x, Float_array y -> compare_float_lists x y + | Immutable_float_array x, Immutable_float_array y -> compare_float_lists x y + | String x, String y -> String.compare x y + | Immutable_string x, Immutable_string y -> String.compare x y + | Float _, _ -> -1 + | _, Float _ -> 1 + | Int32 _, _ -> -1 + | _, Int32 _ -> 1 + | Int64 _, _ -> -1 + | _, Int64 _ -> 1 + | Nativeint _, _ -> -1 + | _, Nativeint _ -> 1 + | Float_array _, _ -> -1 + | _, Float_array _ -> 1 + | Immutable_float_array _, _ -> -1 + | _, Immutable_float_array _ -> 1 + | String _, _ -> -1 + | _, String _ -> 1 + +let print ppf (t : t) = + let fprintf = Format.fprintf in + let floats ppf fl = + List.iter (fun f -> fprintf ppf "@ %f" f) fl + in + match t with + | String s -> fprintf ppf "%S" s + | Immutable_string s -> fprintf ppf "#%S" s + | Int32 n -> fprintf ppf "%lil" n + | Int64 n -> fprintf ppf "%LiL" n + | Nativeint n -> fprintf ppf "%nin" n + | Float f -> fprintf ppf "%f" f + | Float_array [] -> fprintf ppf "[| |]" + | Float_array (f1 :: fl) -> + fprintf ppf "@[<1>[|@[%f%a@]|]@]" f1 floats fl + | Immutable_float_array [] -> fprintf ppf "[|# |]" + | Immutable_float_array (f1 :: fl) -> + fprintf ppf "@[<1>[|# @[%f%a@]|]@]" f1 floats fl diff --git a/middle_end/flambda/allocated_const.mli b/middle_end/flambda/allocated_const.mli new file mode 100644 index 00000000..0bdbe49e --- /dev/null +++ b/middle_end/flambda/allocated_const.mli @@ -0,0 +1,38 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Constants that are always allocated (possibly statically). Blocks + are not included here since they are always encoded using + [Prim (Pmakeblock, ...)]. *) + +type t = + | Float of float + | Int32 of int32 + | Int64 of int64 + | Nativeint of nativeint + (* CR-someday mshinwell: consider using "float array" *) + | Float_array of float list + | Immutable_float_array of float list + | String of string + | Immutable_string of string + +val compare_floats : float -> float -> int + +val compare : t -> t -> int + +val print : Format.formatter -> t -> unit diff --git a/middle_end/flambda/augment_specialised_args.ml b/middle_end/flambda/augment_specialised_args.ml new file mode 100644 index 00000000..c3a30785 --- /dev/null +++ b/middle_end/flambda/augment_specialised_args.ml @@ -0,0 +1,762 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module E = Inline_and_simplify_aux.Env +module B = Inlining_cost.Benefit + +module Definition = struct + type t = + | Existing_inner_free_var of Variable.t + | Projection_from_existing_specialised_arg of Projection.t + + include Identifiable.Make (struct + type nonrec t = t + + let compare t1 t2 = + match t1, t2 with + | Existing_inner_free_var var1, Existing_inner_free_var var2 -> + Variable.compare var1 var2 + | Projection_from_existing_specialised_arg proj1, + Projection_from_existing_specialised_arg proj2 -> + Projection.compare proj1 proj2 + | Existing_inner_free_var _, _ -> -1 + | _, Existing_inner_free_var _ -> 1 + + let equal t1 t2 = + (compare t1 t2) = 0 + + let hash = Hashtbl.hash + + let print ppf t = + match t with + | Existing_inner_free_var var -> + Format.fprintf ppf "Existing_inner_free_var %a" + Variable.print var + | Projection_from_existing_specialised_arg projection -> + Format.fprintf ppf "Projection_from_existing_specialised_arg %a" + Projection.print projection + + let output _ _ = failwith "Definition.output not yet implemented" + end) +end + +module What_to_specialise = struct + type t = { + (* [definitions] is indexed by (fun_var, group) *) + definitions : Definition.t list Variable.Pair.Map.t; + set_of_closures : Flambda.set_of_closures; + make_direct_call_surrogates_for : Variable.Set.t; + } + + let create ~set_of_closures = + { definitions = Variable.Pair.Map.empty; + set_of_closures; + make_direct_call_surrogates_for = Variable.Set.empty; + } + + let new_specialised_arg t ~fun_var ~group ~definition = + let key = fun_var, group in + let definitions = + match Variable.Pair.Map.find key t.definitions with + | exception Not_found -> [] + | definitions -> definitions + in + let definitions = + Variable.Pair.Map.add (fun_var, group) (definition :: definitions) + t.definitions + in + { t with definitions; } + + let make_direct_call_surrogate_for t ~fun_var = + match Variable.Map.find fun_var t.set_of_closures.function_decls.funs with + | exception Not_found -> + Misc.fatal_errorf "use_direct_call_surrogate_for: %a is not a fun_var \ + from the given set of closures" + Variable.print fun_var + | _ -> + { t with + make_direct_call_surrogates_for = + Variable.Set.add fun_var t.make_direct_call_surrogates_for; + } +end + +module W = What_to_specialise + +module type S = sig + val pass_name : string + + val what_to_specialise + : env:Inline_and_simplify_aux.Env.t + -> set_of_closures:Flambda.set_of_closures + -> What_to_specialise.t +end + +module Processed_what_to_specialise = struct + type for_one_function = { + fun_var : Variable.t; + function_decl : Flambda.function_declaration; + make_direct_call_surrogates : bool; + new_definitions_indexed_by_new_inner_vars : Definition.t Variable.Map.t; + all_new_definitions : Definition.Set.t; + new_inner_to_new_outer_vars : Variable.t Variable.Map.t; + total_number_of_args : int; + existing_specialised_args : Flambda.specialised_to Variable.Map.t; + } + + type t = { + set_of_closures : Flambda.set_of_closures; + existing_definitions_via_spec_args_indexed_by_fun_var + : Definition.Set.t Variable.Map.t; + (* The following two maps' definitions have already been rewritten + into their lifted form (i.e. they reference outer rather than inner + variables). *) + new_lifted_defns_indexed_by_new_outer_vars : Projection.t Variable.Map.t; + new_outer_vars_indexed_by_new_lifted_defns : Variable.t Projection.Map.t; + functions : for_one_function Variable.Map.t; + make_direct_call_surrogates_for : Variable.Set.t; + } + + let lift_projection t ~(projection : Projection.t) = + (* The lifted definition must be in terms of outer variables, + not inner variables. *) + let find_outer_var inner_var = + match Variable.Map.find inner_var t.set_of_closures.specialised_args with + | (outer_var : Flambda.specialised_to) -> outer_var.var + | exception Not_found -> + Misc.fatal_errorf "find_outer_var: expected %a \ + to be in [specialised_args], but it is \ + not. The projection was: %a. Set of closures: %a" + Variable.print inner_var + Projection.print projection + Flambda.print_set_of_closures t.set_of_closures + in + Projection.map_projecting_from projection ~f:find_outer_var + + let really_add_new_specialised_arg t ~group ~(definition : Definition.t) + ~(for_one_function : for_one_function) = + let fun_var = for_one_function.fun_var in + (* We know here that a new specialised argument must be added. This + needs a "new inner var" and a "new outer var". However if there + is already a lifted projection being introduced around the set + of closures (corresponding to another new specialised argument), + we should re-use its "new outer var" to avoid duplication of + projection definitions. Likewise if the definition is just + [Existing_inner_free_var], in which case we can use the + corresponding existing outer free variable. *) + let new_outer_var, t = + let existing_outer_var = + match definition with + | Existing_inner_free_var _ -> None + | Projection_from_existing_specialised_arg projection -> + let projection = lift_projection t ~projection in + match + Projection.Map.find projection + t.new_outer_vars_indexed_by_new_lifted_defns + with + | new_outer_var -> Some new_outer_var + | exception Not_found -> None + in + match existing_outer_var with + | Some existing_outer_var -> existing_outer_var, t + | None -> + match definition with + | Existing_inner_free_var existing_inner_var -> + begin match + Variable.Map.find existing_inner_var + t.set_of_closures.free_vars + with + | exception Not_found -> + Misc.fatal_errorf "really_add_new_specialised_arg: \ + Existing_inner_free_var %a is not an inner free variable \ + of %a in %a" + Variable.print existing_inner_var + Variable.print fun_var + Flambda.print_set_of_closures t.set_of_closures + | existing_outer_var -> existing_outer_var.var, t + end + | Projection_from_existing_specialised_arg projection -> + let new_outer_var = Variable.rename group in + let projection = lift_projection t ~projection in + let new_outer_vars_indexed_by_new_lifted_defns = + Projection.Map.add + projection new_outer_var + t.new_outer_vars_indexed_by_new_lifted_defns + in + let new_lifted_defns_indexed_by_new_outer_vars = + Variable.Map.add + new_outer_var projection + t.new_lifted_defns_indexed_by_new_outer_vars + in + let t = + { t with + new_outer_vars_indexed_by_new_lifted_defns; + new_lifted_defns_indexed_by_new_outer_vars; + } + in + new_outer_var, t + in + let new_inner_var = Variable.rename group in + let new_inner_to_new_outer_vars = + Variable.Map.add new_inner_var new_outer_var + for_one_function.new_inner_to_new_outer_vars + in + let for_one_function : for_one_function = + { for_one_function with + new_definitions_indexed_by_new_inner_vars = + Variable.Map.add new_inner_var definition + for_one_function.new_definitions_indexed_by_new_inner_vars; + all_new_definitions = + Definition.Set.add definition + for_one_function.all_new_definitions; + new_inner_to_new_outer_vars; + total_number_of_args = for_one_function.total_number_of_args + 1; + } + in + { t with + functions = Variable.Map.add fun_var for_one_function t.functions; + } + + let new_specialised_arg t ~fun_var ~group ~definition = + let for_one_function : for_one_function = + match Variable.Map.find fun_var t.functions with + | exception Not_found -> + begin + match Variable.Map.find fun_var t.set_of_closures.function_decls.funs + with + | exception Not_found -> assert false + | (function_decl : Flambda.function_declaration) -> + let params = Parameter.Set.vars function_decl.params in + let existing_specialised_args = + Variable.Map.filter (fun inner_var _spec_to -> + Variable.Set.mem inner_var params) + t.set_of_closures.specialised_args + in + let make_direct_call_surrogates = + Variable.Set.mem fun_var t.make_direct_call_surrogates_for + in + { fun_var; + function_decl; + make_direct_call_surrogates; + new_definitions_indexed_by_new_inner_vars = Variable.Map.empty; + all_new_definitions = Definition.Set.empty; + new_inner_to_new_outer_vars = Variable.Map.empty; + (* The "+ 1" is just in case there is a closure environment + parameter added later. *) + total_number_of_args = List.length function_decl.params + 1; + existing_specialised_args; + } + end + | for_one_function -> for_one_function + in + (* Determine whether there already exists an existing specialised argument + that is known to be equal to the one proposed to this function. If so, + use that instead. (Note that we also desire to dedup against any + new specialised arguments added to the current function; but that + happens automatically since [Extract_projections] returns a set.) *) + let exists_already = + match + Variable.Map.find fun_var + t.existing_definitions_via_spec_args_indexed_by_fun_var + with + | exception Not_found -> false + | definitions -> Definition.Set.mem definition definitions + in + if exists_already then t + else really_add_new_specialised_arg t ~group ~definition ~for_one_function + + let create ~env ~(what_to_specialise : W.t) = + let existing_definitions_via_spec_args_indexed_by_fun_var = + Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> + if function_decl.stub then + Definition.Set.empty + else + let params = Parameter.Set.vars function_decl.params in + Variable.Map.fold (fun inner_var + (spec_to : Flambda.specialised_to) definitions -> + if not (Variable.Set.mem inner_var params) then + definitions + else + let definition : Definition.t = + match spec_to.projection with + | None -> Existing_inner_free_var inner_var + | Some projection -> + Projection_from_existing_specialised_arg projection + in + Definition.Set.add definition definitions) + what_to_specialise.set_of_closures.specialised_args + Definition.Set.empty) + what_to_specialise.set_of_closures.function_decls.funs + in + let t : t = + { set_of_closures = what_to_specialise.set_of_closures; + existing_definitions_via_spec_args_indexed_by_fun_var; + new_lifted_defns_indexed_by_new_outer_vars = Variable.Map.empty; + new_outer_vars_indexed_by_new_lifted_defns = Projection.Map.empty; + functions = Variable.Map.empty; + make_direct_call_surrogates_for = + what_to_specialise.make_direct_call_surrogates_for; + } + in + (* It is important to limit the number of arguments added: if arguments + end up being passed on the stack, tail call optimization will be + disabled (see asmcomp/selectgen.ml). + For each group of new specialised args provided by [T], either all or + none of them will be added. (This is to avoid the situation where we + add extra arguments but yet fail to eliminate an original one by + stopping part-way through the specialised args addition.) *) + let by_group = + Variable.Pair.Map.fold (fun (fun_var, group) definitions by_group -> + let fun_vars_and_definitions = + match Variable.Map.find group by_group with + | exception Not_found -> [] + | fun_vars_and_definitions -> fun_vars_and_definitions + in + Variable.Map.add group + ((fun_var, definitions)::fun_vars_and_definitions) + by_group) + what_to_specialise.definitions + Variable.Map.empty + in + let module Backend = (val (E.backend env) : Backend_intf.S) in + Variable.Map.fold (fun group fun_vars_and_definitions t -> + let original_t = t in + let t = + (* Try adding all specialised args in the current group. *) + List.fold_left (fun t (fun_var, definitions) -> + List.fold_left (fun t definition -> + new_specialised_arg t ~fun_var ~group ~definition) + t + definitions) + t + fun_vars_and_definitions + in + let some_function_has_too_many_args = + Variable.Map.exists (fun _ (for_one_function : for_one_function) -> + for_one_function.total_number_of_args + > Backend.max_sensible_number_of_arguments) + t.functions + in + if some_function_has_too_many_args then + original_t (* drop this group *) + else + t) + by_group + t +end + +module P = Processed_what_to_specialise + +let check_invariants ~pass_name ~(set_of_closures : Flambda.set_of_closures) + ~original_set_of_closures = + if !Clflags.flambda_invariant_checks then begin + Variable.Map.iter (fun fun_var + (function_decl : Flambda.function_declaration) -> + let params = Parameter.Set.vars function_decl.params in + Variable.Map.iter (fun inner_var + (outer_var : Flambda.specialised_to) -> + if Variable.Set.mem inner_var params then begin + assert (not (Variable.Set.mem outer_var.var + function_decl.free_variables)); + match outer_var.projection with + | None -> () + | Some projection -> + let from = Projection.projecting_from projection in + if not (Variable.Set.mem from params) then begin + Misc.fatal_errorf "Augment_specialised_args (%s): \ + specialised argument (%a -> %a) references a \ + projection variable that is not a specialised \ + argument of the function %a. @ The set of closures \ + before the transformation was:@ %a. @ The set of \ + closures after the transformation was:@ %a." + pass_name + Variable.print inner_var + Flambda.print_specialised_to outer_var + Variable.print fun_var + Flambda.print_set_of_closures original_set_of_closures + Flambda.print_set_of_closures set_of_closures + end + end) + set_of_closures.specialised_args) + set_of_closures.function_decls.funs + end + +module Make (T : S) = struct + let () = Pass_wrapper.register ~pass_name:T.pass_name + + let rename_function_and_parameters ~fun_var + ~(function_decl : Flambda.function_declaration) = + let new_fun_var = Variable.rename fun_var in + let params_renaming_list = + List.map (fun param -> + let new_param = Parameter.rename param in + param, new_param) + function_decl.params + in + let renamed_params = List.map snd params_renaming_list in + let params_renaming = + Variable.Map.of_list + (List.map (fun (param, new_param) -> + Parameter.var param, Parameter.var new_param) + params_renaming_list) + in + new_fun_var, params_renaming, renamed_params + + let create_wrapper ~(for_one_function : P.for_one_function) ~benefit = + let fun_var = for_one_function.fun_var in + let function_decl = for_one_function.function_decl in + (* To avoid increasing the free variables of the wrapper, for + general cleanliness, we restate the definitions of the + newly-specialised arguments in the wrapper itself in terms of the + original specialised arguments. The variables bound to these + definitions are called the "specialised args bound in the wrapper". + Note that the domain of [params_renaming] is a (non-strict) superset + of the "inner vars" of the original specialised args. *) + let params = Parameter.Set.vars function_decl.params in + let new_fun_var, params_renaming, wrapper_params = + rename_function_and_parameters ~fun_var ~function_decl + in + let find_wrapper_param param = + assert (Variable.Set.mem param params); + match Variable.Map.find param params_renaming with + | wrapper_param -> wrapper_param + | exception Not_found -> + Misc.fatal_errorf "find_wrapper_param: expected %a \ + to be in [params_renaming], but it is not." + Variable.print param + in + let new_inner_vars_to_spec_args_bound_in_the_wrapper_renaming = + Variable.Map.mapi (fun new_inner_var _ -> + Variable.rename new_inner_var) + for_one_function.new_definitions_indexed_by_new_inner_vars + in + let spec_args_bound_in_the_wrapper = + (* N.B.: in the order matching the new specialised argument parameters + to the main function. *) + Variable.Map.data + new_inner_vars_to_spec_args_bound_in_the_wrapper_renaming + in + (* New definitions that project from existing specialised args need + to be rewritten to use the corresponding specialised args of + the wrapper. Definitions that are just equality to existing + inner free variables do not need to be changed. Once this has + been done the wrapper body can be constructed. + We also need to rewrite definitions for any existing specialised + args; these now have corresponding wrapper parameters that must + also be specialised. *) + let wrapper_body, benefit = + let apply : Flambda.expr = + Apply { + func = new_fun_var; + args = + (Parameter.List.vars wrapper_params) @ + spec_args_bound_in_the_wrapper; + kind = Direct (Closure_id.wrap new_fun_var); + dbg = Debuginfo.none; + inline = Default_inline; + specialise = Default_specialise; + } + in + Variable.Map.fold (fun new_inner_var definition (wrapper_body, benefit) -> + let definition : Definition.t = + match (definition : Definition.t) with + | Existing_inner_free_var _ -> definition + | Projection_from_existing_specialised_arg projection -> + Projection_from_existing_specialised_arg + (Projection.map_projecting_from projection + ~f:find_wrapper_param) + in + let benefit = + match (definition : Definition.t) with + | Existing_inner_free_var _ -> benefit + | Projection_from_existing_specialised_arg projection -> + B.add_projection projection benefit + in + match + Variable.Map.find new_inner_var + new_inner_vars_to_spec_args_bound_in_the_wrapper_renaming + with + | exception Not_found -> assert false + | new_inner_var_of_wrapper -> + let named : Flambda.named = + match definition with + | Existing_inner_free_var existing_inner_var -> + Expr (Var existing_inner_var) + | Projection_from_existing_specialised_arg projection -> + Flambda_utils.projection_to_named projection + in + let wrapper_body = + Flambda.create_let new_inner_var_of_wrapper named wrapper_body + in + (wrapper_body, benefit)) + for_one_function.new_definitions_indexed_by_new_inner_vars + (apply, benefit) + in + let rewritten_existing_specialised_args = + Variable.Map.fold (fun inner_var (spec_to : Flambda.specialised_to) + result -> + let inner_var = find_wrapper_param inner_var in + let projection = + match spec_to.projection with + | None -> None + | Some projection -> + Some (Projection.map_projecting_from projection + ~f:find_wrapper_param) + in + let spec_to : Flambda.specialised_to = + { var = spec_to.var; + projection; + } + in + Variable.Map.add inner_var spec_to result) + for_one_function.existing_specialised_args + Variable.Map.empty + in + let new_function_decl = + Flambda.create_function_declaration + ~params:wrapper_params + ~body:wrapper_body + ~stub:true + ~dbg:Debuginfo.none + ~inline:Default_inline + ~specialise:Default_specialise + ~is_a_functor:false + ~closure_origin:function_decl.closure_origin + in + new_fun_var, new_function_decl, rewritten_existing_specialised_args, + benefit + + let rewrite_function_decl (t : P.t) ~env ~duplicate_function + ~(for_one_function : P.for_one_function) ~benefit = + let set_of_closures = t.set_of_closures in + let fun_var = for_one_function.fun_var in + let function_decl = for_one_function.function_decl in + let num_definitions = + Variable.Map.cardinal for_one_function. + new_definitions_indexed_by_new_inner_vars + in + if function_decl.stub + || num_definitions < 1 + || Variable.Map.mem fun_var set_of_closures.direct_call_surrogates + then + None + else + let new_fun_var, wrapper, rewritten_existing_specialised_args, benefit = + create_wrapper ~for_one_function ~benefit + in + let new_specialised_args = + Variable.Map.mapi (fun new_inner_var (definition : Definition.t) + : Flambda.specialised_to -> + assert (not (Variable.Map.mem new_inner_var + set_of_closures.specialised_args)); + match + Variable.Map.find new_inner_var + for_one_function.new_inner_to_new_outer_vars + with + | exception Not_found -> assert false + | new_outer_var -> + match definition with + | Existing_inner_free_var _ -> + { var = new_outer_var; + projection = None; + } + | Projection_from_existing_specialised_arg projection -> + let projecting_from = Projection.projecting_from projection in + assert (Variable.Map.mem projecting_from + set_of_closures.specialised_args); + assert (Variable.Set.mem projecting_from + (Parameter.Set.vars function_decl.params)); + { var = new_outer_var; + projection = Some projection; + }) + for_one_function.new_definitions_indexed_by_new_inner_vars + in + let specialised_args = + Variable.Map.disjoint_union rewritten_existing_specialised_args + new_specialised_args + in + let specialised_args, existing_function_decl = + if not for_one_function.make_direct_call_surrogates then + specialised_args, None + else + let function_decl, new_specialised_args = + duplicate_function ~env ~set_of_closures ~fun_var ~new_fun_var + in + let specialised_args = + Variable.Map.disjoint_union specialised_args new_specialised_args + in + specialised_args, Some function_decl + in + let all_params = + let new_params = + Variable.Set.elements (Variable.Map.keys + for_one_function.new_inner_to_new_outer_vars) + in + let new_params = + List.map Parameter.wrap new_params + in + function_decl.params @ new_params + in + let closure_origin = + Closure_origin.create (Closure_id.wrap new_fun_var) + in + let rewritten_function_decl = + Flambda.create_function_declaration + ~params:all_params + ~body:function_decl.body + ~stub:function_decl.stub + ~dbg:function_decl.dbg + ~inline:function_decl.inline + ~specialise:function_decl.specialise + ~is_a_functor:function_decl.is_a_functor + ~closure_origin + in + let funs, direct_call_surrogates = + if for_one_function.make_direct_call_surrogates then + let surrogate = Variable.rename fun_var in + let funs = + (* In this case, the original function declaration remains + untouched up to alpha-equivalence. Direct calls to it + (including inside the rewritten original function) will be + replaced by calls to the surrogate (i.e. the wrapper) which + will then be inlined. *) + let existing_function_decl = + match existing_function_decl with + | Some decl -> decl + | None -> assert false + in + Variable.Map.add new_fun_var rewritten_function_decl + (Variable.Map.add surrogate wrapper + (Variable.Map.add fun_var existing_function_decl + Variable.Map.empty)) + in + let direct_call_surrogates = + Variable.Map.add fun_var surrogate Variable.Map.empty + in + funs, direct_call_surrogates + else + let funs = + Variable.Map.add new_fun_var rewritten_function_decl + (Variable.Map.add fun_var wrapper Variable.Map.empty) + in + funs, Variable.Map.empty + in + let free_vars = Variable.Map.empty in + Some (funs, free_vars, specialised_args, direct_call_surrogates, benefit) + + let add_lifted_projections_around_set_of_closures + ~(set_of_closures : Flambda.set_of_closures) ~benefit + ~new_lifted_defns_indexed_by_new_outer_vars = + let body = + Flambda_utils.name_expr + ~name:Internal_variable_names.set_of_closures + (Set_of_closures set_of_closures) + in + Variable.Map.fold (fun new_outer_var (projection : Projection.t) + (expr, benefit) -> + let named = Flambda_utils.projection_to_named projection in + let benefit = B.add_projection projection benefit in + let expr = Flambda.create_let new_outer_var named expr in + expr, benefit) + new_lifted_defns_indexed_by_new_outer_vars + (body, benefit) + + let rewrite_set_of_closures_core ~env ~duplicate_function ~benefit + ~(set_of_closures : Flambda.set_of_closures) = + let what_to_specialise = + P.create ~env + ~what_to_specialise:(T.what_to_specialise ~env ~set_of_closures) + in + let original_set_of_closures = set_of_closures in + let funs, free_vars, specialised_args, direct_call_surrogates, + done_something, benefit = + Variable.Map.fold (fun fun_var function_decl + (funs, free_vars, specialised_args, direct_call_surrogates, + done_something, benefit) -> + match Variable.Map.find fun_var what_to_specialise.functions with + | exception Not_found -> + let funs = Variable.Map.add fun_var function_decl funs in + funs, free_vars, specialised_args, direct_call_surrogates, + done_something, benefit + | (for_one_function : P.for_one_function) -> + assert (Variable.equal fun_var for_one_function.fun_var); + match + rewrite_function_decl what_to_specialise ~env + ~duplicate_function ~for_one_function ~benefit + with + | None -> + let function_decl = for_one_function.function_decl in + let funs = Variable.Map.add fun_var function_decl funs in + funs, free_vars, specialised_args, direct_call_surrogates, + done_something, benefit + | Some (funs', free_vars', specialised_args', + direct_call_surrogates', benefit) -> + let funs = Variable.Map.disjoint_union funs funs' in + let direct_call_surrogates = + Variable.Map.disjoint_union direct_call_surrogates + direct_call_surrogates' + in + let free_vars = + Variable.Map.disjoint_union free_vars free_vars' + in + let specialised_args = + Variable.Map.disjoint_union specialised_args specialised_args' + in + funs, free_vars, specialised_args, direct_call_surrogates, true, + benefit) + set_of_closures.function_decls.funs + (Variable.Map.empty, set_of_closures.free_vars, + set_of_closures.specialised_args, + set_of_closures.direct_call_surrogates, false, benefit) + in + if not done_something then + None + else + let function_decls = + Flambda.update_function_declarations set_of_closures.function_decls + ~funs + in + assert (Variable.Map.cardinal specialised_args + >= Variable.Map.cardinal original_set_of_closures.specialised_args); + let set_of_closures = + Flambda.create_set_of_closures + ~function_decls + ~free_vars + ~specialised_args + ~direct_call_surrogates + in + if !Clflags.flambda_invariant_checks then begin + check_invariants ~set_of_closures ~original_set_of_closures + ~pass_name:T.pass_name + end; + let expr, benefit = + add_lifted_projections_around_set_of_closures ~set_of_closures ~benefit + ~new_lifted_defns_indexed_by_new_outer_vars: + what_to_specialise.new_lifted_defns_indexed_by_new_outer_vars + in + Some (expr, benefit) + + let rewrite_set_of_closures ~env ~duplicate_function ~set_of_closures = + Pass_wrapper.with_dump ~ppf_dump:(Inline_and_simplify_aux.Env.ppf_dump env) + ~pass_name:T.pass_name ~input:set_of_closures + ~print_input:Flambda.print_set_of_closures + ~print_output:(fun ppf (expr, _) -> Flambda.print ppf expr) + ~f:(fun () -> + rewrite_set_of_closures_core ~env ~duplicate_function + ~benefit:B.zero ~set_of_closures) +end diff --git a/middle_end/flambda/augment_specialised_args.mli b/middle_end/flambda/augment_specialised_args.mli new file mode 100644 index 00000000..5c48a126 --- /dev/null +++ b/middle_end/flambda/augment_specialised_args.mli @@ -0,0 +1,65 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Helper module for adding specialised arguments to sets of closures. *) + +module Definition : sig + type t = + | Existing_inner_free_var of Variable.t + | Projection_from_existing_specialised_arg of Projection.t +end + +module What_to_specialise : sig + type t + + val create + : set_of_closures:Flambda.set_of_closures + -> t + + val new_specialised_arg + : t + -> fun_var:Variable.t + -> group:Variable.t + -> definition:Definition.t (* [projecting_from] "existing inner vars" *) + -> t + + val make_direct_call_surrogate_for : t -> fun_var:Variable.t -> t +end + +module type S = sig + val pass_name : string + + val what_to_specialise + : env:Inline_and_simplify_aux.Env.t + -> set_of_closures:Flambda.set_of_closures + -> What_to_specialise.t +end + +module Make (T : S) : sig + (** [duplicate_function] should be + [Inline_and_simplify.duplicate_function]. *) + val rewrite_set_of_closures + : env:Inline_and_simplify_aux.Env.t + -> duplicate_function:( + env:Inline_and_simplify_aux.Env.t + -> set_of_closures:Flambda.set_of_closures + -> fun_var:Variable.t + -> new_fun_var:Variable.t + -> Flambda.function_declaration + * Flambda.specialised_to Variable.Map.t) + -> set_of_closures:Flambda.set_of_closures + -> (Flambda.expr * Inlining_cost.Benefit.t) option +end diff --git a/middle_end/flambda/base_types/closure_element.ml b/middle_end/flambda/base_types/closure_element.ml new file mode 100644 index 00000000..561e0803 --- /dev/null +++ b/middle_end/flambda/base_types/closure_element.ml @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +include Variable + +let wrap t = t +let unwrap t = t + +let wrap_map t = t +let unwrap_set t = t diff --git a/middle_end/flambda/base_types/closure_element.mli b/middle_end/flambda/base_types/closure_element.mli new file mode 100644 index 00000000..d78dd9b3 --- /dev/null +++ b/middle_end/flambda/base_types/closure_element.mli @@ -0,0 +1,32 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +include Identifiable.S + +val wrap : Variable.t -> t +val unwrap : t -> Variable.t + +val wrap_map : 'a Variable.Map.t -> 'a Map.t +val unwrap_set : Set.t -> Variable.Set.t + +val in_compilation_unit : t -> Compilation_unit.t -> bool +val get_compilation_unit : t -> Compilation_unit.t + +val unique_name : t -> string + +val output_full : out_channel -> t -> unit diff --git a/middle_end/flambda/base_types/closure_id.ml b/middle_end/flambda/base_types/closure_id.ml new file mode 100644 index 00000000..466f59a2 --- /dev/null +++ b/middle_end/flambda/base_types/closure_id.ml @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +include Closure_element diff --git a/middle_end/flambda/base_types/closure_id.mli b/middle_end/flambda/base_types/closure_id.mli new file mode 100644 index 00000000..853a07f7 --- /dev/null +++ b/middle_end/flambda/base_types/closure_id.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** CR-someday lwhite: "Closure_id" is quite a generic name. I wonder + whether something like "Closure_label" would better capture that it is + the label of a projection. *) + +(** An identifier, unique across the whole program (not just one compilation + unit), that identifies a closure within a particular set of closures + (viz. [Project_closure]). *) + +include module type of Closure_element diff --git a/middle_end/flambda/base_types/closure_origin.ml b/middle_end/flambda/base_types/closure_origin.ml new file mode 100644 index 00000000..2285c687 --- /dev/null +++ b/middle_end/flambda/base_types/closure_origin.ml @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell, Leo White and Fu Yong Quah, Jane Street Europe *) +(* *) +(* Copyright 2013--2017 OCamlPro SAS *) +(* Copyright 2014--2017 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +include Closure_id + +let create t = t diff --git a/middle_end/flambda/base_types/closure_origin.mli b/middle_end/flambda/base_types/closure_origin.mli new file mode 100644 index 00000000..86fcd56c --- /dev/null +++ b/middle_end/flambda/base_types/closure_origin.mli @@ -0,0 +1,21 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell, Leo White and Fu Yong Quah, Jane Street Europe *) +(* *) +(* Copyright 2013--2017 OCamlPro SAS *) +(* Copyright 2014--2017 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +include Identifiable.S + +val create : Closure_id.t -> t + +val get_compilation_unit : t -> Compilation_unit.t diff --git a/middle_end/flambda/base_types/export_id.ml b/middle_end/flambda/base_types/export_id.ml new file mode 100644 index 00000000..681ac955 --- /dev/null +++ b/middle_end/flambda/base_types/export_id.ml @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module Id : Id_types.Id = Id_types.Id (struct end) +module Unit_id = Id_types.UnitId (Id) (Compilation_unit) + +type t = Unit_id.t + +include Identifiable.Make (Unit_id) + +let create = Unit_id.create +let get_compilation_unit = Unit_id.unit +let name = Unit_id.name diff --git a/middle_end/flambda/base_types/export_id.mli b/middle_end/flambda/base_types/export_id.mli new file mode 100644 index 00000000..54c14418 --- /dev/null +++ b/middle_end/flambda/base_types/export_id.mli @@ -0,0 +1,28 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(* Keys representing value descriptions that may be written into + intermediate files and loaded by a dependent compilation unit. + These keys are used to ensure maximal sharing of value descriptions, + which may be substantial. *) + +include Identifiable.S + +val create : ?name:string -> Compilation_unit.t -> t +val name : t -> string option +val get_compilation_unit : t -> Compilation_unit.t diff --git a/middle_end/flambda/base_types/id_types.ml b/middle_end/flambda/base_types/id_types.ml new file mode 100644 index 00000000..6d2e2743 --- /dev/null +++ b/middle_end/flambda/base_types/id_types.ml @@ -0,0 +1,93 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module type BaseId = sig + type t + val equal : t -> t -> bool + val compare : t -> t -> int + val hash : t -> int + val name : t -> string option + val to_string : t -> string + val output : out_channel -> t -> unit + val print : Format.formatter -> t -> unit +end + +module type Id = sig + include BaseId + val create : ?name:string -> unit -> t +end + +module type UnitId = sig + module Compilation_unit : Identifiable.Thing + include BaseId + val create : ?name:string -> Compilation_unit.t -> t + val unit : t -> Compilation_unit.t +end + +module Id(E:sig end) : Id = struct + type t = int * string + let empty_string = "" + let create = let r = ref 0 in + fun ?(name=empty_string) () -> incr r; !r, name + let equal (t1,_) (t2,_) = (t1:int) = t2 + let compare (t1,_) (t2,_) = t1 - t2 + let hash (t,_) = t + let name (_,name) = + if name == empty_string + then None + else Some name + let to_string (t,name) = + if name == empty_string + then Int.to_string t + else Printf.sprintf "%s_%i" name t + let output fd t = output_string fd (to_string t) + let print ppf v = Format.pp_print_string ppf (to_string v) +end + +module UnitId(Innerid:Id)(Compilation_unit:Identifiable.Thing) : + UnitId with module Compilation_unit := Compilation_unit = struct + type t = { + id : Innerid.t; + unit : Compilation_unit.t; + } + let compare x y = + let c = Innerid.compare x.id y.id in + if c <> 0 + then c + else Compilation_unit.compare x.unit y.unit + let output oc x = + Printf.fprintf oc "%a.%a" + Compilation_unit.output x.unit + Innerid.output x.id + let print ppf x = + Format.fprintf ppf "%a.%a" + Compilation_unit.print x.unit + Innerid.print x.id + let hash off = Hashtbl.hash off + let equal o1 o2 = compare o1 o2 = 0 + let name o = Innerid.name o.id + let to_string x = + Format.asprintf "%a.%a" + Compilation_unit.print x.unit + Innerid.print x.id + let create ?name unit = + let id = Innerid.create ?name () in + { id; unit } + let unit x = x.unit +end diff --git a/middle_end/flambda/base_types/id_types.mli b/middle_end/flambda/base_types/id_types.mli new file mode 100644 index 00000000..48ca037c --- /dev/null +++ b/middle_end/flambda/base_types/id_types.mli @@ -0,0 +1,56 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(* CR-soon mshinwell: This module should be removed. *) + +(** Generic identifier type *) +module type BaseId = +sig + type t + val equal : t -> t -> bool + val compare : t -> t -> int + val hash : t -> int + val name : t -> string option + val to_string : t -> string + val output : out_channel -> t -> unit + val print : Format.formatter -> t -> unit +end + +module type Id = +sig + include BaseId + val create : ?name:string -> unit -> t +end + +(** Fully qualified identifiers *) +module type UnitId = +sig + module Compilation_unit : Identifiable.Thing + include BaseId + val create : ?name:string -> Compilation_unit.t -> t + val unit : t -> Compilation_unit.t +end + +(** If applied generatively, i.e. [Id(struct end)], creates a new type + of identifiers. *) +module Id : functor (E : sig end) -> Id + +module UnitId : + functor (Id : Id) -> + functor (Compilation_unit : Identifiable.Thing) -> + UnitId with module Compilation_unit := Compilation_unit diff --git a/middle_end/flambda/base_types/mutable_variable.ml b/middle_end/flambda/base_types/mutable_variable.ml new file mode 100644 index 00000000..07fe3152 --- /dev/null +++ b/middle_end/flambda/base_types/mutable_variable.ml @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +include Variable + +let create_from_variable = rename diff --git a/middle_end/flambda/base_types/mutable_variable.mli b/middle_end/flambda/base_types/mutable_variable.mli new file mode 100644 index 00000000..17fe208f --- /dev/null +++ b/middle_end/flambda/base_types/mutable_variable.mli @@ -0,0 +1,47 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +include Identifiable.S + +val create + : ?current_compilation_unit:Compilation_unit.t + -> Internal_variable_names.t + -> t + +val create_with_same_name_as_ident : Ident.t -> t + +val create_from_variable + : ?current_compilation_unit:Compilation_unit.t + -> Variable.t + -> t + +val rename + : ?current_compilation_unit:Compilation_unit.t + -> t + -> t + +val in_compilation_unit : t -> Compilation_unit.t -> bool + +val name : t -> string + +val unique_name : t -> string + +val print_list : Format.formatter -> t list -> unit +val print_opt : Format.formatter -> t option -> unit + +val output_full : out_channel -> t -> unit diff --git a/middle_end/flambda/base_types/set_of_closures_id.ml b/middle_end/flambda/base_types/set_of_closures_id.ml new file mode 100644 index 00000000..681ac955 --- /dev/null +++ b/middle_end/flambda/base_types/set_of_closures_id.ml @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module Id : Id_types.Id = Id_types.Id (struct end) +module Unit_id = Id_types.UnitId (Id) (Compilation_unit) + +type t = Unit_id.t + +include Identifiable.Make (Unit_id) + +let create = Unit_id.create +let get_compilation_unit = Unit_id.unit +let name = Unit_id.name diff --git a/middle_end/flambda/base_types/set_of_closures_id.mli b/middle_end/flambda/base_types/set_of_closures_id.mli new file mode 100644 index 00000000..811cb661 --- /dev/null +++ b/middle_end/flambda/base_types/set_of_closures_id.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** An identifier, unique across the whole program, that identifies a set + of closures (viz. [Set_of_closures]). *) + +include Identifiable.S + +val create : ?name:string -> Compilation_unit.t -> t +val name : t -> string option +val get_compilation_unit : t -> Compilation_unit.t diff --git a/middle_end/flambda/base_types/set_of_closures_origin.ml b/middle_end/flambda/base_types/set_of_closures_origin.ml new file mode 100644 index 00000000..a5ef8c7c --- /dev/null +++ b/middle_end/flambda/base_types/set_of_closures_origin.ml @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +include Set_of_closures_id + +let create t = t +let rename f t = f t diff --git a/middle_end/flambda/base_types/set_of_closures_origin.mli b/middle_end/flambda/base_types/set_of_closures_origin.mli new file mode 100644 index 00000000..4c9cfdcf --- /dev/null +++ b/middle_end/flambda/base_types/set_of_closures_origin.mli @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +include Identifiable.S + +val create : Set_of_closures_id.t -> t + +val get_compilation_unit : t -> Compilation_unit.t +val rename : (Set_of_closures_id.t -> Set_of_closures_id.t) -> t -> t diff --git a/middle_end/flambda/base_types/static_exception.ml b/middle_end/flambda/base_types/static_exception.ml new file mode 100644 index 00000000..6cecae63 --- /dev/null +++ b/middle_end/flambda/base_types/static_exception.ml @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +include Numbers.Int + +let create () = Lambda.next_raise_count () +let to_int t = t diff --git a/middle_end/flambda/base_types/static_exception.mli b/middle_end/flambda/base_types/static_exception.mli new file mode 100644 index 00000000..88f690aa --- /dev/null +++ b/middle_end/flambda/base_types/static_exception.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** An identifier that is used to label static exceptions. Its + uniqueness properties are unspecified. *) + +include Identifiable.S + +val create : unit -> t + +val to_int : t -> int diff --git a/middle_end/flambda/base_types/tag.ml b/middle_end/flambda/base_types/tag.ml new file mode 100644 index 00000000..cfa51ddb --- /dev/null +++ b/middle_end/flambda/base_types/tag.ml @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type t = int + +include Identifiable.Make (Numbers.Int) + +let create_exn tag = + if tag < 0 || tag > 255 then + Misc.fatal_error (Printf.sprintf "Tag.create_exn %d" tag) + else + tag + +let to_int t = t + +let zero = 0 +let object_tag = Obj.object_tag + +let compare : t -> t -> int = Stdlib.compare diff --git a/middle_end/flambda/base_types/tag.mli b/middle_end/flambda/base_types/tag.mli new file mode 100644 index 00000000..12ce5525 --- /dev/null +++ b/middle_end/flambda/base_types/tag.mli @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Tags on runtime boxed values. *) + +include Identifiable.S + +val create_exn : int -> t +val to_int : t -> int + +val zero : t +val object_tag : t + +val compare : t -> t -> int diff --git a/middle_end/flambda/base_types/var_within_closure.ml b/middle_end/flambda/base_types/var_within_closure.ml new file mode 100644 index 00000000..466f59a2 --- /dev/null +++ b/middle_end/flambda/base_types/var_within_closure.ml @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +include Closure_element diff --git a/middle_end/flambda/base_types/var_within_closure.mli b/middle_end/flambda/base_types/var_within_closure.mli new file mode 100644 index 00000000..56f0af0a --- /dev/null +++ b/middle_end/flambda/base_types/var_within_closure.mli @@ -0,0 +1,24 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** An identifier, unique across the whole program, that identifies a + particular variable within a particular closure. Only + [Project_var], and not [Var], nodes are tagged with these + identifiers. *) + +include module type of Closure_element diff --git a/middle_end/flambda/build_export_info.ml b/middle_end/flambda/build_export_info.ml new file mode 100644 index 00000000..67fea2db --- /dev/null +++ b/middle_end/flambda/build_export_info.ml @@ -0,0 +1,729 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +module Env : sig + type t + + val new_descr : t -> Export_info.descr -> Export_id.t + + val record_descr : t -> Export_id.t -> Export_info.descr -> unit + val new_value_closure_descr + : t + -> closure_id:Closure_id.t + -> set_of_closures: Export_info.value_set_of_closures + -> Export_id.t + + val get_descr : t -> Export_info.approx -> Export_info.descr option + + val add_approx : t -> Variable.t -> Export_info.approx -> t + val add_approx_maps : t -> Export_info.approx Variable.Map.t list -> t + val find_approx : t -> Variable.t -> Export_info.approx + + val get_symbol_descr : t -> Symbol.t -> Export_info.descr option + + val new_unit_descr : t -> Export_id.t + + val is_symbol_being_defined : t -> Symbol.t -> bool + + module Global : sig + (* "Global" as in "without local variable bindings". *) + type t + + val create_empty : unit -> t + + val add_symbol : t -> Symbol.t -> Export_id.t -> t + val new_symbol : t -> Symbol.t -> Export_id.t * t + + val symbol_to_export_id_map : t -> Export_id.t Symbol.Map.t + val export_id_to_descr_map : t -> Export_info.descr Export_id.Map.t + end + + (** Creates a new environment, sharing the mapping from export IDs to + export descriptions with the given global environment. *) + val empty_of_global : symbols_being_defined:Symbol.Set.t -> Global.t -> t +end = struct + let fresh_id () = Export_id.create (Compilenv.current_unit ()) + + module Global = struct + type t = + { sym : Export_id.t Symbol.Map.t; + (* Note that [ex_table]s themselves are shared (hence [ref] and not + [mutable]). *) + ex_table : Export_info.descr Export_id.Map.t ref; + closure_table : Export_id.t Closure_id.Map.t ref; + } + + let create_empty () = + { sym = Symbol.Map.empty; + ex_table = ref Export_id.Map.empty; + closure_table = ref Closure_id.Map.empty; + } + + let add_symbol t sym export_id = + if Symbol.Map.mem sym t.sym then begin + Misc.fatal_errorf "Build_export_info.Env.Global.add_symbol: cannot \ + rebind symbol %a in environment" + Symbol.print sym + end; + { t with sym = Symbol.Map.add sym export_id t.sym } + + let new_symbol t sym = + let export_id = fresh_id () in + export_id, add_symbol t sym export_id + + let symbol_to_export_id_map t = t.sym + let export_id_to_descr_map t = !(t.ex_table) + end + + (* CR-someday mshinwell: The half-mutable nature of [t] with sharing of + the [ex_table] is kind of nasty. Consider making it immutable. *) + type t = + { var : Export_info.approx Variable.Map.t; + sym : Export_id.t Symbol.Map.t; + symbols_being_defined : Symbol.Set.t; + ex_table : Export_info.descr Export_id.Map.t ref; + closure_table: Export_id.t Closure_id.Map.t ref; + } + + let empty_of_global ~symbols_being_defined (env : Global.t) = + { var = Variable.Map.empty; + sym = env.sym; + symbols_being_defined; + ex_table = env.ex_table; + closure_table = env.closure_table; + } + + let extern_id_descr export_id = + let export = Compilenv.approx_env () in + try Some (Export_info.find_description export export_id) + with Not_found -> None + + let extern_symbol_descr sym = + if Compilenv.is_predefined_exception sym + then None + else + match + Compilenv.approx_for_global (Symbol.compilation_unit sym) + with + | None -> None + | Some export -> + try + let id = Symbol.Map.find sym export.symbol_id in + let descr = Export_info.find_description export id in + Some descr + with + | Not_found -> None + + let get_id_descr t export_id = + try Some (Export_id.Map.find export_id !(t.ex_table)) + with Not_found -> extern_id_descr export_id + + let get_symbol_descr t sym = + try + let export_id = Symbol.Map.find sym t.sym in + Some (Export_id.Map.find export_id !(t.ex_table)) + with + | Not_found -> extern_symbol_descr sym + + let get_descr t (approx : Export_info.approx) = + match approx with + | Value_unknown -> None + | Value_id export_id -> get_id_descr t export_id + | Value_symbol sym -> get_symbol_descr t sym + + let record_descr t id (descr : Export_info.descr) = + if Export_id.Map.mem id !(t.ex_table) then begin + Misc.fatal_errorf "Build_export_info.Env.record_descr: cannot rebind \ + export ID %a in environment" + Export_id.print id + end; + t.ex_table := Export_id.Map.add id descr !(t.ex_table) + + let new_descr t (descr : Export_info.descr) = + let id = fresh_id () in + record_descr t id descr; + id + + let new_value_closure_descr t ~closure_id ~set_of_closures = + match Closure_id.Map.find closure_id !(t.closure_table) with + | exception Not_found -> + let export_id = + new_descr t (Value_closure { closure_id; set_of_closures }) + in + t.closure_table := + Closure_id.Map.add closure_id export_id !(t.closure_table); + export_id + | export_id -> export_id + + let new_unit_descr t = + new_descr t (Value_constptr 0) + + let add_approx t var approx = + if Variable.Map.mem var t.var then begin + Misc.fatal_errorf "Build_export_info.Env.add_approx: cannot rebind \ + variable %a in environment" + Variable.print var + end; + { t with var = Variable.Map.add var approx t.var; } + + let add_approx_map t vars_to_approxs = + Variable.Map.fold (fun var approx t -> add_approx t var approx) + vars_to_approxs + t + + let add_approx_maps t vars_to_approxs_list = + List.fold_left add_approx_map t vars_to_approxs_list + + let find_approx t var : Export_info.approx = + try Variable.Map.find var t.var with + | Not_found -> Value_unknown + + let is_symbol_being_defined t sym = + Symbol.Set.mem sym t.symbols_being_defined +end + +let descr_of_constant (c : Flambda.const) : Export_info.descr = + match c with + (* [Const_pointer] is an immediate value of a type whose values may be + boxed (typically a variant type with both constant and non-constant + constructors). *) + | Int i -> Value_int i + | Char c -> Value_char c + | Const_pointer i -> Value_constptr i + +let descr_of_allocated_constant (c : Allocated_const.t) : Export_info.descr = + match c with + | Float f -> Value_float f + | Int32 i -> Value_boxed_int (Int32, i) + | Int64 i -> Value_boxed_int (Int64, i) + | Nativeint i -> Value_boxed_int (Nativeint, i) + | String s -> + let v_string : Export_info.value_string = + { size = String.length s; contents = Unknown_or_mutable; } + in + Value_string v_string + | Immutable_string s -> + let v_string : Export_info.value_string = + { size = String.length s; contents = Contents s; } + in + Value_string v_string + | Immutable_float_array fs -> + Value_float_array { + contents = Contents (Array.map (fun x -> Some x) (Array.of_list fs)); + size = List.length fs; + } + | Float_array fs -> + Value_float_array { + contents = Unknown_or_mutable; + size = List.length fs; + } + +let rec approx_of_expr (env : Env.t) (flam : Flambda.t) : Export_info.approx = + match flam with + | Var var -> Env.find_approx env var + | Let { var; defining_expr; body; _ } -> + let approx = descr_of_named env defining_expr in + let env = Env.add_approx env var approx in + approx_of_expr env body + | Let_mutable { body } -> + approx_of_expr env body + | Let_rec (defs, body) -> + let env = + List.fold_left (fun env (var, defining_expr) -> + let approx = descr_of_named env defining_expr in + Env.add_approx env var approx) + env defs + in + approx_of_expr env body + | Apply { func; kind; _ } -> + begin match kind with + | Indirect -> Value_unknown + | Direct closure_id' -> + match Env.get_descr env (Env.find_approx env func) with + | Some (Value_closure + { closure_id; set_of_closures = { results; _ }; }) -> + assert (Closure_id.equal closure_id closure_id'); + assert (Closure_id.Map.mem closure_id results); + Closure_id.Map.find closure_id results + | _ -> Value_unknown + end + | Assign _ -> Value_id (Env.new_unit_descr env) + | For _ -> Value_id (Env.new_unit_descr env) + | While _ -> Value_id (Env.new_unit_descr env) + | Static_raise _ | Static_catch _ | Try_with _ | If_then_else _ + | Switch _ | String_switch _ | Send _ | Proved_unreachable -> + Value_unknown + +and descr_of_named (env : Env.t) (named : Flambda.named) + : Export_info.approx = + match named with + | Expr expr -> approx_of_expr env expr + | Symbol sym -> Value_symbol sym + | Read_mutable _ -> Value_unknown + | Read_symbol_field (sym, i) -> + begin match Env.get_symbol_descr env sym with + | Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i) + | _ -> Value_unknown + end + | Const const -> + Value_id (Env.new_descr env (descr_of_constant const)) + | Allocated_const const -> + Value_id (Env.new_descr env (descr_of_allocated_constant const)) + | Prim (Pmakeblock (tag, Immutable, _value_kind), args, _dbg) -> + let approxs = List.map (Env.find_approx env) args in + let descr : Export_info.descr = + Value_block (Tag.create_exn tag, Array.of_list approxs) + in + Value_id (Env.new_descr env descr) + | Prim (Pfield i, [arg], _) -> + begin match Env.get_descr env (Env.find_approx env arg) with + | Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i) + | _ -> Value_unknown + end + | Prim _ -> Value_unknown + | Set_of_closures set -> + let descr : Export_info.descr = + Value_set_of_closures (describe_set_of_closures env set) + in + Value_id (Env.new_descr env descr) + | Project_closure { set_of_closures; closure_id; } -> + begin match Env.get_descr env (Env.find_approx env set_of_closures) with + | Some (Value_set_of_closures set_of_closures) -> + if not (Closure_id.Map.mem closure_id set_of_closures.results) then begin + Misc.fatal_errorf "Could not build export description for \ + [Project_closure]: closure ID %a not in set of closures" + Closure_id.print closure_id + end; + Value_id ( + Env.new_value_closure_descr env ~closure_id ~set_of_closures + ) + | _ -> + (* It would be nice if this were [assert false], but owing to the fact + that this pass may propagate less information than for example + [Inline_and_simplify], we might end up here. *) + Value_unknown + end + | Move_within_set_of_closures { closure; start_from; move_to; } -> + begin match Env.get_descr env (Env.find_approx env closure) with + | Some (Value_closure { set_of_closures; closure_id; }) -> + assert (Closure_id.equal closure_id start_from); + Value_id ( + Env.new_value_closure_descr env ~closure_id:move_to ~set_of_closures + ) + | _ -> Value_unknown + end + | Project_var { closure; closure_id = closure_id'; var; } -> + begin match Env.get_descr env (Env.find_approx env closure) with + | Some (Value_closure + { set_of_closures = { bound_vars; _ }; closure_id; }) -> + assert (Closure_id.equal closure_id closure_id'); + if not (Var_within_closure.Map.mem var bound_vars) then begin + Misc.fatal_errorf "Project_var from %a (closure ID %a) of \ + variable %a that is not bound by the closure. \ + Variables bound by the closure are: %a" + Variable.print closure + Closure_id.print closure_id + Var_within_closure.print var + (Var_within_closure.Map.print (fun _ _ -> ())) bound_vars + end; + Var_within_closure.Map.find var bound_vars + | _ -> Value_unknown + end + +and describe_set_of_closures env (set : Flambda.set_of_closures) + : Export_info.value_set_of_closures = + let bound_vars_approx = + Variable.Map.map (fun (external_var : Flambda.specialised_to) -> + Env.find_approx env external_var.var) + set.free_vars + in + let specialised_args_approx = + Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> + Env.find_approx env spec_to.var) + set.specialised_args + in + let closures_approx = + (* To build an approximation of the results, we need an + approximation of the functions. The first one we can build is + one where every function returns something unknown. + *) + (* CR-someday pchambart: we could improve a bit on that by building a + recursive approximation of the closures: The value_closure + description contains a [value_set_of_closures]. We could replace + this field by a [Expr_id.t] or an [approx]. + mshinwell: Deferred for now. + *) + let initial_value_set_of_closures = + { Export_info. + set_of_closures_id = set.function_decls.set_of_closures_id; + bound_vars = Var_within_closure.wrap_map bound_vars_approx; + free_vars = set.free_vars; + results = + Closure_id.wrap_map + (Variable.Map.map (fun _ -> Export_info.Value_unknown) + set.function_decls.funs); + aliased_symbol = None; + } + in + Variable.Map.mapi (fun fun_var _function_decl -> + let export_id = + let closure_id = Closure_id.wrap fun_var in + let set_of_closures = initial_value_set_of_closures in + Env.new_value_closure_descr env ~closure_id ~set_of_closures + in + Export_info.Value_id export_id) + set.function_decls.funs + in + let closure_env = + Env.add_approx_maps env + [closures_approx; bound_vars_approx; specialised_args_approx] + in + let results = + let result_approx _var (function_decl : Flambda.function_declaration) = + approx_of_expr closure_env function_decl.body + in + Variable.Map.mapi result_approx set.function_decls.funs + in + { set_of_closures_id = set.function_decls.set_of_closures_id; + bound_vars = Var_within_closure.wrap_map bound_vars_approx; + free_vars = set.free_vars; + results = Closure_id.wrap_map results; + aliased_symbol = None; + } + +let approx_of_constant_defining_value_block_field env + (c : Flambda.constant_defining_value_block_field) : Export_info.approx = + match c with + | Symbol s -> + if Env.is_symbol_being_defined env s + then Value_unknown + else Value_symbol s + | Const c -> Value_id (Env.new_descr env (descr_of_constant c)) + +let describe_constant_defining_value env export_id symbol + ~symbols_being_defined (const : Flambda.constant_defining_value) = + let env = + (* Assignments of variables to export IDs are local to each constant + defining value. *) + Env.empty_of_global ~symbols_being_defined env + in + match const with + | Allocated_const alloc_const -> + let descr = descr_of_allocated_constant alloc_const in + Env.record_descr env export_id descr + | Block (tag, fields) -> + let approxs = + List.map (approx_of_constant_defining_value_block_field env) fields + in + Env.record_descr env export_id (Value_block (tag, Array.of_list approxs)) + | Set_of_closures set_of_closures -> + let descr : Export_info.descr = + Value_set_of_closures + { (describe_set_of_closures env set_of_closures) with + aliased_symbol = Some symbol; + } + in + Env.record_descr env export_id descr + | Project_closure (sym, closure_id) -> + begin match Env.get_symbol_descr env sym with + | Some (Value_set_of_closures set_of_closures) -> + if not (Closure_id.Map.mem closure_id set_of_closures.results) then begin + Misc.fatal_errorf "Could not build export description for \ + [Project_closure] constant defining value: closure ID %a not in \ + set of closures" + Closure_id.print closure_id + end; + let descr = + Export_info.Value_closure + { closure_id = closure_id; set_of_closures; } + in + Env.record_descr env export_id descr + | None -> + Misc.fatal_errorf + "Cannot project symbol %a to closure_id %a. \ + No available export description@." + Symbol.print sym + Closure_id.print closure_id + | Some (Value_closure _) -> + Misc.fatal_errorf + "Cannot project symbol %a to closure_id %a. \ + The symbol is a closure instead of a set of closures.@." + Symbol.print sym + Closure_id.print closure_id + | Some _ -> + Misc.fatal_errorf + "Cannot project symbol %a to closure_id %a. \ + The symbol is not a set of closures.@." + Symbol.print sym + Closure_id.print closure_id + end + +let describe_program (env : Env.Global.t) (program : Flambda.program) = + let rec loop env (program : Flambda.program_body) = + match program with + | Let_symbol (symbol, constant_defining_value, program) -> + let id, env = Env.Global.new_symbol env symbol in + describe_constant_defining_value env id symbol + ~symbols_being_defined:(Symbol.Set.singleton symbol) + constant_defining_value; + loop env program + | Let_rec_symbol (defs, program) -> + let env, defs = + List.fold_left (fun (env, defs) (symbol, def) -> + let id, env = Env.Global.new_symbol env symbol in + env, ((id, symbol, def) :: defs)) + (env, []) defs + in + (* [Project_closure]s are separated to be handled last. They are the + only values that need a description for their argument. *) + let project_closures, other_constants = + List.partition (function + | _, _, Flambda.Project_closure _ -> true + | _ -> false) + defs + in + let symbols_being_defined = + Symbol.Set.of_list (List.map (fun (_, sym, _) -> sym) defs) + in + List.iter (fun (id, symbol, def) -> + describe_constant_defining_value env id symbol + ~symbols_being_defined def) + other_constants; + List.iter (fun (id, symbol, def) -> + describe_constant_defining_value env id symbol + ~symbols_being_defined def) + project_closures; + loop env program + | Initialize_symbol (symbol, tag, fields, program) -> + let id = + let env = + (* Assignments of variables to export IDs are local to each + [Initialize_symbol] construction. *) + Env.empty_of_global + ~symbols_being_defined:(Symbol.Set.singleton symbol) env + in + let field_approxs = List.map (approx_of_expr env) fields in + let descr : Export_info.descr = + Value_block (tag, Array.of_list field_approxs) + in + Env.new_descr env descr + in + let env = Env.Global.add_symbol env symbol id in + loop env program + | Effect (_expr, program) -> loop env program + | End symbol -> symbol, env + in + loop env program.program_body + + +let build_transient ~(backend : (module Backend_intf.S)) + (program : Flambda.program) : Export_info.transient = + if !Clflags.opaque then + let compilation_unit = Compilenv.current_unit () in + let root_symbol = Compilenv.current_unit_symbol () in + Export_info.opaque_transient ~root_symbol ~compilation_unit + else + (* CR-soon pchambart: Should probably use that instead of the ident of + the module as global identifier. + mshinwell: Is "that" the variable "_global_symbol"? + Yes it is. We are just assuming that the symbol produced from + the identifier of the module is the right one. *) + let _global_symbol, env = + describe_program (Env.Global.create_empty ()) program + in + let sets_of_closures_map = + Flambda_utils.all_sets_of_closures_map program + in + let function_declarations_map = + let set_of_closures_approx { Flambda. function_decls; _ } = + let recursive = + lazy + (Find_recursive_functions.in_function_declarations + function_decls ~backend) + in + let keep_body = + Inline_and_simplify_aux.keep_body_check + ~is_classic_mode:function_decls.is_classic_mode ~recursive + in + Simple_value_approx.function_declarations_approx + ~keep_body function_decls + in + Set_of_closures_id.Map.map set_of_closures_approx sets_of_closures_map + in + let unnested_values = + Env.Global.export_id_to_descr_map env + in + let invariant_params = + let invariant_params = + Set_of_closures_id.Map.map + (fun { Flambda. function_decls; _ } -> + if function_decls.is_classic_mode then begin + Variable.Map.empty + end else begin + Invariant_params.invariant_params_in_recursion + ~backend function_decls + end) + (Flambda_utils.all_sets_of_closures_map program) + in + let export = Compilenv.approx_env () in + Export_id.Map.fold + (fun _eid (descr:Export_info.descr) invariant_params -> + match (descr : Export_info.descr) with + | Value_closure { set_of_closures } + | Value_set_of_closures set_of_closures -> + let { Export_info.set_of_closures_id } = set_of_closures in + begin match + Set_of_closures_id.Map.find set_of_closures_id + export.invariant_params + with + | exception Not_found -> + invariant_params + | (set : Variable.Set.t Variable.Map.t) -> + Set_of_closures_id.Map.add + set_of_closures_id set invariant_params + end + | Export_info.Value_boxed_int (_, _) + | Value_block _ + | Value_mutable_block _ + | Value_int _ + | Value_char _ + | Value_constptr _ + | Value_float _ + | Value_float_array _ + | Value_string _ + | Value_unknown_descr -> + invariant_params) + unnested_values invariant_params + in + let recursive = + let recursive = + Set_of_closures_id.Map.map + (fun { Flambda. function_decls; _ } -> + if function_decls.is_classic_mode then begin + Variable.Set.empty + end else begin + Find_recursive_functions.in_function_declarations + ~backend function_decls + end) + (Flambda_utils.all_sets_of_closures_map program) + in + let export = Compilenv.approx_env () in + Export_id.Map.fold + (fun _eid (descr:Export_info.descr) recursive -> + match (descr : Export_info.descr) with + | Value_closure { set_of_closures } + | Value_set_of_closures set_of_closures -> + let { Export_info.set_of_closures_id } = set_of_closures in + begin match + Set_of_closures_id.Map.find set_of_closures_id + export.recursive + with + | exception Not_found -> + recursive + | (set : Variable.Set.t) -> + Set_of_closures_id.Map.add + set_of_closures_id set recursive + end + | Export_info.Value_boxed_int (_, _) + | Value_block _ + | Value_mutable_block _ + | Value_int _ + | Value_char _ + | Value_constptr _ + | Value_float _ + | Value_float_array _ + | Value_string _ + | Value_unknown_descr -> + recursive) + unnested_values recursive + in + let values = Export_info.nest_eid_map unnested_values in + let symbol_id = Env.Global.symbol_to_export_id_map env in + let { Traverse_for_exported_symbols. + set_of_closure_ids = relevant_set_of_closures; + symbols = relevant_symbols; + export_ids = relevant_export_ids; + set_of_closure_ids_keep_declaration = + relevant_set_of_closures_declaration_only; + relevant_local_closure_ids; + relevant_imported_closure_ids; + relevant_local_vars_within_closure; + relevant_imported_vars_within_closure; + } = + let closure_id_to_set_of_closures_id = + Set_of_closures_id.Map.fold + (fun set_of_closure_id + (function_declarations : Simple_value_approx.function_declarations) + acc -> + Variable.Map.fold + (fun fun_var _ acc -> + let closure_id = Closure_id.wrap fun_var in + Closure_id.Map.add closure_id set_of_closure_id acc) + function_declarations.funs + acc) + function_declarations_map + Closure_id.Map.empty + in + Traverse_for_exported_symbols.traverse + ~sets_of_closures_map + ~closure_id_to_set_of_closures_id + ~function_declarations_map + ~values:(Compilation_unit.Map.find (Compilenv.current_unit ()) values) + ~symbol_id + ~root_symbol:(Compilenv.current_unit_symbol ()) + in + let sets_of_closures = + Set_of_closures_id.Map.filter_map + function_declarations_map + ~f:(fun key (fun_decls : Simple_value_approx.function_declarations) -> + if Set_of_closures_id.Set.mem key relevant_set_of_closures then + Some fun_decls + else if begin + Set_of_closures_id.Set.mem key + relevant_set_of_closures_declaration_only + end then begin + if fun_decls.is_classic_mode then + Some (Simple_value_approx.clear_function_bodies fun_decls) + else + Some fun_decls + end else begin + None + end) + in + + let values = + Compilation_unit.Map.map (fun map -> + Export_id.Map.filter (fun key _ -> + Export_id.Set.mem key relevant_export_ids) + map) + values + in + let symbol_id = + Symbol.Map.filter + (fun key _ -> Symbol.Set.mem key relevant_symbols) + symbol_id + in + Export_info.create_transient ~values + ~symbol_id + ~sets_of_closures + ~invariant_params + ~recursive + ~relevant_local_closure_ids + ~relevant_imported_closure_ids + ~relevant_local_vars_within_closure + ~relevant_imported_vars_within_closure diff --git a/middle_end/flambda/build_export_info.mli b/middle_end/flambda/build_export_info.mli new file mode 100644 index 00000000..0380604b --- /dev/null +++ b/middle_end/flambda/build_export_info.mli @@ -0,0 +1,25 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Construct export information, for emission into .cmx files, from an + Flambda program. *) + +val build_transient : + backend:(module Backend_intf.S) -> + Flambda.program -> + Export_info.transient diff --git a/middle_end/flambda/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml new file mode 100644 index 00000000..9bdd30ea --- /dev/null +++ b/middle_end/flambda/closure_conversion.ml @@ -0,0 +1,737 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module Env = Closure_conversion_aux.Env +module Function_decls = Closure_conversion_aux.Function_decls +module Function_decl = Function_decls.Function_decl +module Names = Internal_variable_names + +let name_expr = Flambda_utils.name_expr +let name_expr_from_var = Flambda_utils.name_expr_from_var + +type t = { + current_unit_id : Ident.t; + symbol_for_global' : (Ident.t -> Symbol.t); + filename : string; + backend : (module Backend_intf.S); + mutable imported_symbols : Symbol.Set.t; + mutable declared_symbols : (Symbol.t * Flambda.constant_defining_value) list; +} + +let add_default_argument_wrappers lam = + let defs_are_all_functions (defs : (_ * Lambda.lambda) list) = + List.for_all (function (_, Lambda.Lfunction _) -> true | _ -> false) defs + in + let f (lam : Lambda.lambda) : Lambda.lambda = + match lam with + | Llet (( Strict | Alias | StrictOpt), _k, id, + Lfunction {kind; params; body = fbody; attr; loc}, body) -> + begin match + Simplif.split_default_wrapper ~id ~kind ~params + ~body:fbody ~return:Pgenval ~attr ~loc + with + | [fun_id, def] -> Llet (Alias, Pgenval, fun_id, def, body) + | [fun_id, def; inner_fun_id, def_inner] -> + Llet (Alias, Pgenval, inner_fun_id, def_inner, + Llet (Alias, Pgenval, fun_id, def, body)) + | _ -> assert false + end + | Lletrec (defs, body) as lam -> + if defs_are_all_functions defs then + let defs = + List.flatten + (List.map + (function + | (id, Lambda.Lfunction {kind; params; body; attr; loc}) -> + Simplif.split_default_wrapper ~id ~kind ~params ~body + ~return:Pgenval ~attr ~loc + | _ -> assert false) + defs) + in + Lletrec (defs, body) + else lam + | lam -> lam + in + Lambda.map f lam + +(** Generate a wrapper ("stub") function that accepts a tuple argument and + calls another function with arguments extracted in the obvious + manner from the tuple. *) +let tupled_function_call_stub original_params unboxed_version ~closure_bound_var + : Flambda.function_declaration = + let tuple_param_var = Variable.rename unboxed_version in + let params = List.map (fun p -> Variable.rename p) original_params in + let call : Flambda.t = + Apply ({ + func = unboxed_version; + args = params; + (* CR-someday mshinwell for mshinwell: investigate if there is some + redundancy here (func is also unboxed_version) *) + kind = Direct (Closure_id.wrap unboxed_version); + dbg = Debuginfo.none; + inline = Default_inline; + specialise = Default_specialise; + }) + in + let _, body = + List.fold_left (fun (pos, body) param -> + let lam : Flambda.named = + Prim (Pfield pos, [tuple_param_var], Debuginfo.none) + in + pos + 1, Flambda.create_let param lam body) + (0, call) params + in + let tuple_param = Parameter.wrap tuple_param_var in + Flambda.create_function_declaration ~params:[tuple_param] + ~body ~stub:true ~dbg:Debuginfo.none ~inline:Default_inline + ~specialise:Default_specialise ~is_a_functor:false + ~closure_origin:(Closure_origin.create (Closure_id.wrap closure_bound_var)) + +let register_const t (constant:Flambda.constant_defining_value) name + : Flambda.constant_defining_value_block_field * Internal_variable_names.t = + let var = Variable.create name in + let symbol = Symbol.of_variable var in + t.declared_symbols <- (symbol, constant) :: t.declared_symbols; + Symbol symbol, name + +let rec declare_const t (const : Lambda.structured_constant) + : Flambda.constant_defining_value_block_field * Internal_variable_names.t = + match const with + | Const_base (Const_int c) -> (Const (Int c), Names.const_int) + | Const_base (Const_char c) -> (Const (Char c), Names.const_char) + | Const_base (Const_string (s, _)) -> + let const, name = + if Config.safe_string then + (Flambda.Allocated_const (Immutable_string s), + Names.const_immstring) + else + (Flambda.Allocated_const (String s), + Names.const_string) + in + register_const t const name + | Const_base (Const_float c) -> + register_const t + (Allocated_const (Float (float_of_string c))) + Names.const_float + | Const_base (Const_int32 c) -> + register_const t (Allocated_const (Int32 c)) + Names.const_int32 + | Const_base (Const_int64 c) -> + register_const t (Allocated_const (Int64 c)) + Names.const_int64 + | Const_base (Const_nativeint c) -> + register_const t (Allocated_const (Nativeint c)) Names.const_nativeint + | Const_pointer c -> Const (Const_pointer c), Names.const_ptr + | Const_immstring c -> + register_const t (Allocated_const (Immutable_string c)) + Names.const_immstring + | Const_float_array c -> + register_const t + (Allocated_const (Immutable_float_array (List.map float_of_string c))) + Names.const_float_array + | Const_block (tag, consts) -> + let const : Flambda.constant_defining_value = + Block (Tag.create_exn tag, + List.map (fun c -> fst (declare_const t c)) consts) + in + register_const t const Names.const_block + +let close_const t (const : Lambda.structured_constant) + : Flambda.named * Internal_variable_names.t = + match declare_const t const with + | Const c, name -> + Const c, name + | Symbol s, name -> + Symbol s, name + +let lambda_const_bool b : Lambda.structured_constant = + if b then + Const_pointer 1 + else + Const_pointer 0 + +let lambda_const_int i : Lambda.structured_constant = + Const_base (Const_int i) + +let rec close t env (lam : Lambda.lambda) : Flambda.t = + match lam with + | Lvar id -> + begin match Env.find_var_exn env id with + | var -> Var var + | exception Not_found -> + match Env.find_mutable_var_exn env id with + | mut_var -> + name_expr (Read_mutable mut_var) ~name:Names.read_mutable + | exception Not_found -> + Misc.fatal_errorf "Closure_conversion.close: unbound identifier %a" + Ident.print id + end + | Lconst cst -> + let cst, name = close_const t cst in + name_expr cst ~name + | Llet ((Strict | Alias | StrictOpt), _value_kind, id, defining_expr, body) -> + (* TODO: keep value_kind in flambda *) + let var = Variable.create_with_same_name_as_ident id in + let defining_expr = + close_let_bound_expression t var env defining_expr + in + let body = close t (Env.add_var env id var) body in + Flambda.create_let var defining_expr body + | Llet (Variable, block_kind, id, defining_expr, body) -> + let mut_var = Mutable_variable.create_with_same_name_as_ident id in + let var = Variable.create_with_same_name_as_ident id in + let defining_expr = + close_let_bound_expression t var env defining_expr + in + let body = close t (Env.add_mutable_var env id mut_var) body in + Flambda.create_let var defining_expr + (Let_mutable + { var = mut_var; + initial_value = var; + body; + contents_kind = block_kind }) + | Lfunction { kind; params; body; attr; loc; } -> + let name = Names.anon_fn_with_loc loc in + let closure_bound_var = Variable.create name in + (* CR-soon mshinwell: some of this is now very similar to the let rec case + below *) + let set_of_closures_var = Variable.create Names.set_of_closures in + let set_of_closures = + let decl = + Function_decl.create ~let_rec_ident:None ~closure_bound_var ~kind + ~params:(List.map fst params) ~body ~attr ~loc + in + close_functions t env (Function_decls.create [decl]) + in + let project_closure : Flambda.project_closure = + { set_of_closures = set_of_closures_var; + closure_id = Closure_id.wrap closure_bound_var; + } + in + Flambda.create_let set_of_closures_var set_of_closures + (name_expr (Project_closure (project_closure)) ~name) + | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall = _; + ap_inlined; ap_specialised; } -> + Lift_code.lifting_helper (close_list t env ap_args) + ~evaluation_order:`Right_to_left + ~name:Names.apply_arg + ~create_body:(fun args -> + let func = close t env ap_func in + let func_var = Variable.create Names.apply_funct in + Flambda.create_let func_var (Expr func) + (Apply ({ + func = func_var; + args; + kind = Indirect; + dbg = Debuginfo.from_location ap_loc; + inline = ap_inlined; + specialise = ap_specialised; + }))) + | Lletrec (defs, body) -> + let env = + List.fold_right (fun (id, _) env -> + Env.add_var env id (Variable.create_with_same_name_as_ident id)) + defs env + in + let function_declarations = + (* Identify any bindings in the [let rec] that are functions. These + will be named after the corresponding identifier in the [let rec]. *) + List.map (function + | (let_rec_ident, + Lambda.Lfunction { kind; params; body; attr; loc }) -> + let closure_bound_var = + Variable.create_with_same_name_as_ident let_rec_ident + in + let function_declaration = + Function_decl.create ~let_rec_ident:(Some let_rec_ident) + ~closure_bound_var ~kind ~params:(List.map fst params) ~body + ~attr ~loc + in + Some function_declaration + | _ -> None) + defs + in + begin match + Misc.Stdlib.List.some_if_all_elements_are_some function_declarations + with + | Some function_declarations -> + (* When all the bindings are (syntactically) functions, we can + eliminate the [let rec] construction, instead producing a normal + [Let] that binds a set of closures containing all of the functions. + *) + (* CR-someday lwhite: This is a very syntactic criteria. Adding an + unused value to a set of recursive bindings changes how + functions are represented at runtime. *) + let set_of_closures_var = Variable.create (Names.set_of_closures) in + let set_of_closures = + close_functions t env (Function_decls.create function_declarations) + in + let body = + List.fold_left (fun body decl -> + let let_rec_ident = Function_decl.let_rec_ident decl in + let closure_bound_var = Function_decl.closure_bound_var decl in + let let_bound_var = Env.find_var env let_rec_ident in + (* Inside the body of the [let], each function is referred to by + a [Project_closure] expression, which projects from the set of + closures. *) + (Flambda.create_let let_bound_var + (Project_closure { + set_of_closures = set_of_closures_var; + closure_id = Closure_id.wrap closure_bound_var; + }) + body)) + (close t env body) function_declarations + in + Flambda.create_let set_of_closures_var set_of_closures body + | None -> + (* If the condition above is not satisfied, we build a [Let_rec] + expression; any functions bound by it will have their own + individual closures. *) + let defs = + List.map (fun (id, def) -> + let var = Env.find_var env id in + var, close_let_bound_expression t ~let_rec_ident:id var env def) + defs + in + Let_rec (defs, close t env body) + end + | Lsend (kind, meth, obj, args, loc) -> + let meth_var = Variable.create Names.meth in + let obj_var = Variable.create Names.obj in + let dbg = Debuginfo.from_location loc in + Flambda.create_let meth_var (Expr (close t env meth)) + (Flambda.create_let obj_var (Expr (close t env obj)) + (Lift_code.lifting_helper (close_list t env args) + ~evaluation_order:`Right_to_left + ~name:Names.send_arg + ~create_body:(fun args -> + Send { kind; meth = meth_var; obj = obj_var; args; dbg; }))) + | Lprim ((Pdivint Safe | Pmodint Safe + | Pdivbint { is_safe = Safe } | Pmodbint { is_safe = Safe }) as prim, + [arg1; arg2], loc) + when not !Clflags.unsafe -> + let arg2 = close t env arg2 in + let arg1 = close t env arg1 in + let numerator = Variable.create Names.numerator in + let denominator = Variable.create Names.denominator in + let zero = Variable.create Names.zero in + let is_zero = Variable.create Names.is_zero in + let exn = Variable.create Names.division_by_zero in + let exn_symbol = + t.symbol_for_global' Predef.ident_division_by_zero + in + let dbg = Debuginfo.from_location loc in + let zero_const : Flambda.named = + match prim with + | Pdivint _ | Pmodint _ -> + Const (Int 0) + | Pdivbint { size = Pint32 } | Pmodbint { size = Pint32 } -> + Allocated_const (Int32 0l) + | Pdivbint { size = Pint64 } | Pmodbint { size = Pint64 } -> + Allocated_const (Int64 0L) + | Pdivbint { size = Pnativeint } | Pmodbint { size = Pnativeint } -> + Allocated_const (Nativeint 0n) + | _ -> assert false + in + let prim : Clambda_primitives.primitive = + match prim with + | Pdivint _ -> Pdivint Unsafe + | Pmodint _ -> Pmodint Unsafe + | Pdivbint { size } -> Pdivbint { size; is_safe = Unsafe } + | Pmodbint { size } -> Pmodbint { size; is_safe = Unsafe } + | _ -> assert false + in + let comparison : Clambda_primitives.primitive = + match prim with + | Pdivint _ | Pmodint _ -> Pintcomp Ceq + | Pdivbint { size } | Pmodbint { size } -> Pbintcomp (size,Ceq) + | _ -> assert false + in + t.imported_symbols <- Symbol.Set.add exn_symbol t.imported_symbols; + Flambda.create_let zero zero_const + (Flambda.create_let exn (Symbol exn_symbol) + (Flambda.create_let denominator (Expr arg2) + (Flambda.create_let numerator (Expr arg1) + (Flambda.create_let is_zero + (Prim (comparison, [zero; denominator], dbg)) + (If_then_else (is_zero, + name_expr (Prim (Praise Raise_regular, [exn], dbg)) + ~name:Names.dummy, + (* CR-someday pchambart: find the right event. + mshinwell: I briefly looked at this, and couldn't + figure it out. + lwhite: I don't think any of the existing events + are suitable. I had to add a new one for a similar + case in the array data types work. + mshinwell: deferred CR *) + name_expr ~name:Names.result + (Prim (prim, [numerator; denominator], dbg)))))))) + | Lprim ((Pdivint Safe | Pmodint Safe + | Pdivbint { is_safe = Safe } | Pmodbint { is_safe = Safe }), _, _) + when not !Clflags.unsafe -> + Misc.fatal_error "Pdivint / Pmodint must have exactly two arguments" + | Lprim (Psequor, [arg1; arg2], _) -> + let arg1 = close t env arg1 in + let arg2 = close t env arg2 in + let const_true = Variable.create Names.const_true in + let cond = Variable.create Names.cond_sequor in + Flambda.create_let const_true (Const (Const_pointer 1)) + (Flambda.create_let cond (Expr arg1) + (If_then_else (cond, Var const_true, arg2))) + | Lprim (Psequand, [arg1; arg2], _) -> + let arg1 = close t env arg1 in + let arg2 = close t env arg2 in + let const_false = Variable.create Names.const_false in + let cond = Variable.create Names.const_sequand in + Flambda.create_let const_false (Const (Const_pointer 0)) + (Flambda.create_let cond (Expr arg1) + (If_then_else (cond, arg2, Var const_false))) + | Lprim ((Psequand | Psequor), _, _) -> + Misc.fatal_error "Psequand / Psequor must have exactly two arguments" + | Lprim ((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _) -> + close t env arg + | Lprim (Pignore, [arg], _) -> + let var = Variable.create Names.ignore in + let defining_expr = + close_let_bound_expression t var env arg + in + Flambda.create_let var defining_expr + (name_expr (Const (Const_pointer 0)) ~name:Names.unit) + | Lprim (Pdirapply, [funct; arg], loc) + | Lprim (Prevapply, [arg; funct], loc) -> + let apply : Lambda.lambda_apply = + { ap_func = funct; + ap_args = [arg]; + ap_loc = loc; + ap_should_be_tailcall = false; + (* CR-someday lwhite: it would be nice to be able to give + inlined attributes to functions applied with the application + operators. *) + ap_inlined = Default_inline; + ap_specialised = Default_specialise; + } + in + close t env (Lambda.Lapply apply) + | Lprim (Praise kind, [arg], loc) -> + let arg_var = Variable.create Names.raise_arg in + let dbg = Debuginfo.from_location loc in + Flambda.create_let arg_var (Expr (close t env arg)) + (name_expr + (Prim (Praise kind, [arg_var], dbg)) + ~name:Names.raise) + | Lprim (Pctconst c, [arg], _loc) -> + let module Backend = (val t.backend) in + let const = + begin match c with + | Big_endian -> lambda_const_bool Backend.big_endian + | Word_size -> lambda_const_int (8*Backend.size_int) + | Int_size -> lambda_const_int (8*Backend.size_int - 1) + | Max_wosize -> + lambda_const_int ((1 lsl ((8*Backend.size_int) - 10)) - 1) + | Ostype_unix -> lambda_const_bool (String.equal Sys.os_type "Unix") + | Ostype_win32 -> lambda_const_bool (String.equal Sys.os_type "Win32") + | Ostype_cygwin -> lambda_const_bool (String.equal Sys.os_type "Cygwin") + | Backend_type -> + Lambda.Const_pointer 0 (* tag 0 is the same as Native *) + end + in + close t env + (Lambda.Llet(Strict, Pgenval, Ident.create_local "dummy", + arg, Lconst const)) + | Lprim (Pfield _, [Lprim (Pgetglobal id, [],_)], _) + when Ident.same id t.current_unit_id -> + Misc.fatal_errorf "[Pfield (Pgetglobal ...)] for the current compilation \ + unit is forbidden upon entry to the middle end" + | Lprim (Psetfield (_, _, _), [Lprim (Pgetglobal _, [], _); _], _) -> + Misc.fatal_errorf "[Psetfield (Pgetglobal ...)] is \ + forbidden upon entry to the middle end" + | Lprim (Pgetglobal id, [], _) when Ident.is_predef id -> + let symbol = t.symbol_for_global' id in + t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols; + name_expr (Symbol symbol) ~name:Names.predef_exn + | Lprim (Pgetglobal id, [], _) -> + assert (not (Ident.same id t.current_unit_id)); + let symbol = t.symbol_for_global' id in + t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols; + name_expr (Symbol symbol) ~name:Names.pgetglobal + | Lprim (lambda_p, args, loc) -> + (* One of the important consequences of the ANF-like representation + here is that we obtain names corresponding to the components of + blocks being made (with [Pmakeblock]). This information can be used + by the simplification pass to increase the likelihood of eliminating + the allocation, since some field accesses can be tracked back to known + field values. *) + let dbg = Debuginfo.from_location loc in + let p = Convert_primitives.convert lambda_p in + Lift_code.lifting_helper (close_list t env args) + ~evaluation_order:`Right_to_left + ~name:(Names.of_primitive_arg lambda_p) + ~create_body:(fun args -> + name_expr (Prim (p, args, dbg)) + ~name:(Names.of_primitive lambda_p)) + | Lswitch (arg, sw, _loc) -> + let scrutinee = Variable.create Names.switch in + let aux (i, lam) = i, close t env lam in + let nums sw_num cases default = + let module I = Numbers.Int in + match default with + | Some _ -> + I.zero_to_n (sw_num - 1) + | None -> + List.fold_left (fun set (i, _) -> I.Set.add i set) I.Set.empty cases + in + Flambda.create_let scrutinee (Expr (close t env arg)) + (Switch (scrutinee, + { numconsts = nums sw.sw_numconsts sw.sw_consts sw.sw_failaction; + consts = List.map aux sw.sw_consts; + numblocks = nums sw.sw_numblocks sw.sw_blocks sw.sw_failaction; + blocks = List.map aux sw.sw_blocks; + failaction = Misc.may_map (close t env) sw.sw_failaction; + })) + | Lstringswitch (arg, sw, def, _) -> + let scrutinee = Variable.create Names.string_switch in + Flambda.create_let scrutinee (Expr (close t env arg)) + (String_switch (scrutinee, + List.map (fun (s, e) -> s, close t env e) sw, + Misc.may_map (close t env) def)) + | Lstaticraise (i, args) -> + Lift_code.lifting_helper (close_list t env args) + ~evaluation_order:`Right_to_left + ~name:Names.staticraise_arg + ~create_body:(fun args -> + let static_exn = Env.find_static_exception env i in + Static_raise (static_exn, args)) + | Lstaticcatch (body, (i, ids), handler) -> + let st_exn = Static_exception.create () in + let env = Env.add_static_exception env i st_exn in + let ids = List.map fst ids in + let vars = List.map Variable.create_with_same_name_as_ident ids in + Static_catch (st_exn, vars, close t env body, + close t (Env.add_vars env ids vars) handler) + | Ltrywith (body, id, handler) -> + let var = Variable.create_with_same_name_as_ident id in + Try_with (close t env body, var, close t (Env.add_var env id var) handler) + | Lifthenelse (cond, ifso, ifnot) -> + let cond = close t env cond in + let cond_var = Variable.create Names.cond in + Flambda.create_let cond_var (Expr cond) + (If_then_else (cond_var, close t env ifso, close t env ifnot)) + | Lsequence (lam1, lam2) -> + let var = Variable.create Names.sequence in + let lam1 = Flambda.Expr (close t env lam1) in + let lam2 = close t env lam2 in + Flambda.create_let var lam1 lam2 + | Lwhile (cond, body) -> While (close t env cond, close t env body) + | Lfor (id, lo, hi, direction, body) -> + let bound_var = Variable.create_with_same_name_as_ident id in + let from_value = Variable.create Names.for_from in + let to_value = Variable.create Names.for_to in + let body = close t (Env.add_var env id bound_var) body in + Flambda.create_let from_value (Expr (close t env lo)) + (Flambda.create_let to_value (Expr (close t env hi)) + (For { bound_var; from_value; to_value; direction; body; })) + | Lassign (id, new_value) -> + let being_assigned = + match Env.find_mutable_var_exn env id with + | being_assigned -> being_assigned + | exception Not_found -> + Misc.fatal_errorf "Closure_conversion.close: unbound mutable \ + variable %s in assignment" + (Ident.unique_name id) + in + let new_value_var = Variable.create Names.new_value in + Flambda.create_let new_value_var (Expr (close t env new_value)) + (Assign { being_assigned; new_value = new_value_var; }) + | Levent (lam, _) -> close t env lam + | Lifused _ -> + (* [Lifused] is used to mark that this expression should be alive only if + an identifier is. Every use should have been removed by + [Simplif.simplify_lets], either by replacing by the inner expression, + or by completely removing it (replacing by unit). *) + Misc.fatal_error "[Lifused] should have been removed by \ + [Simplif.simplify_lets]" + +(** Perform closure conversion on a set of function declarations, returning a + set of closures. (The set will often only contain a single function; + the only case where it cannot is for "let rec".) *) +and close_functions t external_env function_declarations : Flambda.named = + let closure_env_without_parameters = + Function_decls.closure_env_without_parameters + external_env function_declarations + in + let all_free_idents = Function_decls.all_free_idents function_declarations in + let close_one_function map decl = + let body = Function_decl.body decl in + let loc = Function_decl.loc decl in + let dbg = Debuginfo.from_location loc in + let params = Function_decl.params decl in + (* Create fresh variables for the elements of the closure (cf. + the comment on [Function_decl.closure_env_without_parameters], above). + This induces a renaming on [Function_decl.free_idents]; the results of + that renaming are stored in [free_variables]. *) + let closure_env = + List.fold_right (fun id env -> + Env.add_var env id (Variable.create_with_same_name_as_ident id)) + params closure_env_without_parameters + in + (* If the function is the wrapper for a function with an optional + argument with a default value, make sure it always gets inlined. + CR-someday pchambart: eta-expansion wrapper for a primitive are + not marked as stub but certainly should *) + let stub = Function_decl.stub decl in + let param_vars = List.map (Env.find_var closure_env) params in + let params = List.map Parameter.wrap param_vars in + let closure_bound_var = Function_decl.closure_bound_var decl in + let unboxed_version = Variable.rename closure_bound_var in + let body = close t closure_env body in + let closure_origin = + Closure_origin.create (Closure_id.wrap unboxed_version) + in + let fun_decl = + Flambda.create_function_declaration ~params ~body ~stub ~dbg + ~inline:(Function_decl.inline decl) + ~specialise:(Function_decl.specialise decl) + ~is_a_functor:(Function_decl.is_a_functor decl) + ~closure_origin + in + match Function_decl.kind decl with + | Curried -> Variable.Map.add closure_bound_var fun_decl map + | Tupled -> + let unboxed_version = Variable.rename closure_bound_var in + let generic_function_stub = + tupled_function_call_stub param_vars unboxed_version ~closure_bound_var + in + Variable.Map.add unboxed_version fun_decl + (Variable.Map.add closure_bound_var generic_function_stub map) + in + let function_decls = + let is_classic_mode = !Clflags.classic_inlining in + let funs = + List.fold_left close_one_function Variable.Map.empty + (Function_decls.to_list function_declarations) + in + Flambda.create_function_declarations ~is_classic_mode ~funs + in + (* The closed representation of a set of functions is a "set of closures". + (For avoidance of doubt, the runtime representation of the *whole set* is + a single block with tag [Closure_tag].) *) + let set_of_closures = + let free_vars = + Ident.Set.fold (fun var map -> + let internal_var = + Env.find_var closure_env_without_parameters var + in + let external_var : Flambda.specialised_to = + { var = Env.find_var external_env var; + projection = None; + } + in + Variable.Map.add internal_var external_var map) + all_free_idents Variable.Map.empty + in + Flambda.create_set_of_closures ~function_decls ~free_vars + ~specialised_args:Variable.Map.empty + ~direct_call_surrogates:Variable.Map.empty + in + Set_of_closures set_of_closures + +and close_list t sb l = List.map (close t sb) l + +and close_let_bound_expression t ?let_rec_ident let_bound_var env + (lam : Lambda.lambda) : Flambda.named = + match lam with + | Lfunction { kind; params; body; attr; loc; } -> + (* Ensure that [let] and [let rec]-bound functions have appropriate + names. *) + let closure_bound_var = Variable.rename let_bound_var in + let decl = + Function_decl.create ~let_rec_ident ~closure_bound_var ~kind + ~params:(List.map fst params) ~body ~attr ~loc + in + let set_of_closures_var = Variable.rename let_bound_var in + let set_of_closures = + close_functions t env (Function_decls.create [decl]) + in + let project_closure : Flambda.project_closure = + { set_of_closures = set_of_closures_var; + closure_id = Closure_id.wrap closure_bound_var; + } + in + Expr (Flambda.create_let set_of_closures_var set_of_closures + (name_expr_from_var (Project_closure (project_closure)) + ~var:let_bound_var)) + | lam -> Expr (close t env lam) + +let lambda_to_flambda ~backend ~module_ident ~size ~filename lam + : Flambda.program = + let lam = add_default_argument_wrappers lam in + let module Backend = (val backend : Backend_intf.S) in + let compilation_unit = Compilation_unit.get_current_exn () in + let t = + { current_unit_id = Compilation_unit.get_persistent_ident compilation_unit; + symbol_for_global' = Backend.symbol_for_global'; + filename; + backend; + imported_symbols = Symbol.Set.empty; + declared_symbols = []; + } + in + let module_symbol = Backend.symbol_for_global' module_ident in + let block_symbol = + let var = Variable.create Internal_variable_names.module_as_block in + Symbol.of_variable var + in + (* The global module block is built by accessing the fields of all the + introduced symbols. *) + (* CR-soon mshinwell for mshinwell: Add a comment describing how modules are + compiled. *) + let fields = + Array.init size (fun pos -> + let sym_v = Variable.create Names.block_symbol in + let result_v = Variable.create Names.block_symbol_get in + let value_v = Variable.create Names.block_symbol_get_field in + Flambda.create_let + sym_v (Symbol block_symbol) + (Flambda.create_let result_v + (Prim (Pfield 0, [sym_v], Debuginfo.none)) + (Flambda.create_let value_v + (Prim (Pfield pos, [result_v], Debuginfo.none)) + (Var value_v)))) + in + let module_initializer : Flambda.program_body = + Initialize_symbol ( + block_symbol, + Tag.create_exn 0, + [close t Env.empty lam], + Initialize_symbol ( + module_symbol, + Tag.create_exn 0, + Array.to_list fields, + End module_symbol)) + in + let program_body = + List.fold_left + (fun program_body (symbol, constant) : Flambda.program_body -> + Let_symbol (symbol, constant, program_body)) + module_initializer + t.declared_symbols + in + { imported_symbols = t.imported_symbols; + program_body; + } diff --git a/middle_end/flambda/closure_conversion.mli b/middle_end/flambda/closure_conversion.mli new file mode 100644 index 00000000..f5fab0a7 --- /dev/null +++ b/middle_end/flambda/closure_conversion.mli @@ -0,0 +1,53 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Generation of [Flambda] intermediate language code from [Lambda] code + by performing a form of closure conversion. + + Function declarations (which may bind one or more variables identifying + functions, possibly with mutual recursion) are transformed to + [Set_of_closures] expressions. [Project_closure] expressions are then + used to select a closure for a particular function from a [Set_of_closures] + expression. The [Set_of_closures] expressions say nothing about the + actual runtime layout of the closures; this is handled when [Flambda] code + is translated to [Clambda] code. + + The following transformations are also performed during closure + conversion: + - Constant blocks (by which is meant things wrapped in [Lambda.Const_block]) + are converted to applications of the [Pmakeblock] primitive. + - [Levent] debugging event nodes are removed and the information within + them attached to function, method and [raise] calls. + - Tuplified functions are converted to curried functions and a stub + function emitted to call the curried version. For example: + let rec f (x, y) = f (x + 1, y + 1) + is transformed to: + let rec internal_f x y = f (x + 1,y + 1) + and f (x, y) = internal_f x y (* [f] is marked as a stub function *) + - The [Pdirapply] and [Prevapply] application primitives are removed and + converted to normal [Flambda] application nodes. + + The [lambda_to_flambda] function is not re-entrant. +*) +val lambda_to_flambda + : backend:(module Backend_intf.S) + -> module_ident:Ident.t + -> size:int + -> filename:string + -> Lambda.lambda + -> Flambda.program diff --git a/middle_end/flambda/closure_conversion_aux.ml b/middle_end/flambda/closure_conversion_aux.ml new file mode 100644 index 00000000..cfcaf34d --- /dev/null +++ b/middle_end/flambda/closure_conversion_aux.ml @@ -0,0 +1,184 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module Env = struct + type t = { + variables : Variable.t Ident.tbl; + mutable_variables : Mutable_variable.t Ident.tbl; + static_exceptions : Static_exception.t Numbers.Int.Map.t; + globals : Symbol.t Numbers.Int.Map.t; + at_toplevel : bool; + } + + let empty = { + variables = Ident.empty; + mutable_variables = Ident.empty; + static_exceptions = Numbers.Int.Map.empty; + globals = Numbers.Int.Map.empty; + at_toplevel = true; + } + + let clear_local_bindings env = + { empty with globals = env.globals } + + let add_var t id var = { t with variables = Ident.add id var t.variables } + let add_vars t ids vars = List.fold_left2 add_var t ids vars + + let find_var t id = + try Ident.find_same id t.variables + with Not_found -> + Misc.fatal_errorf "Closure_conversion.Env.find_var: %s@ %s" + (Ident.unique_name id) + (Printexc.raw_backtrace_to_string (Printexc.get_callstack 42)) + + let find_var_exn t id = + Ident.find_same id t.variables + + let add_mutable_var t id mutable_var = + { t with mutable_variables = Ident.add id mutable_var t.mutable_variables } + + let find_mutable_var_exn t id = + Ident.find_same id t.mutable_variables + + let add_static_exception t st_exn fresh_st_exn = + { t with + static_exceptions = + Numbers.Int.Map.add st_exn fresh_st_exn t.static_exceptions } + + let find_static_exception t st_exn = + try Numbers.Int.Map.find st_exn t.static_exceptions + with Not_found -> + Misc.fatal_error ("Closure_conversion.Env.find_static_exception: exn " + ^ Int.to_string st_exn) + + let add_global t pos symbol = + { t with globals = Numbers.Int.Map.add pos symbol t.globals } + + let find_global t pos = + try Numbers.Int.Map.find pos t.globals + with Not_found -> + Misc.fatal_error ("Closure_conversion.Env.find_global: global " + ^ Int.to_string pos) + + let at_toplevel t = t.at_toplevel + + let not_at_toplevel t = { t with at_toplevel = false; } +end + +module Function_decls = struct + module Function_decl = struct + type t = { + let_rec_ident : Ident.t; + closure_bound_var : Variable.t; + kind : Lambda.function_kind; + params : Ident.t list; + body : Lambda.lambda; + free_idents_of_body : Ident.Set.t; + attr : Lambda.function_attribute; + loc : Location.t; + } + + let create ~let_rec_ident ~closure_bound_var ~kind ~params ~body + ~attr ~loc = + let let_rec_ident = + match let_rec_ident with + | None -> Ident.create_local "unnamed_function" + | Some let_rec_ident -> let_rec_ident + in + { let_rec_ident; + closure_bound_var; + kind; + params; + body; + free_idents_of_body = Lambda.free_variables body; + attr; + loc; + } + + let let_rec_ident t = t.let_rec_ident + let closure_bound_var t = t.closure_bound_var + let kind t = t.kind + let params t = t.params + let body t = t.body + let free_idents t = t.free_idents_of_body + let inline t = t.attr.inline + let specialise t = t.attr.specialise + let is_a_functor t = t.attr.is_a_functor + let stub t = t.attr.stub + let loc t = t.loc + + end + + type t = { + function_decls : Function_decl.t list; + all_free_idents : Ident.Set.t; + } + + (* All identifiers free in the bodies of the given function declarations, + indexed by the identifiers corresponding to the functions themselves. *) + let free_idents_by_function function_decls = + List.fold_right (fun decl map -> + Variable.Map.add (Function_decl.closure_bound_var decl) + (Function_decl.free_idents decl) map) + function_decls Variable.Map.empty + + let all_free_idents function_decls = + Variable.Map.fold (fun _ -> Ident.Set.union) + (free_idents_by_function function_decls) Ident.Set.empty + + (* All identifiers of simultaneously-defined functions in [ts]. *) + let let_rec_idents function_decls = + List.map Function_decl.let_rec_ident function_decls + + (* All parameters of functions in [ts]. *) + let all_params function_decls = + List.concat (List.map Function_decl.params function_decls) + + let set_diff (from : Ident.Set.t) (idents : Ident.t list) = + List.fold_right Ident.Set.remove idents from + + (* CR-someday lwhite: use a different name from above or explain the + difference *) + let all_free_idents function_decls = + set_diff (set_diff (all_free_idents function_decls) + (all_params function_decls)) + (let_rec_idents function_decls) + + let create function_decls = + { function_decls; + all_free_idents = all_free_idents function_decls; + } + + let to_list t = t.function_decls + + let all_free_idents t = t.all_free_idents + + let closure_env_without_parameters external_env t = + let closure_env = + (* For "let rec"-bound functions. *) + List.fold_right (fun function_decl env -> + Env.add_var env (Function_decl.let_rec_ident function_decl) + (Function_decl.closure_bound_var function_decl)) + t.function_decls (Env.clear_local_bindings external_env) + in + (* For free variables. *) + Ident.Set.fold (fun id env -> + Env.add_var env id (Variable.create_with_same_name_as_ident id)) + t.all_free_idents closure_env +end diff --git a/middle_end/flambda/closure_conversion_aux.mli b/middle_end/flambda/closure_conversion_aux.mli new file mode 100644 index 00000000..f16f05f0 --- /dev/null +++ b/middle_end/flambda/closure_conversion_aux.mli @@ -0,0 +1,94 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Environments and auxiliary structures used during closure conversion. *) + +(** Used to remember which [Variable.t] values correspond to which + [Ident.t] values during closure conversion, and similarly for + static exception identifiers. *) +module Env : sig + type t + + val empty : t + + val add_var : t -> Ident.t -> Variable.t -> t + val add_vars : t -> Ident.t list -> Variable.t list -> t + + val find_var : t -> Ident.t -> Variable.t + val find_var_exn : t -> Ident.t -> Variable.t + + val add_mutable_var : t -> Ident.t -> Mutable_variable.t -> t + val find_mutable_var_exn : t -> Ident.t -> Mutable_variable.t + + val add_static_exception : t -> int -> Static_exception.t -> t + val find_static_exception : t -> int -> Static_exception.t + + val add_global : t -> int -> Symbol.t -> t + val find_global : t -> int -> Symbol.t + + val at_toplevel : t -> bool + val not_at_toplevel : t -> t +end + +(** Used to represent information about a set of function declarations + during closure conversion. (The only case in which such a set may + contain more than one declaration is when processing "let rec".) *) +module Function_decls : sig + module Function_decl : sig + type t + + val create + : let_rec_ident:Ident.t option + -> closure_bound_var:Variable.t + -> kind:Lambda.function_kind + -> params:Ident.t list + -> body:Lambda.lambda + -> attr:Lambda.function_attribute + -> loc:Location.t + -> t + + val let_rec_ident : t -> Ident.t + val closure_bound_var : t -> Variable.t + val kind : t -> Lambda.function_kind + val params : t -> Ident.t list + val body : t -> Lambda.lambda + val inline : t -> Lambda.inline_attribute + val specialise : t -> Lambda.specialise_attribute + val is_a_functor : t -> bool + val stub : t -> bool + val loc : t -> Location.t + + (* Like [all_free_idents], but for just one function. *) + val free_idents : t -> Ident.Set.t + end + + type t + + val create : Function_decl.t list -> t + val to_list : t -> Function_decl.t list + + (* All identifiers free in the given function declarations after the binding + of parameters and function identifiers has been performed. *) + val all_free_idents : t -> Ident.Set.t + + (* A map from identifiers to their corresponding [Variable.t]s whose domain + is the set of all identifiers free in the bodies of the declarations that + are not bound as parameters. + It also contains the globals bindings of the provided environment. *) + val closure_env_without_parameters : Env.t -> t -> Env.t +end diff --git a/middle_end/flambda/closure_offsets.ml b/middle_end/flambda/closure_offsets.ml new file mode 100644 index 00000000..51a09f02 --- /dev/null +++ b/middle_end/flambda/closure_offsets.ml @@ -0,0 +1,89 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +type result = { + function_offsets : int Closure_id.Map.t; + free_variable_offsets : int Var_within_closure.Map.t; +} + +let add_closure_offsets + { function_offsets; free_variable_offsets } + ({ function_decls; free_vars } : Flambda.set_of_closures) = + (* Build the table mapping the functions declared by the set of closures + to the positions of their individual "infix" closures inside the runtime + closure block. (All of the environment entries will come afterwards.) *) + let assign_function_offset id function_decl (map, env_pos) = + let pos = env_pos + 1 in + let env_pos = + let arity = Flambda_utils.function_arity function_decl in + env_pos + + 1 (* GC header; either [Closure_tag] or [Infix_tag] *) + + 1 (* full application code pointer *) + + 1 (* arity *) + + (if arity > 1 then 1 else 0) (* partial application code pointer *) + in + let closure_id = Closure_id.wrap id in + if Closure_id.Map.mem closure_id map then begin + Misc.fatal_errorf "Closure_offsets.add_closure_offsets: function \ + offset for %a would be defined multiple times" + Closure_id.print closure_id + end; + let map = Closure_id.Map.add closure_id pos map in + (map, env_pos) + in + let function_offsets, free_variable_pos = + Variable.Map.fold assign_function_offset + function_decls.funs (function_offsets, -1) + in + (* Adds the mapping of free variables to their offset. Recall that + projections of [Var_within_closure]s are only currently used when + compiling accesses to the closure of a function from outside that + function (in particular, as a result of inlining). Accesses to + a function's own closure are compiled directly via normal [Var] + accesses. *) + (* CR-someday mshinwell: As discussed with lwhite, maybe this isn't + ideal, and the self accesses should be explicitly marked too. *) + let assign_free_variable_offset var _ (map, pos) = + let var_within_closure = Var_within_closure.wrap var in + if Var_within_closure.Map.mem var_within_closure map then begin + Misc.fatal_errorf "Closure_offsets.add_closure_offsets: free variable \ + offset for %a would be defined multiple times" + Var_within_closure.print var_within_closure + end; + let map = Var_within_closure.Map.add var_within_closure pos map in + (map, pos + 1) + in + let free_variable_offsets, _ = + Variable.Map.fold assign_free_variable_offset + free_vars (free_variable_offsets, free_variable_pos) + in + { function_offsets; + free_variable_offsets; + } + +let compute (program:Flambda.program) = + let init : result = + { function_offsets = Closure_id.Map.empty; + free_variable_offsets = Var_within_closure.Map.empty; + } + in + let r = + List.fold_left add_closure_offsets + init (Flambda_utils.all_sets_of_closures program) + in + r diff --git a/middle_end/flambda/closure_offsets.mli b/middle_end/flambda/closure_offsets.mli new file mode 100644 index 00000000..7ecf9c27 --- /dev/null +++ b/middle_end/flambda/closure_offsets.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Assign numerical offsets, within closure blocks, for code pointers and + environment entries. *) + +type result = private { + function_offsets : int Closure_id.Map.t; + free_variable_offsets : int Var_within_closure.Map.t; +} + +val compute : Flambda.program -> result diff --git a/middle_end/flambda/effect_analysis.ml b/middle_end/flambda/effect_analysis.ml new file mode 100644 index 00000000..d0cbd441 --- /dev/null +++ b/middle_end/flambda/effect_analysis.ml @@ -0,0 +1,60 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let no_effects_prim (prim : Clambda_primitives.primitive) = + match Semantics_of_primitives.for_primitive prim with + | (No_effects | Only_generative_effects), (No_coeffects | Has_coeffects) -> + true + | _ -> false + +let rec no_effects (flam : Flambda.t) = + match flam with + | Var _ -> true + | Let { defining_expr; body; _ } -> + no_effects_named defining_expr && no_effects body + | Let_mutable { body } -> no_effects body + | Let_rec (defs, body) -> + no_effects body + && List.for_all (fun (_, def) -> no_effects_named def) defs + | If_then_else (_, ifso, ifnot) -> no_effects ifso && no_effects ifnot + | Switch (_, sw) -> + let aux (_, flam) = no_effects flam in + List.for_all aux sw.blocks + && List.for_all aux sw.consts + && Misc.Stdlib.Option.value_default no_effects sw.failaction + ~default:true + | String_switch (_, sw, def) -> + List.for_all (fun (_, lam) -> no_effects lam) sw + && Misc.Stdlib.Option.value_default no_effects def + ~default:true + | Static_catch (_, _, body, _) | Try_with (body, _, _) -> + (* If there is a [raise] in [body], the whole [Try_with] may have an + effect, so there is no need to test the handler. *) + no_effects body + | While _ | For _ | Apply _ | Send _ | Assign _ | Static_raise _ -> false + | Proved_unreachable -> true + +and no_effects_named (named : Flambda.named) = + match named with + | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field _ + | Set_of_closures _ | Project_closure _ | Project_var _ + | Move_within_set_of_closures _ -> true + | Prim (prim, _, _) -> no_effects_prim prim + | Expr flam -> no_effects flam diff --git a/middle_end/flambda/effect_analysis.mli b/middle_end/flambda/effect_analysis.mli new file mode 100644 index 00000000..b025bf0f --- /dev/null +++ b/middle_end/flambda/effect_analysis.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Simple side effect analysis. *) + +(* CR-someday pchambart: Replace by call to [Purity] module. + mshinwell: Where is the [Purity] module? *) +(** Conservative approximation as to whether a given Flambda expression may + have any side effects. *) +val no_effects : Flambda.t -> bool + +val no_effects_named : Flambda.named -> bool diff --git a/middle_end/flambda/export_info.ml b/middle_end/flambda/export_info.ml new file mode 100644 index 00000000..22dbb6c5 --- /dev/null +++ b/middle_end/flambda/export_info.ml @@ -0,0 +1,555 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +module A = Simple_value_approx + +type value_string_contents = + | Contents of string + | Unknown_or_mutable + +type value_string = { + contents : value_string_contents; + size : int; +} + +type value_float_array_contents = + | Contents of float option array + | Unknown_or_mutable + +type value_float_array = { + contents : value_float_array_contents; + size : int; +} + +type descr = + | Value_block of Tag.t * approx array + | Value_mutable_block of Tag.t * int + | Value_int of int + | Value_char of char + | Value_constptr of int + | Value_float of float + | Value_float_array of value_float_array + | Value_boxed_int : 'a A.boxed_int * 'a -> descr + | Value_string of value_string + | Value_closure of value_closure + | Value_set_of_closures of value_set_of_closures + | Value_unknown_descr + +and value_closure = { + closure_id : Closure_id.t; + set_of_closures : value_set_of_closures; +} + +and value_set_of_closures = { + set_of_closures_id : Set_of_closures_id.t; + bound_vars : approx Var_within_closure.Map.t; + free_vars : Flambda.specialised_to Variable.Map.t; + results : approx Closure_id.Map.t; + aliased_symbol : Symbol.t option; +} + +and approx = + | Value_unknown + | Value_id of Export_id.t + | Value_symbol of Symbol.t + +let equal_approx (a1:approx) (a2:approx) = + match a1, a2 with + | Value_unknown, Value_unknown -> + true + | Value_id id1, Value_id id2 -> + Export_id.equal id1 id2 + | Value_symbol s1, Value_symbol s2 -> + Symbol.equal s1 s2 + | (Value_unknown | Value_symbol _ | Value_id _), + (Value_unknown | Value_symbol _ | Value_id _) -> + false + +let equal_array eq a1 a2 = + Array.length a1 = Array.length a2 && + try + Array.iteri (fun i v1 -> if not (eq a2.(i) v1) then raise Exit) a1; + true + with Exit -> false + +let equal_option eq o1 o2 = + match o1, o2 with + | None, None -> true + | Some v1, Some v2 -> eq v1 v2 + | Some _, None | None, Some _ -> false + +let equal_set_of_closures (s1:value_set_of_closures) + (s2:value_set_of_closures) = + Set_of_closures_id.equal s1.set_of_closures_id s2.set_of_closures_id && + Var_within_closure.Map.equal equal_approx s1.bound_vars s2.bound_vars && + Closure_id.Map.equal equal_approx s1.results s2.results && + equal_option Symbol.equal s1.aliased_symbol s2.aliased_symbol + +let equal_descr (d1:descr) (d2:descr) : bool = + match d1, d2 with + | Value_unknown_descr, Value_unknown_descr -> + true + | Value_block (t1, f1), Value_block (t2, f2) -> + Tag.equal t1 t2 && equal_array equal_approx f1 f2 + | Value_mutable_block (t1, s1), Value_mutable_block (t2, s2) -> + Tag.equal t1 t2 && + s1 = s2 + | Value_int i1, Value_int i2 -> + i1 = i2 + | Value_char c1, Value_char c2 -> + c1 = c2 + | Value_constptr i1, Value_constptr i2 -> + i1 = i2 + | Value_float f1, Value_float f2 -> + f1 = f2 + | Value_float_array s1, Value_float_array s2 -> + s1 = s2 + | Value_boxed_int (t1, v1), Value_boxed_int (t2, v2) -> + A.equal_boxed_int t1 v1 t2 v2 + | Value_string s1, Value_string s2 -> + s1 = s2 + | Value_closure c1, Value_closure c2 -> + Closure_id.equal c1.closure_id c2.closure_id && + equal_set_of_closures c1.set_of_closures c2.set_of_closures + | Value_set_of_closures s1, Value_set_of_closures s2 -> + equal_set_of_closures s1 s2 + | ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _ + | Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _ + | Value_boxed_int _ | Value_string _ | Value_closure _ + | Value_set_of_closures _ + | Value_unknown_descr ), + ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _ + | Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _ + | Value_boxed_int _ | Value_string _ | Value_closure _ + | Value_set_of_closures _ + | Value_unknown_descr ) -> + false + +type t = { + sets_of_closures : A.function_declarations Set_of_closures_id.Map.t; + values : descr Export_id.Map.t Compilation_unit.Map.t; + symbol_id : Export_id.t Symbol.Map.t; + offset_fun : int Closure_id.Map.t; + offset_fv : int Var_within_closure.Map.t; + constant_closures : Closure_id.Set.t; + invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; + recursive : Variable.Set.t Set_of_closures_id.Map.t; +} + +type transient = { + sets_of_closures : A.function_declarations Set_of_closures_id.Map.t; + values : descr Export_id.Map.t Compilation_unit.Map.t; + symbol_id : Export_id.t Symbol.Map.t; + invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; + recursive : Variable.Set.t Set_of_closures_id.Map.t; + relevant_local_closure_ids : Closure_id.Set.t; + relevant_imported_closure_ids : Closure_id.Set.t; + relevant_local_vars_within_closure : Var_within_closure.Set.t; + relevant_imported_vars_within_closure : Var_within_closure.Set.t; +} + +let empty : t = { + sets_of_closures = Set_of_closures_id.Map.empty; + values = Compilation_unit.Map.empty; + symbol_id = Symbol.Map.empty; + offset_fun = Closure_id.Map.empty; + offset_fv = Var_within_closure.Map.empty; + constant_closures = Closure_id.Set.empty; + invariant_params = Set_of_closures_id.Map.empty; + recursive = Set_of_closures_id.Map.empty; +} + +let opaque_transient ~compilation_unit ~root_symbol : transient = + let export_id = Export_id.create compilation_unit in + let values = + let map = Export_id.Map.singleton export_id Value_unknown_descr in + Compilation_unit.Map.singleton compilation_unit map + in + let symbol_id = Symbol.Map.singleton root_symbol export_id in + { sets_of_closures = Set_of_closures_id.Map.empty; + values; + symbol_id; + invariant_params = Set_of_closures_id.Map.empty; + recursive = Set_of_closures_id.Map.empty; + relevant_local_closure_ids = Closure_id.Set.empty; + relevant_imported_closure_ids = Closure_id.Set.empty; + relevant_local_vars_within_closure = Var_within_closure.Set.empty; + relevant_imported_vars_within_closure = Var_within_closure.Set.empty; + } + +let create ~sets_of_closures ~values ~symbol_id + ~offset_fun ~offset_fv ~constant_closures + ~invariant_params ~recursive = + { sets_of_closures; + values; + symbol_id; + offset_fun; + offset_fv; + constant_closures; + invariant_params; + recursive; + } + +let create_transient + ~sets_of_closures ~values ~symbol_id ~invariant_params ~recursive + ~relevant_local_closure_ids ~relevant_imported_closure_ids + ~relevant_local_vars_within_closure + ~relevant_imported_vars_within_closure = + { sets_of_closures; + values; + symbol_id; + invariant_params; + recursive; + relevant_local_closure_ids; + relevant_imported_closure_ids; + relevant_local_vars_within_closure; + relevant_imported_vars_within_closure; + } + +let t_of_transient transient + ~program:_ + ~local_offset_fun ~local_offset_fv + ~imported_offset_fun ~imported_offset_fv + ~constant_closures = + let offset_fun = + let fold_map set = + Closure_id.Map.fold (fun key value unchanged -> + if Closure_id.Set.mem key set then + Closure_id.Map.add key value unchanged + else + unchanged) + in + Closure_id.Map.empty + |> fold_map transient.relevant_local_closure_ids local_offset_fun + |> fold_map transient.relevant_imported_closure_ids imported_offset_fun + in + let offset_fv = + let fold_map set = + Var_within_closure.Map.fold (fun key value unchanged -> + if Var_within_closure.Set.mem key set then + Var_within_closure.Map.add key value unchanged + else + unchanged) + in + Var_within_closure.Map.empty + |> fold_map transient.relevant_local_vars_within_closure local_offset_fv + |> fold_map transient.relevant_imported_vars_within_closure + imported_offset_fv + in + { sets_of_closures = transient.sets_of_closures; + values = transient.values; + symbol_id = transient.symbol_id; + invariant_params = transient.invariant_params; + recursive = transient.recursive; + offset_fun; + offset_fv; + constant_closures; + } + +let merge (t1 : t) (t2 : t) : t = + let eidmap_disjoint_union ?eq map1 map2 = + Compilation_unit.Map.merge (fun _id map1 map2 -> + match map1, map2 with + | None, None -> None + | None, Some map + | Some map, None -> Some map + | Some map1, Some map2 -> + Some (Export_id.Map.disjoint_union ?eq map1 map2)) + map1 map2 + in + let int_eq (i : int) j = i = j in + { values = eidmap_disjoint_union ~eq:equal_descr t1.values t2.values; + sets_of_closures = + Set_of_closures_id.Map.disjoint_union t1.sets_of_closures + t2.sets_of_closures; + symbol_id = + Symbol.Map.disjoint_union ~print:Export_id.print t1.symbol_id + t2.symbol_id; + offset_fun = Closure_id.Map.disjoint_union + ~eq:int_eq t1.offset_fun t2.offset_fun; + offset_fv = Var_within_closure.Map.disjoint_union + ~eq:int_eq t1.offset_fv t2.offset_fv; + constant_closures = + Closure_id.Set.union t1.constant_closures t2.constant_closures; + invariant_params = + Set_of_closures_id.Map.disjoint_union + ~print:(Variable.Map.print Variable.Set.print) + ~eq:(Variable.Map.equal Variable.Set.equal) + t1.invariant_params t2.invariant_params; + recursive = + Set_of_closures_id.Map.disjoint_union + ~print:Variable.Set.print + ~eq:Variable.Set.equal + t1.recursive t2.recursive; + } + +let find_value eid map = + let unit_map = + Compilation_unit.Map.find (Export_id.get_compilation_unit eid) map + in + Export_id.Map.find eid unit_map + +let find_description (t : t) eid = + find_value eid t.values + +let nest_eid_map map = + let add_map eid v map = + let unit = Export_id.get_compilation_unit eid in + let m = + try Compilation_unit.Map.find unit map + with Not_found -> Export_id.Map.empty + in + Compilation_unit.Map.add unit (Export_id.Map.add eid v m) map + in + Export_id.Map.fold add_map map Compilation_unit.Map.empty + +let print_raw_approx ppf approx = + let fprintf = Format.fprintf in + match approx with + | Value_unknown -> fprintf ppf "(Unknown)" + | Value_id export_id -> fprintf ppf "(Id %a)" Export_id.print export_id + | Value_symbol symbol -> fprintf ppf "(Symbol %a)" Symbol.print symbol + +let print_value_set_of_closures ppf (t : value_set_of_closures) = + let print_bound_vars ppf bound_vars = + Format.fprintf ppf "(%a)" + (Var_within_closure.Map.print print_raw_approx) + bound_vars + in + let print_free_vars ppf free_vars = + Format.fprintf ppf "(%a)" + (Variable.Map.print Flambda.print_specialised_to) + free_vars + in + let print_results ppf results = + Format.fprintf ppf "(%a)" (Closure_id.Map.print print_raw_approx) results + in + let print_aliased_symbol ppf aliased_symbol = + match aliased_symbol with + | None -> Format.fprintf ppf "" + | Some symbol -> Format.fprintf ppf "(%a)" Symbol.print symbol + in + Format.fprintf ppf + "((set_of_closures_id %a) \ + (bound_vars %a) \ + (free_vars %a) \ + (results %a) \ + (aliased_symbol %a))" + Set_of_closures_id.print t.set_of_closures_id + print_bound_vars t.bound_vars + print_free_vars t.free_vars + print_results t.results + print_aliased_symbol t.aliased_symbol + +let print_value_closure ppf (t : value_closure) = + Format.fprintf ppf "((closure_id %a) (set_of_closures %a))" + Closure_id.print t.closure_id + print_value_set_of_closures t.set_of_closures + +let print_value_float_array_contents + ppf (value : value_float_array_contents) = + match value with + | Unknown_or_mutable -> Format.fprintf ppf "(Unknown_or_mutable)" + | Contents _ -> Format.fprintf ppf "(Contents ...)" + +let print_value_float_array ppf (value : value_float_array) = + Format.fprintf ppf "((size %d) (contents %a))" + value.size + print_value_float_array_contents value.contents + +let print_value_string_contents ppf (value : value_string_contents) = + match value with + | Unknown_or_mutable -> Format.fprintf ppf "(Unknown_or_mutable)" + | Contents _ -> Format.fprintf ppf "(Contents ...)" + +let print_value_string ppf (value : value_string) = + Format.fprintf ppf "((size %d) (contents %a))" + value.size + print_value_string_contents value.contents + +let print_raw_descr ppf descr = + let fprintf = Format.fprintf in + let print_approx_array ppf arr = + Array.iter (fun approx -> fprintf ppf "%a " print_raw_approx approx) arr + in + match descr with + | Value_block (tag, approx_array) -> + fprintf ppf "(Value_block (%a %a))" + Tag.print tag + print_approx_array approx_array + | Value_mutable_block (tag, i) -> + fprintf ppf "(Value_mutable-block (%a %d))" Tag.print tag i + | Value_int i -> fprintf ppf "(Value_int %d)" i + | Value_char c -> fprintf ppf "(Value_char %c)" c + | Value_constptr p -> fprintf ppf "(Value_constptr %d)" p + | Value_float f -> fprintf ppf "(Value_float %.3f)" f + | Value_float_array value_float_array -> + fprintf ppf "(Value_float_array %a)" + print_value_float_array value_float_array + | Value_boxed_int _ -> + fprintf ppf "(Value_Boxed_int)" + | Value_string value_string -> + fprintf ppf "(Value_string %a)" print_value_string value_string + | Value_closure value_closure -> + fprintf ppf "(Value_closure %a)" + print_value_closure value_closure + | Value_set_of_closures value_set_of_closures -> + fprintf ppf "(Value_set_of_closures %a)" + print_value_set_of_closures value_set_of_closures + | Value_unknown_descr -> fprintf ppf "(Value_unknown_descr)" + +let print_approx_components ppf ~symbol_id ~values + (root_symbols : Symbol.t list) = + let fprintf = Format.fprintf in + let printed = ref Export_id.Set.empty in + let recorded_symbol = ref Symbol.Set.empty in + let symbols_to_print = Queue.create () in + let printed_set_of_closures = ref Set_of_closures_id.Set.empty in + let rec print_approx ppf (approx : approx) = + match approx with + | Value_unknown -> fprintf ppf "?" + | Value_id id -> + if Export_id.Set.mem id !printed then + fprintf ppf "(%a: _)" Export_id.print id + else begin + try + let descr = find_value id values in + printed := Export_id.Set.add id !printed; + fprintf ppf "@[(%a:@ %a)@]" + Export_id.print id print_descr descr + with Not_found -> + fprintf ppf "(%a: Not available)" Export_id.print id + end + | Value_symbol sym -> + if not (Symbol.Set.mem sym !recorded_symbol) then begin + recorded_symbol := Symbol.Set.add sym !recorded_symbol; + Queue.push sym symbols_to_print; + end; + Symbol.print ppf sym + and print_descr ppf (descr : descr) = + match descr with + | Value_int i -> Format.pp_print_int ppf i + | Value_char c -> fprintf ppf "%c" c + | Value_constptr i -> fprintf ppf "%ip" i + | Value_block (tag, fields) -> + fprintf ppf "[%a:%a]" Tag.print tag print_fields fields + | Value_mutable_block (tag, size) -> + fprintf ppf "[mutable %a:%i]" Tag.print tag size + | Value_closure {closure_id; set_of_closures} -> + fprintf ppf "(closure %a, %a)" Closure_id.print closure_id + print_set_of_closures set_of_closures + | Value_set_of_closures set_of_closures -> + fprintf ppf "(set_of_closures %a)" print_set_of_closures set_of_closures + | Value_string { contents; size } -> + begin match contents with + | Unknown_or_mutable -> Format.fprintf ppf "string %i" size + | Contents s -> + let s = + if size > 10 + then String.sub s 0 8 ^ "..." + else s + in + Format.fprintf ppf "string %i %S" size s + end + | Value_float f -> Format.pp_print_float ppf f + | Value_float_array float_array -> + Format.fprintf ppf "float_array%s %i" + (match float_array.contents with + | Unknown_or_mutable -> "" + | Contents _ -> "_imm") + float_array.size + | Value_boxed_int (t, i) -> + begin match t with + | A.Int32 -> Format.fprintf ppf "%li" i + | A.Int64 -> Format.fprintf ppf "%Li" i + | A.Nativeint -> Format.fprintf ppf "%ni" i + end + | Value_unknown_descr -> Format.fprintf ppf "?" + and print_fields ppf fields = + Array.iter (fun approx -> fprintf ppf "%a@ " print_approx approx) fields + and print_set_of_closures ppf + { set_of_closures_id; bound_vars; aliased_symbol; results } = + if Set_of_closures_id.Set.mem set_of_closures_id !printed_set_of_closures + then fprintf ppf "%a" Set_of_closures_id.print set_of_closures_id + else begin + printed_set_of_closures := + Set_of_closures_id.Set.add set_of_closures_id !printed_set_of_closures; + let print_alias ppf = function + | None -> () + | Some symbol -> + Format.fprintf ppf "@ (alias: %a)" Symbol.print symbol + in + fprintf ppf "{%a: %a%a => %a}" + Set_of_closures_id.print set_of_closures_id + print_binding bound_vars + print_alias aliased_symbol + (Closure_id.Map.print print_approx) results + end + and print_binding ppf bound_vars = + Var_within_closure.Map.iter (fun clos_id approx -> + fprintf ppf "%a -> %a,@ " + Var_within_closure.print clos_id + print_approx approx) + bound_vars + in + let rec print_recorded_symbols () = + if not (Queue.is_empty symbols_to_print) then begin + let sym = Queue.pop symbols_to_print in + begin match Symbol.Map.find sym symbol_id with + | exception Not_found -> () + | id -> + fprintf ppf "@[%a:@ %a@];@ " + Symbol.print sym + print_approx (Value_id id) + end; + print_recorded_symbols (); + end + in + List.iter (fun s -> Queue.push s symbols_to_print) root_symbols; + fprintf ppf "@[Globals:@ "; + fprintf ppf "@]@ @[Symbols:@ "; + print_recorded_symbols (); + fprintf ppf "@]" + +let print_approx ppf ((t : t), symbols) = + let symbol_id = t.symbol_id in + let values = t.values in + print_approx_components ppf ~symbol_id ~values symbols + +let print_offsets ppf (t : t) = + Format.fprintf ppf "@[offset_fun:@ "; + Closure_id.Map.iter (fun cid off -> + Format.fprintf ppf "%a -> %i@ " + Closure_id.print cid off) t.offset_fun; + Format.fprintf ppf "@]@ @[offset_fv:@ "; + Var_within_closure.Map.iter (fun vid off -> + Format.fprintf ppf "%a -> %i@ " + Var_within_closure.print vid off) t.offset_fv; + Format.fprintf ppf "@]@ " + +let print_functions ppf (t : t) = + Set_of_closures_id.Map.print + A.print_function_declarations ppf + t.sets_of_closures + +let print_all ppf ((t, root_symbols) : t * Symbol.t list) = + let fprintf = Format.fprintf in + fprintf ppf "approxs@ %a@.@." + print_approx (t, root_symbols); + fprintf ppf "functions@ %a@.@." + print_functions t diff --git a/middle_end/flambda/export_info.mli b/middle_end/flambda/export_info.mli new file mode 100644 index 00000000..f93698be --- /dev/null +++ b/middle_end/flambda/export_info.mli @@ -0,0 +1,195 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Exported information (that is to say, information written into a .cmx + file) about a compilation unit. *) + +module A = Simple_value_approx + +type value_string_contents = + | Contents of string + | Unknown_or_mutable + +type value_string = { + contents : value_string_contents; + size : int; +} + +type value_float_array_contents = + | Contents of float option array + | Unknown_or_mutable + +type value_float_array = { + contents : value_float_array_contents; + size : int; +} + +type descr = + | Value_block of Tag.t * approx array + | Value_mutable_block of Tag.t * int + | Value_int of int + | Value_char of char + | Value_constptr of int + | Value_float of float + | Value_float_array of value_float_array + | Value_boxed_int : 'a A.boxed_int * 'a -> descr + | Value_string of value_string + | Value_closure of value_closure + | Value_set_of_closures of value_set_of_closures + | Value_unknown_descr + +and value_closure = { + closure_id : Closure_id.t; + set_of_closures : value_set_of_closures; +} + +and value_set_of_closures = { + set_of_closures_id : Set_of_closures_id.t; + bound_vars : approx Var_within_closure.Map.t; + free_vars : Flambda.specialised_to Variable.Map.t; + results : approx Closure_id.Map.t; + aliased_symbol : Symbol.t option; +} + +(* CR-soon mshinwell: Fix the export information so we can correctly + propagate "unresolved due to..." in the manner of [Simple_value_approx]. + Unfortunately this seems to be complicated by the fact that, during + [Import_approx], resolution can fail not only due to missing symbols but + also due to missing export IDs. The argument type of + [Simple_value_approx.t] may need updating to reflect this (make the + symbol optional? It's only for debugging anyway.) *) +and approx = + | Value_unknown + | Value_id of Export_id.t + | Value_symbol of Symbol.t + +(** A structure that describes what a single compilation unit exports. *) +type t = private { + sets_of_closures : A.function_declarations Set_of_closures_id.Map.t; + (** Code of exported functions indexed by set of closures IDs. *) + values : descr Export_id.Map.t Compilation_unit.Map.t; + (** Structure of exported values. *) + symbol_id : Export_id.t Symbol.Map.t; + (** Associates symbols and values. *) + offset_fun : int Closure_id.Map.t; + (** Positions of function pointers in their closures. *) + offset_fv : int Var_within_closure.Map.t; + (** Positions of value pointers in their closures. *) + constant_closures : Closure_id.Set.t; + (* CR-soon mshinwell for pchambart: Add comment *) + invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; + (* Function parameters known to be invariant (see [Invariant_params]) + indexed by set of closures ID. *) + recursive : Variable.Set.t Set_of_closures_id.Map.t; +} + +type transient = private { + sets_of_closures : A.function_declarations Set_of_closures_id.Map.t; + values : descr Export_id.Map.t Compilation_unit.Map.t; + symbol_id : Export_id.t Symbol.Map.t; + invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; + recursive : Variable.Set.t Set_of_closures_id.Map.t; + relevant_local_closure_ids : Closure_id.Set.t; + relevant_imported_closure_ids : Closure_id.Set.t; + relevant_local_vars_within_closure : Var_within_closure.Set.t; + relevant_imported_vars_within_closure : Var_within_closure.Set.t; +} + +(** Export information for a compilation unit that exports nothing. *) +val empty : t + +val opaque_transient + : compilation_unit:Compilation_unit.t + -> root_symbol:Symbol.t + -> transient + +(** Create a new export information structure. *) +val create + : sets_of_closures:(A.function_declarations Set_of_closures_id.Map.t) + -> values:descr Export_id.Map.t Compilation_unit.Map.t + -> symbol_id:Export_id.t Symbol.Map.t + -> offset_fun:int Closure_id.Map.t + -> offset_fv:int Var_within_closure.Map.t + -> constant_closures:Closure_id.Set.t + -> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t + -> recursive:Variable.Set.t Set_of_closures_id.Map.t + -> t + +val create_transient + : sets_of_closures:(A.function_declarations Set_of_closures_id.Map.t) + -> values:descr Export_id.Map.t Compilation_unit.Map.t + -> symbol_id:Export_id.t Symbol.Map.t + -> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t + -> recursive:Variable.Set.t Set_of_closures_id.Map.t + -> relevant_local_closure_ids: Closure_id.Set.t + -> relevant_imported_closure_ids : Closure_id.Set.t + -> relevant_local_vars_within_closure : Var_within_closure.Set.t + -> relevant_imported_vars_within_closure : Var_within_closure.Set.t + -> transient + +(* CR-someday pchambart: Should we separate [t] in 2 types: one created by the + current [create] function, returned by [Build_export_info]. And + another built using t and offset_informations returned by + [flambda_to_clambda] ? + mshinwell: I think we should, but after we've done the first release. +*) +(** Record information about the layout of closures and which sets of + closures are constant. These are all worked out during the + [Flambda_to_clambda] pass. *) +val t_of_transient + : transient + -> program: Flambda.program + -> local_offset_fun:int Closure_id.Map.t + -> local_offset_fv:int Var_within_closure.Map.t + -> imported_offset_fun:int Closure_id.Map.t + -> imported_offset_fv:int Var_within_closure.Map.t + -> constant_closures:Closure_id.Set.t + -> t + +(** Union of export information. Verifies that there are no identifier + clashes. *) +val merge : t -> t -> t + +(** Look up the description of an exported value given its export ID. *) +val find_description + : t + -> Export_id.t + -> descr + +(** Partition a mapping from export IDs by compilation unit. *) +val nest_eid_map + : 'a Export_id.Map.t + -> 'a Export_id.Map.t Compilation_unit.Map.t + +(**/**) +(* Debug printing functions. *) +val print_approx_components + : Format.formatter + -> symbol_id: Export_id.t Symbol.Map.t + -> values: descr Export_id.Map.t Compilation_unit.Map.t + -> Symbol.t list + -> unit +val print_approx : Format.formatter -> t * Symbol.t list -> unit +val print_functions : Format.formatter -> t -> unit +val print_offsets : Format.formatter -> t -> unit +val print_all : Format.formatter -> t * Symbol.t list -> unit + +(** Prints approx and descr as it is, without recursively looking up + [Export_id.t] *) +val print_raw_approx : Format.formatter -> approx -> unit +val print_raw_descr : Format.formatter -> descr -> unit diff --git a/middle_end/flambda/export_info_for_pack.ml b/middle_end/flambda/export_info_for_pack.ml new file mode 100644 index 00000000..42a81553 --- /dev/null +++ b/middle_end/flambda/export_info_for_pack.ml @@ -0,0 +1,231 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +module A = Simple_value_approx + +let rename_id_state = Export_id.Tbl.create 100 +let rename_set_of_closures_id_state = Set_of_closures_id.Tbl.create 10 +let imported_function_declarations_table = + (Set_of_closures_id.Tbl.create 10 + : A.function_declarations Set_of_closures_id.Tbl.t) + +(* Rename export identifiers' compilation units to denote that they now + live within a pack. *) +let import_eid_for_pack units pack id = + try Export_id.Tbl.find rename_id_state id + with Not_found -> + let unit_id = Export_id.get_compilation_unit id in + let id' = + if Compilation_unit.Set.mem unit_id units + then Export_id.create ?name:(Export_id.name id) pack + else id + in + Export_id.Tbl.add rename_id_state id id'; + id' + +(* Similar to [import_eid_for_pack], but for symbols. *) +let import_symbol_for_pack units pack symbol = + let compilation_unit = Symbol.compilation_unit symbol in + if Compilation_unit.Set.mem compilation_unit units + then Symbol.import_for_pack ~pack symbol + else symbol + +let import_approx_for_pack units pack (approx : Export_info.approx) + : Export_info.approx = + match approx with + | Value_symbol sym -> Value_symbol (import_symbol_for_pack units pack sym) + | Value_id eid -> Value_id (import_eid_for_pack units pack eid) + | Value_unknown -> Value_unknown + +let import_set_of_closures_id_for_pack units pack + (set_of_closures_id : Set_of_closures_id.t) + : Set_of_closures_id.t = + let compilation_unit = + Set_of_closures_id.get_compilation_unit set_of_closures_id + in + if Compilation_unit.Set.mem compilation_unit units then + Set_of_closures_id.Tbl.memoize + rename_set_of_closures_id_state + (fun _ -> + Set_of_closures_id.create + ?name:(Set_of_closures_id.name set_of_closures_id) + pack) + set_of_closures_id + else set_of_closures_id + +let import_set_of_closures_origin_for_pack units pack + (set_of_closures_origin : Set_of_closures_origin.t) + : Set_of_closures_origin.t = + Set_of_closures_origin.rename + (import_set_of_closures_id_for_pack units pack) + set_of_closures_origin + +let import_set_of_closures units pack + (set_of_closures : Export_info.value_set_of_closures) + : Export_info.value_set_of_closures = + { set_of_closures_id = + import_set_of_closures_id_for_pack units pack + set_of_closures.set_of_closures_id; + bound_vars = + Var_within_closure.Map.map (import_approx_for_pack units pack) + set_of_closures.bound_vars; + free_vars = set_of_closures.free_vars; + results = + Closure_id.Map.map (import_approx_for_pack units pack) + set_of_closures.results; + aliased_symbol = + Misc.may_map + (import_symbol_for_pack units pack) + set_of_closures.aliased_symbol; + } + +let import_descr_for_pack units pack (descr : Export_info.descr) + : Export_info.descr = + match descr with + | Value_int _ + | Value_char _ + | Value_constptr _ + | Value_string _ + | Value_float _ + | Value_float_array _ + | Export_info.Value_boxed_int _ + | Value_mutable_block _ as desc -> desc + | Value_block (tag, fields) -> + Value_block (tag, Array.map (import_approx_for_pack units pack) fields) + | Value_closure { closure_id; set_of_closures } -> + Value_closure { + closure_id; + set_of_closures = import_set_of_closures units pack set_of_closures; + } + | Value_set_of_closures set_of_closures -> + Value_set_of_closures (import_set_of_closures units pack set_of_closures) + | Value_unknown_descr -> Value_unknown_descr + +let rec import_code_for_pack units pack expr = + Flambda_iterators.map_named (function + | Symbol sym -> Symbol (import_symbol_for_pack units pack sym) + | Read_symbol_field (sym, field) -> + Read_symbol_field (import_symbol_for_pack units pack sym, field) + | Set_of_closures set_of_closures -> + let set_of_closures = + Flambda.create_set_of_closures + ~free_vars:set_of_closures.free_vars + ~specialised_args:set_of_closures.specialised_args + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + ~function_decls: + (import_function_declarations_for_pack_aux units pack + set_of_closures.function_decls) + in + Set_of_closures set_of_closures + | e -> e) + expr + +and import_function_declarations_for_pack_aux units pack + (function_decls : Flambda.function_declarations) = + let funs = + Variable.Map.map + (fun (function_decl : Flambda.function_declaration) -> + Flambda.create_function_declaration ~params:function_decl.params + ~body:(import_code_for_pack units pack function_decl.body) + ~stub:function_decl.stub ~dbg:function_decl.dbg + ~inline:function_decl.inline + ~specialise:function_decl.specialise + ~is_a_functor:function_decl.is_a_functor + ~closure_origin:function_decl.closure_origin) + function_decls.funs + in + Flambda.import_function_declarations_for_pack + (Flambda.update_function_declarations function_decls ~funs) + (import_set_of_closures_id_for_pack units pack) + (import_set_of_closures_origin_for_pack units pack) + +let import_function_declarations_for_pack_aux units pack + (function_decls : A.function_declarations) : A.function_declarations = + let funs = + Variable.Map.map + (fun (function_decl : A.function_declaration) -> + A.update_function_declaration_body function_decl + (fun body -> import_code_for_pack units pack body)) + function_decls.funs + in + A.import_function_declarations_for_pack + (A.update_function_declarations function_decls ~funs) + (import_set_of_closures_id_for_pack units pack) + (import_set_of_closures_origin_for_pack units pack) + +let import_function_declarations_approx_for_pack units pack + (function_decls: A.function_declarations) = + let original_set_of_closures_id = function_decls.set_of_closures_id in + try + Set_of_closures_id.Tbl.find imported_function_declarations_table + original_set_of_closures_id + with Not_found -> + let function_decls = + import_function_declarations_for_pack_aux units pack function_decls + in + Set_of_closures_id.Tbl.add + imported_function_declarations_table + original_set_of_closures_id + function_decls; + function_decls + +let import_eidmap_for_pack units pack f map = + Export_info.nest_eid_map + (Compilation_unit.Map.fold + (fun _ map acc -> Export_id.Map.disjoint_union map acc) + (Compilation_unit.Map.map (fun map -> + Export_id.Map.map_keys (import_eid_for_pack units pack) + (Export_id.Map.map f map)) + map) + Export_id.Map.empty) + +let import_for_pack ~pack_units ~pack (exp : Export_info.t) = + let import_sym = import_symbol_for_pack pack_units pack in + let import_descr = import_descr_for_pack pack_units pack in + let import_eid = import_eid_for_pack pack_units pack in + let import_eidmap f map = import_eidmap_for_pack pack_units pack f map in + let import_set_of_closures_id = + import_set_of_closures_id_for_pack pack_units pack + in + let import_function_declarations = + import_function_declarations_approx_for_pack pack_units pack + in + let sets_of_closures = + Set_of_closures_id.Map.map_keys import_set_of_closures_id + (Set_of_closures_id.Map.map + import_function_declarations + exp.sets_of_closures) + in + Export_info.create ~sets_of_closures + ~offset_fun:exp.offset_fun + ~offset_fv:exp.offset_fv + ~values:(import_eidmap import_descr exp.values) + ~symbol_id:(Symbol.Map.map_keys import_sym + (Symbol.Map.map import_eid exp.symbol_id)) + ~constant_closures:exp.constant_closures + ~invariant_params: + (Set_of_closures_id.Map.map_keys import_set_of_closures_id + exp.invariant_params) + ~recursive: + (Set_of_closures_id.Map.map_keys import_set_of_closures_id + exp.recursive) + +let clear_import_state () = + Set_of_closures_id.Tbl.clear imported_function_declarations_table; + Set_of_closures_id.Tbl.clear rename_set_of_closures_id_state; + Export_id.Tbl.clear rename_id_state diff --git a/middle_end/flambda/export_info_for_pack.mli b/middle_end/flambda/export_info_for_pack.mli new file mode 100644 index 00000000..2ba3a35d --- /dev/null +++ b/middle_end/flambda/export_info_for_pack.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Transformations on export information that are only used for the + building of packs. *) + +(** Transform the information from [exported] to be + suitable to be reexported as the information for a pack named [pack] + containing units [pack_units]. + It mainly changes symbols of units [pack_units] to refer to + [pack] instead. *) +val import_for_pack + : pack_units:Compilation_unit.Set.t + -> pack:Compilation_unit.t + -> Export_info.t + -> Export_info.t + +(** Drops the state after importing several units in the same pack. *) +val clear_import_state : unit -> unit diff --git a/middle_end/flambda/extract_projections.ml b/middle_end/flambda/extract_projections.ml new file mode 100644 index 00000000..33cd473e --- /dev/null +++ b/middle_end/flambda/extract_projections.ml @@ -0,0 +1,190 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module A = Simple_value_approx +module E = Inline_and_simplify_aux.Env + +(* CR-soon pchambart: should we restrict only to cases + when the field is aliased to a variable outside + of the closure (i.e. when we can certainly remove + the allocation of the block) ? + Note that this may prevent cases with imbricated + closures from benefiting from this transformations. + mshinwell: What word was "imbricated" supposed to be? + (The code this referred to has been deleted, but the same thing is + probably still happening). +*) + +let known_valid_projections ~env ~projections ~which_variables = + Projection.Set.filter (fun projection -> + let from = Projection.projecting_from projection in + let outer_var = + match Variable.Map.find from which_variables with + | exception Not_found -> assert false + | (outer_var : Flambda.specialised_to) -> + Freshening.apply_variable (E.freshening env) outer_var.var + in + let approx = E.find_exn env outer_var in + match projection with + | Project_var project_var -> + begin match A.check_approx_for_closure approx with + | Ok (_value_closure, _approx_var, _approx_sym, + value_set_of_closures) -> + Var_within_closure.Map.mem project_var.var + value_set_of_closures.bound_vars + | Wrong -> false + end + | Project_closure project_closure -> + begin match A.strict_check_approx_for_set_of_closures approx with + | Ok (_var, value_set_of_closures) -> + Variable.Set.mem (Closure_id.unwrap project_closure.closure_id) + (Variable.Map.keys value_set_of_closures.function_decls.funs) + | Wrong -> false + end + | Move_within_set_of_closures move -> + begin match A.check_approx_for_closure approx with + | Ok (value_closure, _approx_var, _approx_sym, + _value_set_of_closures) -> + (* We could check that [move.move_to] is in [value_set_of_closures], + but this is unnecessary, since [Closure_id]s are unique. *) + Closure_id.equal value_closure.closure_id move.start_from + | Wrong -> false + end + | Field (field_index, _) -> + match A.check_approx_for_block approx with + | Wrong -> false + | Ok (_tag, fields) -> + field_index >= 0 && field_index < Array.length fields) + projections + +let rec analyse_expr ~which_variables expr = + let projections = ref Projection.Set.empty in + let used_which_variables = ref Variable.Set.empty in + let check_free_variable var = + if Variable.Map.mem var which_variables then begin + used_which_variables := Variable.Set.add var !used_which_variables + end + in + let for_expr (expr : Flambda.expr) = + match expr with + | Var var + | Let_mutable { initial_value = var } -> + check_free_variable var + (* CR-soon mshinwell: We don't handle [Apply] for the moment to + avoid disabling unboxing optimizations whenever we see a recursive + call. We should improve this analysis. Leo says this can be + done by a similar thing to the unused argument analysis. *) + | Apply _ -> () + | Send { meth; obj; args; _ } -> + check_free_variable meth; + check_free_variable obj; + List.iter check_free_variable args + | Assign { new_value; _ } -> + check_free_variable new_value + | If_then_else (var, _, _) + | Switch (var, _) + | String_switch (var, _, _) -> + check_free_variable var + | Static_raise (_, args) -> + List.iter check_free_variable args + | For { from_value; to_value; _ } -> + check_free_variable from_value; + check_free_variable to_value + | Let _ | Let_rec _ | Static_catch _ | While _ | Try_with _ + | Proved_unreachable -> () + in + let for_named (named : Flambda.named) = + match named with + | Project_var project_var + when Variable.Map.mem project_var.closure which_variables -> + projections := + Projection.Set.add (Project_var project_var) !projections + | Project_closure project_closure + when Variable.Map.mem project_closure.set_of_closures + which_variables -> + projections := + Projection.Set.add (Project_closure project_closure) !projections + | Move_within_set_of_closures move + when Variable.Map.mem move.closure which_variables -> + projections := + Projection.Set.add (Move_within_set_of_closures move) !projections + | Prim (Pfield field_index, [var], _dbg) + when Variable.Map.mem var which_variables -> + projections := + Projection.Set.add (Field (field_index, var)) !projections + | Set_of_closures set_of_closures -> + let aliasing_free_vars = + Variable.Map.filter (fun _ (spec_to : Flambda.specialised_to) -> + Variable.Map.mem spec_to.var which_variables) + set_of_closures.free_vars + in + let aliasing_specialised_args = + Variable.Map.filter (fun _ (spec_to : Flambda.specialised_to) -> + Variable.Map.mem spec_to.var which_variables) + set_of_closures.specialised_args + in + let aliasing_vars = + Variable.Map.disjoint_union + aliasing_free_vars aliasing_specialised_args + in + if not (Variable.Map.is_empty aliasing_vars) then begin + Variable.Map.iter (fun _ (fun_decl : Flambda.function_declaration) -> + (* We ignore projections from within nested sets of closures. *) + let _, used = + analyse_expr fun_decl.body ~which_variables:aliasing_vars + in + Variable.Set.iter (fun var -> + match Variable.Map.find var aliasing_vars with + | exception Not_found -> assert false + | spec_to -> check_free_variable spec_to.var) + used) + set_of_closures.function_decls.funs + end + | Prim (_, vars, _) -> + List.iter check_free_variable vars + | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field _ | Project_var _ | Project_closure _ + | Move_within_set_of_closures _ + | Expr _ -> () + in + Flambda_iterators.iter_toplevel for_expr for_named expr; + let projections = !projections in + let used_which_variables = !used_which_variables in + projections, used_which_variables + +let from_function_decl ~env ~which_variables + ~(function_decl : Flambda.function_declaration) = + let projections, used_which_variables = + analyse_expr ~which_variables function_decl.body + in + (* We must use approximation information to determine which projections + are actually valid in the current environment, other we might lift + expressions too far. *) + let projections = + known_valid_projections ~env ~projections ~which_variables + in + (* Don't extract projections whose [projecting_from] variable is also + used boxed. We could in the future consider being more sophisticated + about this based on the uses in the body, but given we are not doing + that yet, it seems safest in performance terms not to (e.g.) unbox a + specialised argument whose boxed version is used. *) + Projection.Set.filter (fun projection -> + let projecting_from = Projection.projecting_from projection in + not (Variable.Set.mem projecting_from used_which_variables)) + projections diff --git a/middle_end/flambda/extract_projections.mli b/middle_end/flambda/extract_projections.mli new file mode 100644 index 00000000..47456bda --- /dev/null +++ b/middle_end/flambda/extract_projections.mli @@ -0,0 +1,33 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Identify projections from variables used in function bodies (free + variables or specialised args, for example, according to [which_variables] + below). Projections from variables that are also used boxed are not + returned. *) + +(** [which_variables] maps (existing) inner variables to (existing) outer + variables in the manner of [free_vars] and [specialised_args] in + [Flambda.set_of_closures]. + + The returned projections are [projecting_from] (cf. projection.mli) + the "existing inner vars". +*) +val from_function_decl + : env:Inline_and_simplify_aux.Env.t + -> which_variables:Flambda.specialised_to Variable.Map.t + -> function_decl:Flambda.function_declaration + -> Projection.Set.t diff --git a/middle_end/flambda/find_recursive_functions.ml b/middle_end/flambda/find_recursive_functions.ml new file mode 100644 index 00000000..e6943303 --- /dev/null +++ b/middle_end/flambda/find_recursive_functions.ml @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let in_function_declarations (function_decls : Flambda.function_declarations) + ~backend = + let module VCC = Strongly_connected_components.Make (Variable) in + let directed_graph = + let module B = (val backend : Backend_intf.S) in + Flambda_utils.fun_vars_referenced_in_decls function_decls + ~closure_symbol:B.closure_symbol + in + let connected_components = + VCC.connected_components_sorted_from_roots_to_leaf directed_graph + in + Array.fold_left (fun rec_fun -> function + | VCC.No_loop _ -> rec_fun + | VCC.Has_loop elts -> List.fold_right Variable.Set.add elts rec_fun) + Variable.Set.empty connected_components diff --git a/middle_end/flambda/find_recursive_functions.mli b/middle_end/flambda/find_recursive_functions.mli new file mode 100644 index 00000000..3c2dd5b1 --- /dev/null +++ b/middle_end/flambda/find_recursive_functions.mli @@ -0,0 +1,37 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** "Recursive functions" are those functions [f] that might call either: + - themselves, or + - another function that in turn might call [f]. + + For example in the following simultaneous definition of [f] [g] and [h], + [f] and [g] are recursive functions, but not [h]: + [let rec f x = g x + and g x = f x + and h x = g x] +*) + +(** Determine the recursive functions, if any, bound by the given set of + function declarations. + This is only intended to be used by [Flambda.create_function_declarations]. +*) +val in_function_declarations + : Flambda.function_declarations + -> backend:(module Backend_intf.S) + -> Variable.Set.t diff --git a/middle_end/flambda/flambda.ml b/middle_end/flambda/flambda.ml new file mode 100644 index 00000000..243e2e3f --- /dev/null +++ b/middle_end/flambda/flambda.ml @@ -0,0 +1,1272 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type call_kind = + | Indirect + | Direct of Closure_id.t + +type const = + | Int of int + | Char of char + | Const_pointer of int + +type apply = { + func : Variable.t; + args : Variable.t list; + kind : call_kind; + dbg : Debuginfo.t; + inline : Lambda.inline_attribute; + specialise : Lambda.specialise_attribute; +} + +type assign = { + being_assigned : Mutable_variable.t; + new_value : Variable.t; +} + +type send = { + kind : Lambda.meth_kind; + meth : Variable.t; + obj : Variable.t; + args : Variable.t list; + dbg : Debuginfo.t; +} + +type project_closure = Projection.project_closure +type move_within_set_of_closures = Projection.move_within_set_of_closures +type project_var = Projection.project_var + +type specialised_to = { + var : Variable.t; + projection : Projection.t option; +} + +type t = + | Var of Variable.t + | Let of let_expr + | Let_mutable of let_mutable + | Let_rec of (Variable.t * named) list * t + | Apply of apply + | Send of send + | Assign of assign + | If_then_else of Variable.t * t * t + | Switch of Variable.t * switch + | String_switch of Variable.t * (string * t) list * t option + | Static_raise of Static_exception.t * Variable.t list + | Static_catch of Static_exception.t * Variable.t list * t * t + | Try_with of t * Variable.t * t + | While of t * t + | For of for_loop + | Proved_unreachable + +and named = + | Symbol of Symbol.t + | Const of const + | Allocated_const of Allocated_const.t + | Read_mutable of Mutable_variable.t + | Read_symbol_field of Symbol.t * int + | Set_of_closures of set_of_closures + | Project_closure of project_closure + | Move_within_set_of_closures of move_within_set_of_closures + | Project_var of project_var + | Prim of Clambda_primitives.primitive * Variable.t list * Debuginfo.t + | Expr of t + +and let_expr = { + var : Variable.t; + defining_expr : named; + body : t; + free_vars_of_defining_expr : Variable.Set.t; + free_vars_of_body : Variable.Set.t; +} + +and let_mutable = { + var : Mutable_variable.t; + initial_value : Variable.t; + contents_kind : Lambda.value_kind; + body : t; +} + +and set_of_closures = { + function_decls : function_declarations; + free_vars : specialised_to Variable.Map.t; + specialised_args : specialised_to Variable.Map.t; + direct_call_surrogates : Variable.t Variable.Map.t; +} + +and function_declarations = { + is_classic_mode : bool; + set_of_closures_id : Set_of_closures_id.t; + set_of_closures_origin : Set_of_closures_origin.t; + funs : function_declaration Variable.Map.t; +} + +and function_declaration = { + closure_origin: Closure_origin.t; + params : Parameter.t list; + body : t; + free_variables : Variable.Set.t; + free_symbols : Symbol.Set.t; + stub : bool; + dbg : Debuginfo.t; + inline : Lambda.inline_attribute; + specialise : Lambda.specialise_attribute; + is_a_functor : bool; +} + +and switch = { + numconsts : Numbers.Int.Set.t; + consts : (int * t) list; + numblocks : Numbers.Int.Set.t; + blocks : (int * t) list; + failaction : t option; +} + +and for_loop = { + bound_var : Variable.t; + from_value : Variable.t; + to_value : Variable.t; + direction : Asttypes.direction_flag; + body : t +} + +and constant_defining_value = + | Allocated_const of Allocated_const.t + | Block of Tag.t * constant_defining_value_block_field list + | Set_of_closures of set_of_closures (* [free_vars] must be empty *) + | Project_closure of Symbol.t * Closure_id.t + +and constant_defining_value_block_field = + | Symbol of Symbol.t + | Const of const + +type expr = t + +type program_body = + | Let_symbol of Symbol.t * constant_defining_value * program_body + | Let_rec_symbol of (Symbol.t * constant_defining_value) list * program_body + | Initialize_symbol of Symbol.t * Tag.t * t list * program_body + | Effect of t * program_body + | End of Symbol.t + +type program = { + imported_symbols : Symbol.Set.t; + program_body : program_body; +} + +let fprintf = Format.fprintf +module Int = Numbers.Int + +let print_specialised_to ppf (spec_to : specialised_to) = + match spec_to.projection with + | None -> fprintf ppf "%a" Variable.print spec_to.var + | Some projection -> + fprintf ppf "%a(= %a)" + Variable.print spec_to.var + Projection.print projection + +(* CR-soon mshinwell: delete uses of old names *) +let print_project_var = Projection.print_project_var +let print_move_within_set_of_closures = + Projection.print_move_within_set_of_closures +let print_project_closure = Projection.print_project_closure + +(** CR-someday lwhite: use better name than this *) +let rec lam ppf (flam : t) = + match flam with + | Var (id) -> + Variable.print ppf id + | Apply({func; args; kind; inline; dbg}) -> + let direct ppf () = + match kind with + | Indirect -> () + | Direct closure_id -> fprintf ppf "*[%a]" Closure_id.print closure_id + in + let inline ppf () = + match inline with + | Always_inline -> fprintf ppf "" + | Never_inline -> fprintf ppf "" + | Unroll i -> fprintf ppf "" i + | Default_inline -> () + in + fprintf ppf "@[<2>(apply%a%a<%s>@ %a%a)@]" direct () inline () + (Debuginfo.to_string dbg) + Variable.print func Variable.print_list args + | Assign { being_assigned; new_value; } -> + fprintf ppf "@[<2>(assign@ %a@ %a)@]" + Mutable_variable.print being_assigned + Variable.print new_value + | Send { kind; meth; obj; args; dbg = _; } -> + let print_args ppf args = + List.iter (fun l -> fprintf ppf "@ %a" Variable.print l) args + in + let kind = + match kind with + | Self -> "self" + | Public -> "public" + | Cached -> "cached" + in + fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind + Variable.print obj Variable.print meth + print_args args + | Proved_unreachable -> + fprintf ppf "unreachable" + | Let { var = id; defining_expr = arg; body; _ } -> + let rec letbody (ul : t) = + match ul with + | Let { var = id; defining_expr = arg; body; _ } -> + fprintf ppf "@ @[<2>%a@ %a@]" Variable.print id print_named arg; + letbody body + | _ -> ul + in + fprintf ppf "@[<2>(let@ @[(@[<2>%a@ %a@]" + Variable.print id print_named arg; + let expr = letbody body in + fprintf ppf ")@]@ %a)@]" lam expr + | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> + let print_kind ppf (kind : Lambda.value_kind) = + match kind with + | Pgenval -> () + | _ -> Format.fprintf ppf " %a" Printlambda.value_kind kind + in + fprintf ppf "@[<2>(let_mutable%a@ @[<2>%a@ %a@]@ %a)@]" + print_kind contents_kind + Mutable_variable.print mut_var + Variable.print var + lam body + | Let_rec(id_arg_list, body) -> + let bindings ppf id_arg_list = + let spc = ref false in + List.iter + (fun (id, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<2>%a@ %a@]" Variable.print id print_named l) + id_arg_list in + fprintf ppf + "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body + | Switch(larg, sw) -> + let switch ppf (sw : switch) = + let spc = ref false in + List.iter + (fun (n, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case int %i:@ %a@]" n lam l) + sw.consts; + List.iter + (fun (n, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case tag %i:@ %a@]" n lam l) + sw.blocks ; + begin match sw.failaction with + | None -> () + | Some l -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam l + end in + fprintf ppf + "@[<1>(%s(%i,%i) %a@ @[%a@])@]" + (match sw.failaction with None -> "switch*" | _ -> "switch") + (Int.Set.cardinal sw.numconsts) + (Int.Set.cardinal sw.numblocks) + Variable.print larg switch sw + | String_switch(arg, cases, default) -> + let switch ppf cases = + let spc = ref false in + List.iter + (fun (s, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) + cases; + begin match default with + | Some default -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam default + | None -> () + end in + fprintf ppf + "@[<1>(stringswitch %a@ @[%a@])@]" Variable.print arg switch cases + | Static_raise (i, ls) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" Variable.print l) largs in + fprintf ppf "@[<2>(exit@ %a%a)@]" Static_exception.print i lams ls; + | Static_catch(i, vars, lbody, lhandler) -> + fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%a%a)@ %a)@]" + lam lbody Static_exception.print i + (fun ppf vars -> match vars with + | [] -> () + | _ -> + List.iter + (fun x -> fprintf ppf " %a" Variable.print x) + vars) + vars + lam lhandler + | Try_with(lbody, param, lhandler) -> + fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" + lam lbody Variable.print param lam lhandler + | If_then_else(lcond, lif, lelse) -> + fprintf ppf "@[<2>(if@ %a@ then begin@ %a@ end else begin@ %a@ end)@]" + Variable.print lcond + lam lif lam lelse + | While(lcond, lbody) -> + fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody + | For { bound_var; from_value; to_value; direction; body; } -> + fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" + Variable.print bound_var Variable.print from_value + (match direction with + Asttypes.Upto -> "to" | Asttypes.Downto -> "downto") + Variable.print to_value lam body +and print_named ppf (named : named) = + match named with + | Symbol (symbol) -> Symbol.print ppf symbol + | Const (cst) -> fprintf ppf "Const(%a)" print_const cst + | Allocated_const (cst) -> fprintf ppf "Aconst(%a)" Allocated_const.print cst + | Read_mutable mut_var -> + fprintf ppf "Read_mut(%a)" Mutable_variable.print mut_var + | Read_symbol_field (symbol, field) -> + fprintf ppf "%a.(%d)" Symbol.print symbol field + | Project_closure (project_closure) -> + print_project_closure ppf project_closure + | Project_var (project_var) -> print_project_var ppf project_var + | Move_within_set_of_closures (move_within_set_of_closures) -> + print_move_within_set_of_closures ppf move_within_set_of_closures + | Set_of_closures (set_of_closures) -> + print_set_of_closures ppf set_of_closures + | Prim(prim, args, dbg) -> + fprintf ppf "@[<2>(%a<%s>%a)@]" Printclambda_primitives.primitive prim + (Debuginfo.to_string dbg) + Variable.print_list args + | Expr expr -> + fprintf ppf "*%a" lam expr + (* lam ppf expr *) + +and print_function_declaration ppf var (f : function_declaration) = + let param ppf p = + Variable.print ppf (Parameter.var p) + in + let params ppf = + List.iter (fprintf ppf "@ %a" param) in + let stub = + if f.stub then + " *stub*" + else + "" + in + let is_a_functor = + if f.is_a_functor then + " *functor*" + else + "" + in + let inline = + match f.inline with + | Always_inline -> " *inline*" + | Never_inline -> " *never_inline*" + | Unroll _ -> " *unroll*" + | Default_inline -> "" + in + let specialise = + match f.specialise with + | Always_specialise -> " *specialise*" + | Never_specialise -> " *never_specialise*" + | Default_specialise -> "" + in + fprintf ppf "@[<2>(%a%s%s%s%s@ =@ fun@[<2>%a@] ->@ @[<2>%a@])@]@ " + Variable.print var stub is_a_functor inline specialise + params f.params lam f.body + +and print_set_of_closures ppf (set_of_closures : set_of_closures) = + match set_of_closures with + | { function_decls; free_vars; specialised_args} -> + let funs ppf = + Variable.Map.iter (print_function_declaration ppf) + in + let vars ppf = + Variable.Map.iter (fun id v -> + fprintf ppf "@ %a -rename-> %a" + Variable.print id print_specialised_to v) + in + let spec ppf spec_args = + if not (Variable.Map.is_empty spec_args) + then begin + fprintf ppf "@ "; + Variable.Map.iter (fun id (spec_to : specialised_to) -> + fprintf ppf "@ %a := %a" + Variable.print id print_specialised_to spec_to) + spec_args + end + in + fprintf ppf "@[<2>(set_of_closures id=%a@ %a@ @[<2>free_vars={%a@ }@]@ \ + @[<2>specialised_args={%a})@]@ \ + @[<2>direct_call_surrogates=%a@]@ \ + @[<2>set_of_closures_origin=%a@]@]]" + Set_of_closures_id.print function_decls.set_of_closures_id + funs function_decls.funs + vars free_vars + spec specialised_args + (Variable.Map.print Variable.print) + set_of_closures.direct_call_surrogates + Set_of_closures_origin.print function_decls.set_of_closures_origin + +and print_const ppf (c : const) = + match c with + | Int n -> fprintf ppf "%i" n + | Char c -> fprintf ppf "%C" c + | Const_pointer n -> fprintf ppf "%ia" n + +let print_function_declarations ppf (fd : function_declarations) = + let funs ppf = + Variable.Map.iter (print_function_declaration ppf) + in + fprintf ppf "@[<2>(%a)(origin = %a)@]" funs fd.funs + Set_of_closures_origin.print fd.set_of_closures_origin + +let print ppf flam = + fprintf ppf "%a@." lam flam + +let print_function_declaration ppf (var, decl) = + print_function_declaration ppf var decl + +let print_constant_defining_value ppf (const : constant_defining_value) = + match const with + | Allocated_const const -> + fprintf ppf "(Allocated_const %a)" Allocated_const.print const + | Block (tag, []) -> fprintf ppf "(Atom (tag %d))" (Tag.to_int tag) + | Block (tag, fields) -> + let print_field ppf (field : constant_defining_value_block_field) = + match field with + | Symbol symbol -> Symbol.print ppf symbol + | Const const -> print_const ppf const + in + let print_fields ppf = + List.iter (fprintf ppf "@ %a" print_field) + in + fprintf ppf "(Block (tag %d, %a))" (Tag.to_int tag) + print_fields fields + | Set_of_closures set_of_closures -> + fprintf ppf "@[<2>(Set_of_closures (@ %a))@]" print_set_of_closures + set_of_closures + | Project_closure (set_of_closures, closure_id) -> + fprintf ppf "(Project_closure (%a, %a))" Symbol.print set_of_closures + Closure_id.print closure_id + +let rec print_program_body ppf (program : program_body) = + let symbol_binding ppf (symbol, constant_defining_value) = + fprintf ppf "@[<2>(%a@ %a)@]" + Symbol.print symbol + print_constant_defining_value constant_defining_value + in + match program with + | Let_symbol (symbol, constant_defining_value, body) -> + let rec extract acc (ul : program_body) = + match ul with + | Let_symbol (symbol, constant_defining_value, body) -> + extract ((symbol, constant_defining_value) :: acc) body + | _ -> + List.rev acc, ul + in + let defs, program = extract [symbol, constant_defining_value] body in + fprintf ppf + "@[<2>let_symbol@ @[%a@]@]@." + (Format.pp_print_list symbol_binding) defs; + print_program_body ppf program + | Let_rec_symbol (defs, program) -> + fprintf ppf + "@[<2>let_rec_symbol@ @[%a@]@]@." + (Format.pp_print_list symbol_binding) defs; + print_program_body ppf program + | Initialize_symbol (symbol, tag, fields, program) -> + fprintf ppf "@[<2>initialize_symbol@ (@[<2>%a@ %a@ %a@])@]@." + Symbol.print symbol + Tag.print tag + (Format.pp_print_list lam) fields; + print_program_body ppf program + | Effect (expr, program) -> + fprintf ppf "@[<2>effect@ %a@]@." + lam expr; + print_program_body ppf program; + | End root -> fprintf ppf "End %a" Symbol.print root + +let print_program ppf program = + Symbol.Set.iter (fun symbol -> + fprintf ppf "@[import_symbol@ %a@]@." Symbol.print symbol) + program.imported_symbols; + print_program_body ppf program.program_body + +let rec variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument + ?ignore_uses_in_project_var ~all_used_variables tree = + match tree with + | Var var -> Variable.Set.singleton var + | _ -> + let free = ref Variable.Set.empty in + let bound = ref Variable.Set.empty in + let free_variables ids = free := Variable.Set.union ids !free in + let free_variable fv = free := Variable.Set.add fv !free in + let bound_variable id = bound := Variable.Set.add id !bound in + (* N.B. This function assumes that all bound identifiers are distinct. *) + let rec aux (flam : t) : unit = + match flam with + | Var var -> free_variable var + | Apply { func; args; kind = _; dbg = _} -> + begin match ignore_uses_as_callee with + | None -> free_variable func + | Some () -> () + end; + begin match ignore_uses_as_argument with + | None -> List.iter free_variable args + | Some () -> () + end + | Let { var; free_vars_of_defining_expr; free_vars_of_body; + defining_expr; body; _ } -> + bound_variable var; + if all_used_variables + || Option.is_some ignore_uses_as_callee + || Option.is_some ignore_uses_as_argument + || Option.is_some ignore_uses_in_project_var + then begin + (* In these cases we can't benefit from the pre-computed free + variable sets. *) + free_variables + (variables_usage_named ?ignore_uses_in_project_var + ?ignore_uses_as_callee ?ignore_uses_as_argument + ~all_used_variables defining_expr); + aux body + end else begin + free_variables free_vars_of_defining_expr; + free_variables free_vars_of_body + end + | Let_mutable { initial_value = var; body; _ } -> + free_variable var; + aux body + | Let_rec (bindings, body) -> + List.iter (fun (var, defining_expr) -> + bound_variable var; + free_variables + (variables_usage_named ?ignore_uses_in_project_var + ~all_used_variables defining_expr)) + bindings; + aux body + | Switch (scrutinee, switch) -> + free_variable scrutinee; + List.iter (fun (_, e) -> aux e) switch.consts; + List.iter (fun (_, e) -> aux e) switch.blocks; + Misc.may aux switch.failaction + | String_switch (scrutinee, cases, failaction) -> + free_variable scrutinee; + List.iter (fun (_, e) -> aux e) cases; + Misc.may aux failaction + | Static_raise (_, es) -> + List.iter free_variable es + | Static_catch (_, vars, e1, e2) -> + List.iter bound_variable vars; + aux e1; + aux e2 + | Try_with (e1, var, e2) -> + aux e1; + bound_variable var; + aux e2 + | If_then_else (var, e1, e2) -> + free_variable var; + aux e1; + aux e2 + | While (e1, e2) -> + aux e1; + aux e2 + | For { bound_var; from_value; to_value; direction = _; body; } -> + bound_variable bound_var; + free_variable from_value; + free_variable to_value; + aux body + | Assign { being_assigned = _; new_value; } -> + free_variable new_value + | Send { kind = _; meth; obj; args; dbg = _ } -> + free_variable meth; + free_variable obj; + List.iter free_variable args; + | Proved_unreachable -> () + in + aux tree; + if all_used_variables then + !free + else + Variable.Set.diff !free !bound + +and variables_usage_named ?ignore_uses_in_project_var + ?ignore_uses_as_callee ?ignore_uses_as_argument + ~all_used_variables named = + let free = ref Variable.Set.empty in + let free_variable fv = free := Variable.Set.add fv !free in + begin match named with + | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field _ -> () + | Set_of_closures { free_vars; specialised_args; _ } -> + (* Sets of closures are, well, closed---except for the free variable and + specialised argument lists, which may identify variables currently in + scope outside of the closure. *) + Variable.Map.iter (fun _ (renamed_to : specialised_to) -> + (* We don't need to do anything with [renamed_to.projectee.var], if + it is present, since it would only be another free variable + in the same set of closures. *) + free_variable renamed_to.var) + free_vars; + Variable.Map.iter (fun _ (spec_to : specialised_to) -> + (* We don't need to do anything with [spec_to.projectee.var], if + it is present, since it would only be another specialised arg + in the same set of closures. *) + free_variable spec_to.var) + specialised_args + | Project_closure { set_of_closures; closure_id = _ } -> + free_variable set_of_closures + | Project_var { closure; closure_id = _; var = _ } -> + begin match ignore_uses_in_project_var with + | None -> free_variable closure + | Some () -> () + end + | Move_within_set_of_closures { closure; start_from = _; move_to = _ } -> + free_variable closure + | Prim (_, args, _) -> List.iter free_variable args + | Expr flam -> + free := Variable.Set.union + (variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument + ~all_used_variables flam) !free + end; + !free + +let free_variables ?ignore_uses_as_callee ?ignore_uses_as_argument + ?ignore_uses_in_project_var tree = + variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument + ?ignore_uses_in_project_var ~all_used_variables:false tree + +let free_variables_named ?ignore_uses_in_project_var named = + variables_usage_named ?ignore_uses_in_project_var + ~all_used_variables:false named + +let used_variables ?ignore_uses_as_callee ?ignore_uses_as_argument + ?ignore_uses_in_project_var tree = + variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument + ?ignore_uses_in_project_var ~all_used_variables:true tree + +let used_variables_named ?ignore_uses_in_project_var named = + variables_usage_named ?ignore_uses_in_project_var + ~all_used_variables:true named + +let create_let var defining_expr body : t = + begin match !Clflags.dump_flambda_let with + | None -> () + | Some stamp -> + Variable.debug_when_stamp_matches var ~stamp ~f:(fun () -> + Printf.eprintf "Creation of [Let] with stamp %d:\n%s\n%!" + stamp + (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int))) + end; + let defining_expr, free_vars_of_defining_expr = + match defining_expr with + | Expr (Let { var = var1; defining_expr; body = Var var2; + free_vars_of_defining_expr; _ }) when Variable.equal var1 var2 -> + defining_expr, free_vars_of_defining_expr + | _ -> defining_expr, free_variables_named defining_expr + in + Let { + var; + defining_expr; + body; + free_vars_of_defining_expr; + free_vars_of_body = free_variables body; + } + +let map_defining_expr_of_let let_expr ~f = + let defining_expr = f let_expr.defining_expr in + if defining_expr == let_expr.defining_expr then + Let let_expr + else + let free_vars_of_defining_expr = + free_variables_named defining_expr + in + Let { + var = let_expr.var; + defining_expr; + body = let_expr.body; + free_vars_of_defining_expr; + free_vars_of_body = let_expr.free_vars_of_body; + } + +let iter_lets t ~for_defining_expr ~for_last_body ~for_each_let = + let rec loop (t : t) = + match t with + | Let { var; defining_expr; body; _ } -> + for_each_let t; + for_defining_expr var defining_expr; + loop body + | t -> + for_last_body t + in + loop t + +let map_lets t ~for_defining_expr ~for_last_body ~after_rebuild = + let rec loop (t : t) ~rev_lets = + match t with + | Let { var; defining_expr; body; _ } -> + let new_defining_expr = + for_defining_expr var defining_expr + in + let original = + if new_defining_expr == defining_expr then + Some t + else + None + in + let rev_lets = (var, new_defining_expr, original) :: rev_lets in + loop body ~rev_lets + | t -> + let last_body = for_last_body t in + (* As soon as we see a change, we have to rebuild that [Let] and every + outer one. *) + let seen_change = ref (not (last_body == t)) in + List.fold_left (fun t (var, defining_expr, original) -> + let let_expr = + match original with + | Some original when not !seen_change -> original + | Some _ | None -> + seen_change := true; + create_let var defining_expr t + in + let new_let = after_rebuild let_expr in + if not (new_let == let_expr) then begin + seen_change := true + end; + new_let) + last_body + rev_lets + in + loop t ~rev_lets:[] + +(** CR-someday lwhite: Why not use two functions? *) +type maybe_named = + | Is_expr of t + | Is_named of named + +let iter_general ~toplevel f f_named maybe_named = + let rec aux (t : t) = + match t with + | Let _ -> + iter_lets t + ~for_defining_expr:(fun _var named -> aux_named named) + ~for_last_body:aux + ~for_each_let:f + | _ -> + f t; + match t with + | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable + | Static_raise _ -> () + | Let _ -> assert false + | Let_mutable { body; _ } -> + aux body + | Let_rec (defs, body) -> + List.iter (fun (_,l) -> aux_named l) defs; + aux body + | Try_with (f1,_,f2) + | While (f1,f2) + | Static_catch (_,_,f1,f2) -> + aux f1; aux f2 + | For { body; _ } -> aux body + | If_then_else (_, f1, f2) -> + aux f1; aux f2 + | Switch (_, sw) -> + List.iter (fun (_,l) -> aux l) sw.consts; + List.iter (fun (_,l) -> aux l) sw.blocks; + Misc.may aux sw.failaction + | String_switch (_, sw, def) -> + List.iter (fun (_,l) -> aux l) sw; + Misc.may aux def + and aux_named (named : named) = + f_named named; + match named with + | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field _ + | Project_closure _ | Project_var _ | Move_within_set_of_closures _ + | Prim _ -> () + | Set_of_closures ({ function_decls = funcs; free_vars = _; + specialised_args = _}) -> + if not toplevel then begin + Variable.Map.iter (fun _ (decl : function_declaration) -> + aux decl.body) + funcs.funs + end + | Expr flam -> aux flam + in + match maybe_named with + | Is_expr expr -> aux expr + | Is_named named -> aux_named named + +module With_free_variables = struct + type 'a t = + | Expr : expr * Variable.Set.t -> expr t + | Named : named * Variable.Set.t -> named t + + let of_defining_expr_of_let let_expr = + Named (let_expr.defining_expr, let_expr.free_vars_of_defining_expr) + + let of_body_of_let let_expr = + Expr (let_expr.body, let_expr.free_vars_of_body) + + let of_expr expr = + Expr (expr, free_variables expr) + + let of_named named = + Named (named, free_variables_named named) + + let create_let_reusing_defining_expr var (t : named t) body = + match t with + | Named (defining_expr, free_vars_of_defining_expr) -> + Let { + var; + defining_expr; + body; + free_vars_of_defining_expr; + free_vars_of_body = free_variables body; + } + + let create_let_reusing_body var defining_expr (t : expr t) = + match t with + | Expr (body, free_vars_of_body) -> + Let { + var; + defining_expr; + body; + free_vars_of_defining_expr = free_variables_named defining_expr; + free_vars_of_body; + } + + let create_let_reusing_both var (t1 : named t) (t2 : expr t) = + match t1, t2 with + | Named (defining_expr, free_vars_of_defining_expr), + Expr (body, free_vars_of_body) -> + Let { + var; + defining_expr; + body; + free_vars_of_defining_expr; + free_vars_of_body; + } + + let expr (t : expr t) = + match t with + | Expr (expr, free_vars) -> Named (Expr expr, free_vars) + + let contents (type a) (t : a t) : a = + match t with + | Expr (expr, _) -> expr + | Named (named, _) -> named + + let free_variables (type a) (t : a t) = + match t with + | Expr (_, free_vars) -> free_vars + | Named (_, free_vars) -> free_vars +end + +let fold_lets_option + t ~init + ~(for_defining_expr:('a -> Variable.t -> named -> 'a * Variable.t * named)) + ~for_last_body + ~(filter_defining_expr:('b -> Variable.t -> named -> Variable.Set.t -> + 'b * Variable.t * named option)) = + let finish ~last_body ~acc ~rev_lets = + let module W = With_free_variables in + let acc, t = + List.fold_left (fun (acc, t) (var, defining_expr) -> + let free_vars_of_body = W.free_variables t in + let acc, var, defining_expr = + filter_defining_expr acc var defining_expr free_vars_of_body + in + match defining_expr with + | None -> acc, t + | Some defining_expr -> + let let_expr = + W.create_let_reusing_body var defining_expr t + in + acc, W.of_expr let_expr) + (acc, W.of_expr last_body) + rev_lets + in + W.contents t, acc + in + let rec loop (t : t) ~acc ~rev_lets = + match t with + | Let { var; defining_expr; body; _ } -> + let acc, var, defining_expr = + for_defining_expr acc var defining_expr + in + let rev_lets = (var, defining_expr) :: rev_lets in + loop body ~acc ~rev_lets + | t -> + let last_body, acc = for_last_body acc t in + finish ~last_body ~acc ~rev_lets + in + loop t ~acc:init ~rev_lets:[] + +let free_symbols_helper symbols (named : named) = + match named with + | Symbol symbol + | Read_symbol_field (symbol, _) -> symbols := Symbol.Set.add symbol !symbols + | Set_of_closures set_of_closures -> + Variable.Map.iter (fun _ (function_decl : function_declaration) -> + symbols := Symbol.Set.union function_decl.free_symbols !symbols) + set_of_closures.function_decls.funs + | _ -> () + +let free_symbols expr = + let symbols = ref Symbol.Set.empty in + iter_general ~toplevel:true + (fun (_ : t) -> ()) + (fun (named : named) -> free_symbols_helper symbols named) + (Is_expr expr); + !symbols + +let free_symbols_named named = + let symbols = ref Symbol.Set.empty in + iter_general ~toplevel:true + (fun (_ : t) -> ()) + (fun (named : named) -> free_symbols_helper symbols named) + (Is_named named); + !symbols + +let free_symbols_allocated_constant_helper symbols + (const : constant_defining_value) = + match const with + | Allocated_const _ -> () + | Block (_, fields) -> + List.iter + (function + | (Symbol s : constant_defining_value_block_field) -> + symbols := Symbol.Set.add s !symbols + | (Const _ : constant_defining_value_block_field) -> ()) + fields + | Set_of_closures set_of_closures -> + symbols := Symbol.Set.union !symbols + (free_symbols_named (Set_of_closures set_of_closures)) + | Project_closure (s, _) -> + symbols := Symbol.Set.add s !symbols + +let free_symbols_program (program : program) = + let symbols = ref Symbol.Set.empty in + let rec loop (program : program_body) = + match program with + | Let_symbol (_, const, program) -> + free_symbols_allocated_constant_helper symbols const; + loop program + | Let_rec_symbol (defs, program) -> + List.iter (fun (_, const) -> + free_symbols_allocated_constant_helper symbols const) + defs; + loop program + | Initialize_symbol (_, _, fields, program) -> + List.iter (fun field -> + symbols := Symbol.Set.union !symbols (free_symbols field)) + fields; + loop program + | Effect (expr, program) -> + symbols := Symbol.Set.union !symbols (free_symbols expr); + loop program + | End symbol -> symbols := Symbol.Set.add symbol !symbols + in + (* Note that there is no need to count the [imported_symbols]. *) + loop program.program_body; + !symbols + +let update_body_of_function_declaration (func_decl: function_declaration) + ~body : function_declaration = + { closure_origin = func_decl.closure_origin; + params = func_decl.params; + body; + free_variables = free_variables body; + free_symbols = free_symbols body; + stub = func_decl.stub; + dbg = func_decl.dbg; + inline = func_decl.inline; + specialise = func_decl.specialise; + is_a_functor = func_decl.is_a_functor; + } + +let update_function_decl's_params_and_body + (func_decl : function_declaration) ~params ~body = + { closure_origin = func_decl.closure_origin; + params; + body; + free_variables = free_variables body; + free_symbols = free_symbols body; + stub = func_decl.stub; + dbg = func_decl.dbg; + inline = func_decl.inline; + specialise = func_decl.specialise; + is_a_functor = func_decl.is_a_functor; + } + + +let create_function_declaration ~params ~body ~stub ~dbg + ~(inline : Lambda.inline_attribute) + ~(specialise : Lambda.specialise_attribute) ~is_a_functor + ~closure_origin + : function_declaration = + begin match stub, inline with + | true, (Never_inline | Default_inline) + | false, (Never_inline | Default_inline | Always_inline | Unroll _) -> () + | true, (Always_inline | Unroll _) -> + Misc.fatal_errorf + "Stubs may not be annotated as [Always_inline] or [Unroll]: %a" + print body + end; + begin match stub, specialise with + | true, (Never_specialise | Default_specialise) + | false, (Never_specialise | Default_specialise | Always_specialise) -> () + | true, Always_specialise -> + Misc.fatal_errorf + "Stubs may not be annotated as [Always_specialise]: %a" + print body + end; + { closure_origin; + params; + body; + free_variables = free_variables body; + free_symbols = free_symbols body; + stub; + dbg; + inline; + specialise; + is_a_functor; + } + +let update_function_declaration fun_decl ~params ~body = + let free_variables = free_variables body in + let free_symbols = free_symbols body in + { fun_decl with params; body; free_variables; free_symbols } + +let create_function_declarations ~is_classic_mode ~funs = + let compilation_unit = Compilation_unit.get_current_exn () in + let set_of_closures_id = Set_of_closures_id.create compilation_unit in + let set_of_closures_origin = + Set_of_closures_origin.create set_of_closures_id + in + { is_classic_mode; + set_of_closures_id; + set_of_closures_origin; + funs; + } + +let create_function_declarations_with_origin + ~is_classic_mode ~funs ~set_of_closures_origin = + let compilation_unit = Compilation_unit.get_current_exn () in + let set_of_closures_id = Set_of_closures_id.create compilation_unit in + { is_classic_mode; + set_of_closures_id; + set_of_closures_origin; + funs; + } + +let update_function_declarations function_decls ~funs = + let is_classic_mode = function_decls.is_classic_mode in + let compilation_unit = Compilation_unit.get_current_exn () in + let set_of_closures_id = Set_of_closures_id.create compilation_unit in + let set_of_closures_origin = function_decls.set_of_closures_origin in + { is_classic_mode; + set_of_closures_id; + set_of_closures_origin; + funs; + } + +let create_function_declarations_with_closures_origin + ~is_classic_mode ~funs ~set_of_closures_origin = + let compilation_unit = Compilation_unit.get_current_exn () in + let set_of_closures_id = Set_of_closures_id.create compilation_unit in + { is_classic_mode; + set_of_closures_id; + set_of_closures_origin; + funs + } + +let import_function_declarations_for_pack function_decls + import_set_of_closures_id import_set_of_closures_origin = + let is_classic_mode = function_decls.is_classic_mode in + let set_of_closures_id = + import_set_of_closures_id function_decls.set_of_closures_id + in + let set_of_closures_origin = + import_set_of_closures_origin function_decls.set_of_closures_origin + in + let funs = function_decls.funs in + { is_classic_mode; + set_of_closures_id; + set_of_closures_origin; + funs; + } + +let create_set_of_closures ~function_decls ~free_vars ~specialised_args + ~direct_call_surrogates = + if !Clflags.flambda_invariant_checks then begin + let all_fun_vars = Variable.Map.keys function_decls.funs in + let expected_free_vars = + Variable.Map.fold (fun _fun_var function_decl expected_free_vars -> + let free_vars = + Variable.Set.diff function_decl.free_variables + (Variable.Set.union (Parameter.Set.vars function_decl.params) + all_fun_vars) + in + Variable.Set.union free_vars expected_free_vars) + function_decls.funs + Variable.Set.empty + in + (* CR-soon pchambart: We do not seem to be able to maintain the + invariant that if a variable is not used inside the closure, it + is not used outside either. This would be a nice property for + better dead code elimination during inline_and_simplify, but it + is not obvious how to ensure that. + + This would be true when the function is known never to have + been inlined. + + Note that something like that may maybe enforcable in + inline_and_simplify, but there is no way to do that on other + passes. + + mshinwell: see CR in Flambda_invariants about this too + *) + let free_vars_domain = Variable.Map.keys free_vars in + if not (Variable.Set.subset expected_free_vars free_vars_domain) then begin + Misc.fatal_errorf "create_set_of_closures: [free_vars] mapping of \ + variables bound by the closure(s) is wrong. (Must map at least \ + %a but only maps %a.)@ \nfunction_decls:@ %a" + Variable.Set.print expected_free_vars + Variable.Set.print free_vars_domain + print_function_declarations function_decls + end; + let all_params = + Variable.Map.fold (fun _fun_var function_decl all_params -> + Variable.Set.union (Parameter.Set.vars function_decl.params) + all_params) + function_decls.funs + Variable.Set.empty + in + let spec_args_domain = Variable.Map.keys specialised_args in + if not (Variable.Set.subset spec_args_domain all_params) then begin + Misc.fatal_errorf "create_set_of_closures: [specialised_args] \ + maps variable(s) that are not parameters of the given function \ + declarations. specialised_args domain=%a all_params=%a \n\ + function_decls:@ %a" + Variable.Set.print spec_args_domain + Variable.Set.print all_params + print_function_declarations function_decls + end + end; + { function_decls; + free_vars; + specialised_args; + direct_call_surrogates; + } + +let used_params function_decl = + Variable.Set.filter + (fun param -> Variable.Set.mem param function_decl.free_variables) + (Parameter.Set.vars function_decl.params) + +let compare_const (c1:const) (c2:const) = + match c1, c2 with + | Int i1, Int i2 -> compare i1 i2 + | Char i1, Char i2 -> Char.compare i1 i2 + | Const_pointer i1, Const_pointer i2 -> compare i1 i2 + | Int _, (Char _ | Const_pointer _) -> -1 + | (Char _ | Const_pointer _), Int _ -> 1 + | Char _, Const_pointer _ -> -1 + | Const_pointer _, Char _ -> 1 + +let compare_constant_defining_value_block_field + (c1:constant_defining_value_block_field) + (c2:constant_defining_value_block_field) = + match c1, c2 with + | Symbol s1, Symbol s2 -> Symbol.compare s1 s2 + | Const c1, Const c2 -> compare_const c1 c2 + | Symbol _, Const _ -> -1 + | Const _, Symbol _ -> 1 + +module Constant_defining_value = struct + type t = constant_defining_value + + include Identifiable.Make (struct + type nonrec t = t + + let compare (t1 : t) (t2 : t) = + match t1, t2 with + | Allocated_const c1, Allocated_const c2 -> + Allocated_const.compare c1 c2 + | Block (tag1, fields1), Block (tag2, fields2) -> + let c = Tag.compare tag1 tag2 in + if c <> 0 then c + else + Misc.Stdlib.List.compare compare_constant_defining_value_block_field + fields1 fields2 + | Set_of_closures set1, Set_of_closures set2 -> + Set_of_closures_id.compare set1.function_decls.set_of_closures_id + set2.function_decls.set_of_closures_id + | Project_closure (set1, closure_id1), + Project_closure (set2, closure_id2) -> + let c = Symbol.compare set1 set2 in + if c <> 0 then c + else Closure_id.compare closure_id1 closure_id2 + | Allocated_const _, Block _ -> -1 + | Allocated_const _, Set_of_closures _ -> -1 + | Allocated_const _, Project_closure _ -> -1 + | Block _, Allocated_const _ -> 1 + | Block _, Set_of_closures _ -> -1 + | Block _, Project_closure _ -> -1 + | Set_of_closures _, Allocated_const _ -> 1 + | Set_of_closures _, Block _ -> 1 + | Set_of_closures _, Project_closure _ -> -1 + | Project_closure _, Allocated_const _ -> 1 + | Project_closure _, Block _ -> 1 + | Project_closure _, Set_of_closures _ -> 1 + + let equal t1 t2 = + t1 == t2 || compare t1 t2 = 0 + + let hash = Hashtbl.hash + + let print = print_constant_defining_value + + let output o v = + output_string o (Format.asprintf "%a" print v) + end) +end + +let equal_call_kind (call_kind1 : call_kind) (call_kind2 : call_kind) = + match call_kind1, call_kind2 with + | Indirect, Indirect -> true + | Direct cid1, Direct cid2 -> Closure_id.equal cid1 cid2 + | (Indirect | Direct _), _ -> false + +let equal_specialised_to (spec_to1 : specialised_to) + (spec_to2 : specialised_to) = + Variable.equal spec_to1.var spec_to2.var + && begin + match spec_to1.projection, spec_to2.projection with + | None, None -> true + | Some _, None | None, Some _ -> false + | Some proj1, Some proj2 -> Projection.equal proj1 proj2 + end + +let compare_project_var = Projection.compare_project_var +let compare_project_closure = Projection.compare_project_closure +let compare_move_within_set_of_closures = + Projection.compare_move_within_set_of_closures diff --git a/middle_end/flambda/flambda.mli b/middle_end/flambda/flambda.mli new file mode 100644 index 00000000..325c15ee --- /dev/null +++ b/middle_end/flambda/flambda.mli @@ -0,0 +1,713 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Intermediate language used for tree-based analysis and optimization. *) + +(** Whether the callee in a function application is known at compile time. *) +type call_kind = + | Indirect + | Direct of Closure_id.t + +(** Simple constants. ("Structured constants" are rewritten to invocations + of [Pmakeblock] so that they easily take part in optimizations.) *) +type const = + | Int of int + | Char of char + (** [Char] is kept separate from [Int] to improve printing *) + | Const_pointer of int + (** [Const_pointer] is an immediate value of a type whose values may be + boxed (typically a variant type with both constant and non-constant + constructors). *) + +(** The application of a function to a list of arguments. *) +type apply = { + (* CR-soon mshinwell: rename func -> callee, and + lhs_of_application -> callee *) + func : Variable.t; + args : Variable.t list; + kind : call_kind; + dbg : Debuginfo.t; + inline : Lambda.inline_attribute; + (** Instructions from the source code as to whether the callee should + be inlined. *) + specialise : Lambda.specialise_attribute; + (** Instructions from the source code as to whether the callee should + be specialised. *) +} + +(** The update of a mutable variable. Mutable variables are distinct from + immutable variables in Flambda. *) +type assign = { + being_assigned : Mutable_variable.t; + new_value : Variable.t; +} + +(** The invocation of a method. *) +type send = { + kind : Lambda.meth_kind; + meth : Variable.t; + obj : Variable.t; + args : Variable.t list; + dbg : Debuginfo.t; +} + +(** For details on these types, see projection.mli. *) +type project_closure = Projection.project_closure +type move_within_set_of_closures = Projection.move_within_set_of_closures +type project_var = Projection.project_var + +(** See [free_vars] and [specialised_args], below. *) +(* CR-someday mshinwell: move to separate module and make [Identifiable]. + (Or maybe nearly Identifiable; having a special map that enforces invariants + might be good.) *) +type specialised_to = { + var : Variable.t; + (** The "outer variable". *) + projection : Projection.t option; + (** The [projecting_from] value (see projection.mli) of any [projection] + must be another free variable or specialised argument (depending on + whether this record type is involved in [free_vars] or + [specialised_args] respectively) in the same set of closures. + As such, this field describes a relation of projections between + either the [free_vars] or the [specialised_args]. *) +} + +(** Flambda terms are partitioned in a pseudo-ANF manner; many terms are + required to be [let]-bound. This in particular ensures there is always + a variable name for an expression that may be lifted out (for example + if it is found to be constant). + Note: All bound variables in Flambda terms must be distinct. + [Flambda_invariants] verifies this. *) +type t = + | Var of Variable.t + | Let of let_expr + | Let_mutable of let_mutable + | Let_rec of (Variable.t * named) list * t + (** CR-someday lwhite: give Let_rec the same fields as Let. *) + | Apply of apply + | Send of send + | Assign of assign + | If_then_else of Variable.t * t * t + | Switch of Variable.t * switch + | String_switch of Variable.t * (string * t) list * t option + (** Restrictions on [Lambda.Lstringswitch] also apply to [String_switch]. *) + | Static_raise of Static_exception.t * Variable.t list + | Static_catch of Static_exception.t * Variable.t list * t * t + | Try_with of t * Variable.t * t + | While of t * t + | For of for_loop + | Proved_unreachable + +(** Values of type [named] will always be [let]-bound to a [Variable.t]. *) +and named = + | Symbol of Symbol.t + | Const of const + | Allocated_const of Allocated_const.t + | Read_mutable of Mutable_variable.t + | Read_symbol_field of Symbol.t * int + (** During the lifting of [let] bindings to [program] constructions after + closure conversion, we generate symbols and their corresponding + definitions (which may or may not be constant), together with field + accesses to such symbols. We would like it to be the case that such + field accesses are simplified to the relevant component of the + symbol concerned. (The rationale is to generate efficient code and + share constants as expected: see e.g. tests/asmcomp/staticalloc.ml.) + The components of the symbol would be identified by other symbols. + This sort of access pattern is feasible because the top-level structure + of symbols is statically allocated and fixed at compile time. + It may seem that [Prim (Pfield, ...)] expressions could be used to + perform the field accesses. However for simplicity, to avoid having to + keep track of properties of individual fields of blocks, + [Inconstant_idents] never deems a [Prim (Pfield, ...)] expression to be + constant. This would in general prevent field accesses to symbols from + being simplified in the way we would like, since [Lift_constants] would + not assign new symbols (i.e. the things we would like to simplify to) + to the various projections from the symbols in question. + To circumvent this problem we use [Read_symbol_field] when generating + projections from the top level of symbols. Owing to the properties of + symbols described above, such expressions may be eligible for declaration + as constant by [Inconstant_idents] (and thus themselves lifted to another + symbol), without any further complication. + [Read_symbol_field] may only be used when the definition of the symbol + is in scope in the [program]. For external unresolved symbols, [Pfield] + may still be used; it will be changed to [Read_symbol_field] by + [Inline_and_simplify] when (and if) the symbol is imported. *) + | Set_of_closures of set_of_closures + | Project_closure of project_closure + | Move_within_set_of_closures of move_within_set_of_closures + | Project_var of project_var + | Prim of Clambda_primitives.primitive * Variable.t list * Debuginfo.t + | Expr of t (** ANF escape hatch. *) + +(* CR-someday mshinwell: use [letcont]-style construct to remove e.g. + [While] and [For]. *) +(* CR-someday mshinwell: try to produce a tighter definition of a "switch" + (and translate to that earlier) so that middle- and back-end code for + these can be reduced. *) +(* CR-someday mshinwell: remove [Expr], but to do this easily would probably + require a continuation-binding construct. *) +(* CR-someday mshinwell: Since we lack expression identifiers on every term, + we should probably introduce [Mutable_var] into [named] if we introduce + more complicated analyses on these in the future. Alternatively, maybe + consider removing mutable variables altogether. *) + +and let_expr = private { + var : Variable.t; + defining_expr : named; + body : t; + (* CR-someday mshinwell: we could consider having these be keys into some + kind of global cache, to reduce memory usage. *) + free_vars_of_defining_expr : Variable.Set.t; + (** A cache of the free variables in the defining expression of the [let]. *) + free_vars_of_body : Variable.Set.t; + (** A cache of the free variables of the body of the [let]. This is an + important optimization. *) +} + +and let_mutable = { + var : Mutable_variable.t; + initial_value : Variable.t; + contents_kind : Lambda.value_kind; + body : t; +} + +(** The representation of a set of function declarations (possibly mutually + recursive). Such a set encapsulates the declarations themselves, + information about their defining environment, and information used + specifically for optimization. + Before a function can be applied it must be "projected" from a set of + closures to yield a "closure". This is done using [Project_closure] + (see above). Given a closure, not only can it be applied, but information + about its defining environment can be retrieved (using [Project_var], + see above). + At runtime, a [set_of_closures] corresponds to an OCaml value with tag + [Closure_tag] (possibly with inline [Infix_tag](s)). As an optimization, + an operation ([Move_within_set_of_closures]) is provided (see above) + which enables one closure within a set to be located given another + closure in the same set. This avoids keeping a pointer to the whole set + of closures alive when compiling, for example, mutually-recursive + functions. +*) +and set_of_closures = private { + function_decls : function_declarations; + (* CR-soon mshinwell: consider renaming [free_vars]. Also, it's still really + confusing which side of this map to use when. "Vars bound by the + closure" is the domain. + Another example of when this is confusing: + let bound_vars_approx = + Variable.Map.map (Env.find_approx env) set.free_vars + in + in [Build_export_info]. *) + (* CR-soon mshinwell: I'd like to arrange these maps so that it's impossible + to put invalid projection information into them (in particular, so that + we enforce that the relation stays within the domain of the map). *) + free_vars : specialised_to Variable.Map.t; + (** Mapping from all variables free in the body of the [function_decls] to + variables in scope at the definition point of the [set_of_closures]. + The domain of this map is sometimes known as the "variables bound by + the closure". *) + specialised_args : specialised_to Variable.Map.t; + (** Parameters whose corresponding arguments are known to always alias a + particular value. These are the only parameters that may, during + [Inline_and_simplify], have non-unknown approximations. + + An argument may only be specialised to a variable in the scope of the + corresponding set of closures declaration. Usually, that variable + itself also appears in the position of the specialised argument at + all call sites of the function. However it may also be the case (for + example in code generated as a result of [Augment_specialised_args]) + that the various call sites of such a function have differing + variables in the position of the specialised argument. This is + permissible *so long as it is certain they all alias the same value*. + Great care must be taken in transformations that result in this + situation since there are no invariant checks for correctness. + + As an example, supposing all call sites of f are represented here: + [let x = ... in + let f a b c = ... in + let y = ... in + f x y 1; + f x y 1] + the specialised arguments of f can (but does not necessarily) contain + the association [a] -> [x], but cannot contain [b] -> [y] because [f] + is not in the scope of [y]. If f were the recursive function + [let rec f a b c = f a 1 2 in], [a] -> [x] would still be a valid + specialised argument because all recursive calls maintain the invariant. + + This information is used for optimization purposes, if such a binding is + known, it is possible to specialise the body of the function according + to its parameter. This is usually introduced when specialising a + recursive function, for instance. + [let rec map f = function + | [] -> [] + | h :: t -> f h :: map f t + let map_succ l = + let succ x = x + 1 in + map succ l] + [map] can be duplicated in [map_succ] to be specialised for the argument + [f]. This will result in + [let map_succ l = + let succ x = x + 1 in + let rec map f = function + | [] -> [] + | h :: t -> f h :: map f t in + map succ l] + with map having [f] -> [succ] in its [specialised_args] field. + + Specialised argument information for arguments that are used must + never be erased. This ensures that specialised arguments whose + approximations describe closures maintain those approximations, which + is essential to transport the closure freshening information to the + point of use (e.g. a [Project_var] from such an argument). + *) + direct_call_surrogates : Variable.t Variable.Map.t; + (** If [direct_call_surrogates] maps [fun_var1] to [fun_var2] then direct + calls to [fun_var1] should be redirected to [fun_var2]. This is used + to reduce the overhead of transformations that introduce wrapper + functions (which will be inlined at direct call sites, but will + penalise indirect call sites). + [direct_call_surrogates] may not be transitively closed. *) +} + +and function_declarations = private { + is_classic_mode: bool; + (** Indicates whether this [function_declarations] was compiled + with -Oclassic. *) + set_of_closures_id : Set_of_closures_id.t; + (** An identifier (unique across all Flambda trees currently in memory) + of the set of closures associated with this set of function + declarations. *) + set_of_closures_origin : Set_of_closures_origin.t; + (** An identifier of the original set of closures on which this set of + function declarations is based. Used to prevent different + specialisations of the same functions from being inlined/specialised + within each other. *) + funs : function_declaration Variable.Map.t; + (** The function(s) defined by the set of function declarations. The + keys of this map are often referred to in the code as "fun_var"s. *) +} + +and function_declaration = private { + closure_origin: Closure_origin.t; + params : Parameter.t list; + body : t; + (* CR-soon mshinwell: inconsistent naming free_variables/free_vars here and + above *) + free_variables : Variable.Set.t; + (** All variables free in the *body* of the function. For example, a + variable that is bound as one of the function's parameters will still + be included in this set. This field is present as an optimization. *) + free_symbols : Symbol.Set.t; + (** All symbols that occur in the function's body. (Symbols can never be + bound in a function's body; the only thing that binds symbols is the + [program] constructions below.) *) + stub : bool; + (** A stub function is a generated function used to prepare arguments or + return values to allow indirect calls to functions with a special calling + convention. For instance indirect calls to tuplified functions must go + through a stub. Stubs will be unconditionally inlined. *) + dbg : Debuginfo.t; + (** Debug info for the function declaration. *) + inline : Lambda.inline_attribute; + (** Inlining requirements from the source code. *) + specialise : Lambda.specialise_attribute; + (** Specialising requirements from the source code. *) + is_a_functor : bool; + (** Whether the function is known definitively to be a functor. *) +} + +(** Equivalent to the similar type in [Lambda]. *) +and switch = { + numconsts : Numbers.Int.Set.t; (** Integer cases *) + consts : (int * t) list; (** Integer cases *) + numblocks : Numbers.Int.Set.t; (** Number of tag block cases *) + blocks : (int * t) list; (** Tag block cases *) + failaction : t option; (** Action to take if none matched *) +} + +(** Equivalent to the similar type in [Lambda]. *) +and for_loop = { + bound_var : Variable.t; + from_value : Variable.t; + to_value : Variable.t; + direction : Asttypes.direction_flag; + body : t +} + +(** Like a subset of [Flambda.named], except that instead of [Variable.t]s we + have [Symbol.t]s, and everything is a constant (i.e. with a fixed value + known at compile time). Values of this type describe constants that will + be directly assigned to symbols in the object file (see below). *) +and constant_defining_value = + | Allocated_const of Allocated_const.t + (** A single constant. These are never "simple constants" (type [const]) + but instead more complicated constructions. *) + | Block of Tag.t * constant_defining_value_block_field list + (** A pre-allocated block full of constants (either simple constants + or references to other constants, see below). *) + | Set_of_closures of set_of_closures + (** A closed (and thus constant) set of closures. (That is to say, + [free_vars] must be empty.) *) + | Project_closure of Symbol.t * Closure_id.t + (** Selection of one closure from a constant set of closures. + Analogous to the equivalent operation on expressions. *) + +and constant_defining_value_block_field = + | Symbol of Symbol.t + | Const of const + +module Constant_defining_value : + Identifiable.S with type t = constant_defining_value + +type expr = t + +(** A "program" is the contents of one compilation unit. It describes the + various values that are assigned to symbols (and in some cases fields of + such symbols) in the object file. As such, it is closely related to + the compilation of toplevel modules. *) +type program_body = + | Let_symbol of Symbol.t * constant_defining_value * program_body + (** Define the given symbol to have the given constant value. *) + | Let_rec_symbol of (Symbol.t * constant_defining_value) list * program_body + (** As for [Let_symbol], but recursive. This is needed to treat examples + like this, where a constant set of closures is lifted to toplevel: + + let rec f x = f x + + After lifting this produces (in pseudo-Flambda): + + Let_rec_symbol set_of_closures_symbol = + (Set_of_closures { f x -> + let applied_function = Symbol f_closure in + Apply (applied_function, x) }) + and f_closure = Project_closure (set_of_closures_symbol, f) + + Use of [Let_rec_symbol], by virtue of the special handling in + [Inline_and_simplify.define_let_rec_symbol_approx], enables the + approximation of the set of closures to be present in order to + correctly simplify the [Project_closure] construction. (See + [Inline_and_simplify.simplify_project_closure] for that part.) *) + | Initialize_symbol of Symbol.t * Tag.t * t list * program_body + (** Define the given symbol as a constant block of the given size and + tag; but with a possibly non-constant initializer. The initializer + will be executed at most once (from the entry point of the compilation + unit). *) + | Effect of t * program_body + (** Cause the given expression, which may have a side effect, to be + executed. The resulting value is discarded. [Effect] constructions + are never re-ordered. *) + | End of Symbol.t + (** [End] accepts the root symbol: the only symbol that can never be + eliminated. *) + +type program = { + imported_symbols : Symbol.Set.t; + program_body : program_body; +} + +(** Compute the free variables of a term. (This is O(1) for [Let]s). + If [ignore_uses_as_callee], all free variables inside [Apply] expressions + are ignored. Likewise [ignore_uses_in_project_var] for [Project_var] + expressions. +*) +val free_variables + : ?ignore_uses_as_callee:unit + -> ?ignore_uses_as_argument:unit + -> ?ignore_uses_in_project_var:unit + -> t + -> Variable.Set.t + +(** Compute the free variables of a named expression. *) +val free_variables_named + : ?ignore_uses_in_project_var:unit + -> named + -> Variable.Set.t + +(** Compute _all_ variables occurring inside an expression. *) +val used_variables + : ?ignore_uses_as_callee:unit + -> ?ignore_uses_as_argument:unit + -> ?ignore_uses_in_project_var:unit + -> t + -> Variable.Set.t + +(** Compute _all_ variables occurring inside a named expression. *) +val used_variables_named + : ?ignore_uses_in_project_var:unit + -> named + -> Variable.Set.t + +val free_symbols : expr -> Symbol.Set.t + +val free_symbols_named : named -> Symbol.Set.t + +val free_symbols_program : program -> Symbol.Set.t + +(** Used to avoid exceeding the stack limit when handling expressions with + multiple consecutive nested [Let]-expressions. This saves rewriting large + simplification functions in CPS. This function provides for the + rewriting or elimination of expressions during the fold. *) +val fold_lets_option + : t + -> init:'a + -> for_defining_expr:('a -> Variable.t -> named -> 'a * Variable.t * named) + -> for_last_body:('a -> t -> t * 'b) + (* CR-someday mshinwell: consider making [filter_defining_expr] + optional *) + -> filter_defining_expr:('b -> Variable.t -> named -> Variable.Set.t -> + 'b * Variable.t * named option) + -> t * 'b + +(** Like [fold_lets_option], but just a map. *) +val map_lets + : t + -> for_defining_expr:(Variable.t -> named -> named) + -> for_last_body:(t -> t) + -> after_rebuild:(t -> t) + -> t + +(** Like [map_lets], but just an iterator. *) +val iter_lets + : t + -> for_defining_expr:(Variable.t -> named -> unit) + -> for_last_body:(t -> unit) + -> for_each_let:(t -> unit) + -> unit + +(** Creates a [Let] expression. (This computes the free variables of the + defining expression and the body.) *) +val create_let : Variable.t -> named -> t -> t + +(** Apply the specified function [f] to the defining expression of the given + [Let]-expression, returning a new [Let]. *) +val map_defining_expr_of_let : let_expr -> f:(named -> named) -> t + +(** A module for the manipulation of terms where the recomputation of free + variable sets is to be kept to a minimum. *) +module With_free_variables : sig + type 'a t + + (** O(1) time. *) + val of_defining_expr_of_let : let_expr -> named t + + (** O(1) time. *) + val of_body_of_let : let_expr -> expr t + + (** Takes the time required to calculate the free variables of the given + term (proportional to the size of the term, except that the calculation + for [Let] is O(1)). *) + val of_expr : expr -> expr t + + val of_named : named -> named t + + (** Takes the time required to calculate the free variables of the given + [expr]. *) + val create_let_reusing_defining_expr + : Variable.t + -> named t + -> expr + -> expr + + (** Takes the time required to calculate the free variables of the given + [named]. *) + val create_let_reusing_body + : Variable.t + -> named + -> expr t + -> expr + + (** O(1) time. *) + val create_let_reusing_both + : Variable.t + -> named t + -> expr t + -> expr + + (** The equivalent of the [Expr] constructor. *) + val expr : expr t -> named t + + val contents : 'a t -> 'a + + (** O(1) time. *) + val free_variables : _ t -> Variable.Set.t +end + +(** Create a function declaration. This calculates the free variables and + symbols occurring in the specified [body]. *) +val create_function_declaration + : params:Parameter.t list + -> body:t + -> stub:bool + -> dbg:Debuginfo.t + -> inline:Lambda.inline_attribute + -> specialise:Lambda.specialise_attribute + -> is_a_functor:bool + -> closure_origin:Closure_origin.t + -> function_declaration + +(** Create a function declaration based on another function declaration *) +val update_function_declaration + : function_declaration + -> params:Parameter.t list + -> body:t + -> function_declaration + +(** Create a set of function declarations given the individual declarations. *) +val create_function_declarations + : is_classic_mode:bool + -> funs:function_declaration Variable.Map.t + -> function_declarations + +(** Create a set of function declarations with a given set of closures + origin. *) +val create_function_declarations_with_origin + : is_classic_mode:bool + -> funs:function_declaration Variable.Map.t + -> set_of_closures_origin:Set_of_closures_origin.t + -> function_declarations + +(** Change only the code of a function declaration. *) +val update_body_of_function_declaration + : function_declaration + -> body:expr + -> function_declaration + +(** Change only the code and parameters of a function declaration. *) +(* CR-soon mshinwell: rename this to match new update function above *) +val update_function_decl's_params_and_body + : function_declaration + -> params:Parameter.t list + -> body:expr + -> function_declaration + +(** Create a set of function declarations based on another set of function + declarations. *) +val update_function_declarations + : function_declarations + -> funs:function_declaration Variable.Map.t + -> function_declarations + +val create_function_declarations_with_closures_origin + : is_classic_mode: bool + -> funs:function_declaration Variable.Map.t + -> set_of_closures_origin:Set_of_closures_origin.t + -> function_declarations + +val import_function_declarations_for_pack + : function_declarations + -> (Set_of_closures_id.t -> Set_of_closures_id.t) + -> (Set_of_closures_origin.t -> Set_of_closures_origin.t) + -> function_declarations + +(** Create a set of closures. Checks are made to ensure that [free_vars] + and [specialised_args] are reasonable. *) +val create_set_of_closures + : function_decls:function_declarations + -> free_vars:specialised_to Variable.Map.t + -> specialised_args:specialised_to Variable.Map.t + -> direct_call_surrogates:Variable.t Variable.Map.t + -> set_of_closures + +(** Given a function declaration, find which of its parameters (if any) + are used in the body. *) +val used_params : function_declaration -> Variable.Set.t + +type maybe_named = + | Is_expr of t + | Is_named of named + +(** This function is designed for the internal use of [Flambda_iterators]. + See that module for iterators to be used over Flambda terms. *) +val iter_general + : toplevel:bool + -> (t -> unit) + -> (named -> unit) + -> maybe_named + -> unit + +val print : Format.formatter -> t -> unit + +val print_named : Format.formatter -> named -> unit + +val print_program : Format.formatter -> program -> unit + +val print_const : Format.formatter -> const -> unit + +val print_constant_defining_value + : Format.formatter + -> constant_defining_value + -> unit + +val print_function_declaration + : Format.formatter + -> Variable.t * function_declaration + -> unit + +val print_function_declarations + : Format.formatter + -> function_declarations + -> unit + +val print_project_closure + : Format.formatter + -> project_closure + -> unit + +val print_move_within_set_of_closures + : Format.formatter + -> move_within_set_of_closures + -> unit + +val print_project_var + : Format.formatter + -> project_var + -> unit + +val print_set_of_closures + : Format.formatter + -> set_of_closures + -> unit + +val print_specialised_to + : Format.formatter + -> specialised_to + -> unit + +val equal_call_kind + : call_kind + -> call_kind + -> bool + +val equal_specialised_to + : specialised_to + -> specialised_to + -> bool + +val compare_const + : const + -> const + -> int + +val compare_project_var : project_var -> project_var -> int + +val compare_move_within_set_of_closures + : move_within_set_of_closures + -> move_within_set_of_closures + -> int + +val compare_project_closure : project_closure -> project_closure -> int diff --git a/middle_end/flambda/flambda_invariants.ml b/middle_end/flambda/flambda_invariants.ml new file mode 100644 index 00000000..250a2e9a --- /dev/null +++ b/middle_end/flambda/flambda_invariants.ml @@ -0,0 +1,800 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type flambda_kind = + | Normal + | Lifted + +(* Explicit "ignore" functions. We name every pattern variable, avoiding + underscores, to try to avoid accidentally failing to handle (for example) + a particular variable. + We also avoid explicit record field access during the checking functions, + preferring instead to use exhaustive record matches. +*) +(* CR-someday pchambart: for sum types, we should probably add an exhaustive + pattern in ignores functions to be reminded if a type change *) +let already_added_bound_variable_to_env (_ : Variable.t) = () +let will_traverse_named_expression_later (_ : Flambda.named) = () +let ignore_variable (_ : Variable.t) = () +let ignore_call_kind (_ : Flambda.call_kind) = () +let ignore_debuginfo (_ : Debuginfo.t) = () +let ignore_meth_kind (_ : Lambda.meth_kind) = () +let ignore_int (_ : int) = () +let ignore_int_set (_ : Numbers.Int.Set.t) = () +let ignore_bool (_ : bool) = () +let ignore_string (_ : string) = () +let ignore_static_exception (_ : Static_exception.t) = () +let ignore_direction_flag (_ : Asttypes.direction_flag) = () +let ignore_primitive ( _ : Clambda_primitives.primitive) = () +let ignore_const (_ : Flambda.const) = () +let ignore_allocated_const (_ : Allocated_const.t) = () +let ignore_set_of_closures_id (_ : Set_of_closures_id.t) = () +let ignore_set_of_closures_origin (_ : Set_of_closures_origin.t) = () +let ignore_closure_id (_ : Closure_id.t) = () +let ignore_var_within_closure (_ : Var_within_closure.t) = () +let ignore_tag (_ : Tag.t) = () +let ignore_inline_attribute (_ : Lambda.inline_attribute) = () +let ignore_specialise_attribute (_ : Lambda.specialise_attribute) = () +let ignore_value_kind (_ : Lambda.value_kind) = () + +exception Binding_occurrence_not_from_current_compilation_unit of Variable.t +exception Mutable_binding_occurrence_not_from_current_compilation_unit of + Mutable_variable.t +exception Binding_occurrence_of_variable_already_bound of Variable.t +exception Binding_occurrence_of_mutable_variable_already_bound of + Mutable_variable.t +exception Binding_occurrence_of_symbol_already_bound of Symbol.t +exception Unbound_variable of Variable.t +exception Unbound_mutable_variable of Mutable_variable.t +exception Unbound_symbol of Symbol.t +exception Vars_in_function_body_not_bound_by_closure_or_params of + Variable.Set.t * Flambda.set_of_closures * Variable.t +exception Function_decls_have_overlapping_parameters of Variable.Set.t +exception Specialised_arg_that_is_not_a_parameter of Variable.t +exception Projection_must_be_a_free_var of Projection.t +exception Projection_must_be_a_specialised_arg of Projection.t +exception Free_variables_set_is_lying of + Variable.t * Variable.Set.t * Variable.Set.t * Flambda.function_declaration +exception Set_of_closures_free_vars_map_has_wrong_range of Variable.Set.t +exception Static_exception_not_caught of Static_exception.t +exception Static_exception_caught_in_multiple_places of Static_exception.t +exception Sequential_logical_operator_primitives_must_be_expanded of + Clambda_primitives.primitive +exception Var_within_closure_bound_multiple_times of Var_within_closure.t +exception Declared_closure_from_another_unit of Compilation_unit.t +exception Closure_id_is_bound_multiple_times of Closure_id.t +exception Set_of_closures_id_is_bound_multiple_times of Set_of_closures_id.t +exception Unbound_closure_ids of Closure_id.Set.t +exception Unbound_vars_within_closures of Var_within_closure.Set.t +exception Move_to_a_closure_not_in_the_free_variables + of Variable.t * Variable.Set.t + +exception Flambda_invariants_failed + +(* CR-someday mshinwell: We should make "direct applications should not have + overapplication" be an invariant throughout. At the moment I think this is + only true after [Inline_and_simplify] has split overapplications. *) + +(* CR-someday mshinwell: What about checks for shadowed variables and + symbols? *) + +let variable_and_symbol_invariants (program : Flambda.program) = + let all_declared_variables = ref Variable.Set.empty in + let declare_variable var = + if Variable.Set.mem var !all_declared_variables then + raise (Binding_occurrence_of_variable_already_bound var); + all_declared_variables := Variable.Set.add var !all_declared_variables + in + let declare_variables vars = + Variable.Set.iter declare_variable vars + in + let all_declared_mutable_variables = ref Mutable_variable.Set.empty in + let declare_mutable_variable mut_var = + if Mutable_variable.Set.mem mut_var !all_declared_mutable_variables then + raise (Binding_occurrence_of_mutable_variable_already_bound mut_var); + all_declared_mutable_variables := + Mutable_variable.Set.add mut_var !all_declared_mutable_variables + in + let add_binding_occurrence (var_env, mut_var_env, sym_env) var = + let compilation_unit = Compilation_unit.get_current_exn () in + if not (Variable.in_compilation_unit var compilation_unit) then + raise (Binding_occurrence_not_from_current_compilation_unit var); + declare_variable var; + Variable.Set.add var var_env, mut_var_env, sym_env + in + let add_mutable_binding_occurrence (var_env, mut_var_env, sym_env) mut_var = + let compilation_unit = Compilation_unit.get_current_exn () in + if not (Mutable_variable.in_compilation_unit mut_var compilation_unit) then + raise (Mutable_binding_occurrence_not_from_current_compilation_unit + mut_var); + declare_mutable_variable mut_var; + var_env, Mutable_variable.Set.add mut_var mut_var_env, sym_env + in + let add_binding_occurrence_of_symbol (var_env, mut_var_env, sym_env) sym = + if Symbol.Set.mem sym sym_env then + raise (Binding_occurrence_of_symbol_already_bound sym) + else + var_env, mut_var_env, Symbol.Set.add sym sym_env + in + let add_binding_occurrences env vars = + List.fold_left (fun env var -> add_binding_occurrence env var) env vars + in + let check_variable_is_bound (var_env, _, _) var = + if not (Variable.Set.mem var var_env) then raise (Unbound_variable var) + in + let check_symbol_is_bound (_, _, sym_env) sym = + if not (Symbol.Set.mem sym sym_env) then raise (Unbound_symbol sym) + in + let check_variables_are_bound env vars = + List.iter (check_variable_is_bound env) vars + in + let check_mutable_variable_is_bound (_, mut_var_env, _) mut_var = + if not (Mutable_variable.Set.mem mut_var mut_var_env) then begin + raise (Unbound_mutable_variable mut_var) + end + in + let rec loop env (flam : Flambda.t) = + match flam with + (* Expressions that can bind [Variable.t]s: *) + | Let { var; defining_expr; body; _ } -> + loop_named env defining_expr; + loop (add_binding_occurrence env var) body + | Let_mutable { var = mut_var; initial_value = var; + body; contents_kind } -> + ignore_value_kind contents_kind; + check_variable_is_bound env var; + loop (add_mutable_binding_occurrence env mut_var) body + | Let_rec (defs, body) -> + let env = + List.fold_left (fun env (var, def) -> + will_traverse_named_expression_later def; + add_binding_occurrence env var) + env defs + in + List.iter (fun (var, def) -> + already_added_bound_variable_to_env var; + loop_named env def) defs; + loop env body + | For { bound_var; from_value; to_value; direction; body; } -> + ignore_direction_flag direction; + check_variable_is_bound env from_value; + check_variable_is_bound env to_value; + loop (add_binding_occurrence env bound_var) body + | Static_catch (static_exn, vars, body, handler) -> + ignore_static_exception static_exn; + loop env body; + loop (add_binding_occurrences env vars) handler + | Try_with (body, var, handler) -> + loop env body; + loop (add_binding_occurrence env var) handler + (* Everything else: *) + | Var var -> check_variable_is_bound env var + | Apply { func; args; kind; dbg; inline; specialise; } -> + check_variable_is_bound env func; + check_variables_are_bound env args; + ignore_call_kind kind; + ignore_debuginfo dbg; + ignore_inline_attribute inline; + ignore_specialise_attribute specialise + | Assign { being_assigned; new_value; } -> + check_mutable_variable_is_bound env being_assigned; + check_variable_is_bound env new_value + | Send { kind; meth; obj; args; dbg; } -> + ignore_meth_kind kind; + check_variable_is_bound env meth; + check_variable_is_bound env obj; + check_variables_are_bound env args; + ignore_debuginfo dbg + | If_then_else (cond, ifso, ifnot) -> + check_variable_is_bound env cond; + loop env ifso; + loop env ifnot + | Switch (arg, { numconsts; consts; numblocks; blocks; failaction; }) -> + check_variable_is_bound env arg; + ignore_int_set numconsts; + ignore_int_set numblocks; + List.iter (fun (n, e) -> + ignore_int n; + loop env e) + (consts @ blocks); + Misc.may (loop env) failaction + | String_switch (arg, cases, e_opt) -> + check_variable_is_bound env arg; + List.iter (fun (label, case) -> + ignore_string label; + loop env case) + cases; + Misc.may (loop env) e_opt + | Static_raise (static_exn, es) -> + ignore_static_exception static_exn; + List.iter (check_variable_is_bound env) es + | While (e1, e2) -> + loop env e1; + loop env e2 + | Proved_unreachable -> () + and loop_named env (named : Flambda.named) = + match named with + | Symbol symbol -> check_symbol_is_bound env symbol + | Const const -> ignore_const const + | Allocated_const const -> ignore_allocated_const const + | Read_mutable mut_var -> + check_mutable_variable_is_bound env mut_var + | Read_symbol_field (symbol, index) -> + check_symbol_is_bound env symbol; + assert (index >= 0) (* CR-someday mshinwell: add proper error *) + | Set_of_closures set_of_closures -> + loop_set_of_closures env set_of_closures + | Project_closure { set_of_closures; closure_id; } -> + check_variable_is_bound env set_of_closures; + ignore_closure_id closure_id + | Move_within_set_of_closures { closure; start_from; move_to; } -> + check_variable_is_bound env closure; + ignore_closure_id start_from; + ignore_closure_id move_to; + | Project_var { closure; closure_id; var; } -> + check_variable_is_bound env closure; + ignore_closure_id closure_id; + ignore_var_within_closure var + | Prim (prim, args, dbg) -> + ignore_primitive prim; + check_variables_are_bound env args; + ignore_debuginfo dbg + | Expr expr -> + loop env expr + and loop_set_of_closures env + ({ Flambda.function_decls; free_vars; specialised_args; + direct_call_surrogates = _; } as set_of_closures) = + (* CR-soon mshinwell: check [direct_call_surrogates] *) + let { Flambda. is_classic_mode; + set_of_closures_id; set_of_closures_origin; funs; } = + function_decls + in + ignore (is_classic_mode : bool); + ignore_set_of_closures_id set_of_closures_id; + ignore_set_of_closures_origin set_of_closures_origin; + let functions_in_closure = Variable.Map.keys funs in + let variables_in_closure = + Variable.Map.fold (fun var (var_in_closure : Flambda.specialised_to) + variables_in_closure -> + (* [var] may occur in the body, but will effectively be renamed + to [var_in_closure], so the latter is what we check to make + sure it's bound. *) + ignore_variable var; + check_variable_is_bound env var_in_closure.var; + Variable.Set.add var variables_in_closure) + free_vars Variable.Set.empty + in + let all_params, all_free_vars = + Variable.Map.fold (fun fun_var function_decl acc -> + let all_params, all_free_vars = acc in + (* CR-soon mshinwell: check function_decl.all_symbols *) + let { Flambda.params; body; free_variables; stub; dbg; _ } = + function_decl + in + assert (Variable.Set.mem fun_var functions_in_closure); + ignore_bool stub; + ignore_debuginfo dbg; + (* Check that [free_variables], which is only present as an + optimization, is not lying. *) + let free_variables' = Flambda.free_variables body in + if not (Variable.Set.subset free_variables' free_variables) then + raise (Free_variables_set_is_lying (fun_var, + free_variables, free_variables', function_decl)); + (* Check that every variable free in the body of the function is + bound by either the set of closures or the parameter list. *) + let acceptable_free_variables = + Variable.Set.union + (Variable.Set.union variables_in_closure functions_in_closure) + (Parameter.Set.vars params) + in + let bad = + Variable.Set.diff free_variables acceptable_free_variables + in + if not (Variable.Set.is_empty bad) then begin + raise (Vars_in_function_body_not_bound_by_closure_or_params + (bad, set_of_closures, fun_var)) + end; + (* Check that parameters are unique across all functions in the + declaration. *) + let old_all_params_size = Variable.Set.cardinal all_params in + let params = Parameter.Set.vars params in + let params_size = Variable.Set.cardinal params in + let all_params = Variable.Set.union all_params params in + let all_params_size = Variable.Set.cardinal all_params in + if all_params_size <> old_all_params_size + params_size then begin + raise (Function_decls_have_overlapping_parameters all_params) + end; + (* Check that parameters and function variables are not + bound somewhere else in the program *) + declare_variables params; + declare_variable fun_var; + (* Check that the body of the functions is correctly structured *) + let body_env = + let (var_env, _, sym_env) = env in + let var_env = + Variable.Set.fold (fun var -> Variable.Set.add var) + free_variables var_env + in + (* Mutable variables cannot be captured by closures *) + let mut_env = Mutable_variable.Set.empty in + (var_env, mut_env, sym_env) + in + loop body_env body; + all_params, Variable.Set.union free_variables all_free_vars) + funs (Variable.Set.empty, Variable.Set.empty) + in + (* CR-soon pchambart: This is not a property that we can certainly + ensure. + If the function get inlined, it is possible for the inlined version + to still use that variable. To be able to ensure that, we need to + also ensure that the inlined version will certainly be transformed + in a same way that can drop the dependency. + mshinwell: This should get some thought after the first release to + decide for sure what to do. *) + (* Check that the free variables rewriting map in the set of closures + does not contain variables in its domain that are not actually free + variables of any of the function bodies. *) + let bad_free_vars = + Variable.Set.diff (Variable.Map.keys free_vars) all_free_vars + in +(* + if not (Variable.Set.is_empty bad_free_vars) then begin + raise (Set_of_closures_free_vars_map_has_wrong_range bad_free_vars) + end; +*) + (* CR-someday pchambart: Ignore it to avoid the warning: get rid of that + when the case is settled *) + ignore (Set_of_closures_free_vars_map_has_wrong_range bad_free_vars); + (* Check that free variables are not bound somewhere + else in the program *) + declare_variables (Variable.Map.keys free_vars); + (* Check that every "specialised arg" is a parameter of one of the + functions being declared, and that the variable to which the + parameter is being specialised is bound. *) + Variable.Map.iter (fun _inner_var + (specialised_to : Flambda.specialised_to) -> + check_variable_is_bound env specialised_to.var; + match specialised_to.projection with + | None -> () + | Some projection -> + let projecting_from = Projection.projecting_from projection in + if not (Variable.Map.mem projecting_from free_vars) + then begin + raise (Projection_must_be_a_free_var projection) + end) + free_vars; + Variable.Map.iter (fun being_specialised + (specialised_to : Flambda.specialised_to) -> + if not (Variable.Set.mem being_specialised all_params) then begin + raise (Specialised_arg_that_is_not_a_parameter being_specialised) + end; + check_variable_is_bound env specialised_to.var; + match specialised_to.projection with + | None -> () + | Some projection -> + let projecting_from = Projection.projecting_from projection in + if not (Variable.Map.mem projecting_from specialised_args) + then begin + raise (Projection_must_be_a_specialised_arg projection) + end) + specialised_args + in + let loop_constant_defining_value env + (const : Flambda.constant_defining_value) = + match const with + | Flambda.Allocated_const c -> + ignore_allocated_const c + | Flambda.Block (tag,fields) -> + ignore_tag tag; + List.iter (fun (fields : Flambda.constant_defining_value_block_field) -> + match fields with + | Const c -> ignore_const c + | Symbol s -> check_symbol_is_bound env s) + fields + | Flambda.Set_of_closures set_of_closures -> + loop_set_of_closures env set_of_closures; + (* Constant set of closures must not have free variables *) + if not (Variable.Map.is_empty set_of_closures.free_vars) then + assert false; (* TODO: correct error *) + if not (Variable.Map.is_empty set_of_closures.specialised_args) then + assert false; (* TODO: correct error *) + | Flambda.Project_closure (symbol,closure_id) -> + ignore_closure_id closure_id; + check_symbol_is_bound env symbol + in + let rec loop_program_body env (program : Flambda.program_body) = + match program with + | Let_rec_symbol (defs, program) -> + let env = + List.fold_left (fun env (symbol, _) -> + add_binding_occurrence_of_symbol env symbol) + env defs + in + List.iter (fun (_, def) -> + loop_constant_defining_value env def) + defs; + loop_program_body env program + | Let_symbol (symbol, def, program) -> + loop_constant_defining_value env def; + let env = add_binding_occurrence_of_symbol env symbol in + loop_program_body env program + | Initialize_symbol (symbol, _tag, fields, program) -> + List.iter (loop env) fields; + let env = add_binding_occurrence_of_symbol env symbol in + loop_program_body env program + | Effect (expr, program) -> + loop env expr; + loop_program_body env program + | End root -> + check_symbol_is_bound env root + in + let env = + Symbol.Set.fold (fun symbol env -> + add_binding_occurrence_of_symbol env symbol) + program.imported_symbols + (Variable.Set.empty, Mutable_variable.Set.empty, Symbol.Set.empty) + in + loop_program_body env program.program_body + +let primitive_invariants flam = + Flambda_iterators.iter_named (function + | Prim (prim, _, _) -> + begin match prim with + | Psequand | Psequor -> + raise (Sequential_logical_operator_primitives_must_be_expanded prim) + | _ -> () + end + | _ -> ()) + flam + +let declared_var_within_closure (flam:Flambda.program) = + let bound = ref Var_within_closure.Set.empty in + let bound_multiple_times = ref None in + let add_and_check var = + if Var_within_closure.Set.mem var !bound then begin + bound_multiple_times := Some var + end; + bound := Var_within_closure.Set.add var !bound + in + Flambda_iterators.iter_on_set_of_closures_of_program + ~f:(fun ~constant:_ { Flambda. free_vars; _ } -> + Variable.Map.iter (fun id _ -> + let var = Var_within_closure.wrap id in + add_and_check var) + free_vars) + flam; + !bound, !bound_multiple_times + +let no_var_within_closure_is_bound_multiple_times (flam:Flambda.program) = + match declared_var_within_closure flam with + | _, Some var -> raise (Var_within_closure_bound_multiple_times var) + | _, None -> () + +let every_declared_closure_is_from_current_compilation_unit flam = + let current_compilation_unit = Compilation_unit.get_current_exn () in + Flambda_iterators.iter_on_sets_of_closures (fun + { Flambda. function_decls; _ } -> + let compilation_unit = + Set_of_closures_id.get_compilation_unit + function_decls.set_of_closures_id + in + if not (Compilation_unit.equal compilation_unit current_compilation_unit) + then raise (Declared_closure_from_another_unit compilation_unit)) + flam + +let declared_closure_ids program = + let bound = ref Closure_id.Set.empty in + let bound_multiple_times = ref None in + let add_and_check var = + if Closure_id.Set.mem var !bound + then bound_multiple_times := Some var; + bound := Closure_id.Set.add var !bound + in + Flambda_iterators.iter_on_set_of_closures_of_program program + ~f:(fun ~constant:_ { Flambda. function_decls; _; } -> + Variable.Map.iter (fun id _ -> + let var = Closure_id.wrap id in + add_and_check var) + function_decls.funs); + !bound, !bound_multiple_times + +let no_closure_id_is_bound_multiple_times program = + match declared_closure_ids program with + | _, Some closure_id -> + raise (Closure_id_is_bound_multiple_times closure_id) + | _, None -> () + +let declared_set_of_closures_ids program = + let bound = ref Set_of_closures_id.Set.empty in + let bound_multiple_times = ref None in + let add_and_check var = + if Set_of_closures_id.Set.mem var !bound + then bound_multiple_times := Some var; + bound := Set_of_closures_id.Set.add var !bound + in + Flambda_iterators.iter_on_set_of_closures_of_program program + ~f:(fun ~constant:_ { Flambda. function_decls; _; } -> + add_and_check function_decls.set_of_closures_id); + !bound, !bound_multiple_times + +let no_set_of_closures_id_is_bound_multiple_times program = + match declared_set_of_closures_ids program with + | _, Some set_of_closures_id -> + raise (Set_of_closures_id_is_bound_multiple_times set_of_closures_id) + | _, None -> () + +let used_closure_ids (program:Flambda.program) = + let used = ref Closure_id.Set.empty in + let f (flam : Flambda.named) = + match flam with + | Project_closure { closure_id; _} -> + used := Closure_id.Set.add closure_id !used; + | Move_within_set_of_closures { closure = _; start_from; move_to; } -> + used := Closure_id.Set.add start_from !used; + used := Closure_id.Set.add move_to !used + | Project_var { closure = _; closure_id; var = _ } -> + used := Closure_id.Set.add closure_id !used + | Set_of_closures _ | Symbol _ | Const _ | Allocated_const _ + | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _ -> () + in + (* CR-someday pchambart: check closure_ids of constant_defining_values' + project_closures *) + Flambda_iterators.iter_named_of_program ~f program; + !used + +let used_vars_within_closures (flam:Flambda.program) = + let used = ref Var_within_closure.Set.empty in + let f (flam : Flambda.named) = + match flam with + | Project_var { closure = _; closure_id = _; var; } -> + used := Var_within_closure.Set.add var !used + | _ -> () + in + Flambda_iterators.iter_named_of_program ~f flam; + !used + +let every_used_function_from_current_compilation_unit_is_declared + (program:Flambda.program) = + let current_compilation_unit = Compilation_unit.get_current_exn () in + let declared, _ = declared_closure_ids program in + let used = used_closure_ids program in + let used_from_current_unit = + Closure_id.Set.filter (fun cu -> + Closure_id.in_compilation_unit cu current_compilation_unit) + used + in + let counter_examples = + Closure_id.Set.diff used_from_current_unit declared + in + if Closure_id.Set.is_empty counter_examples + then () + else raise (Unbound_closure_ids counter_examples) + +let every_used_var_within_closure_from_current_compilation_unit_is_declared + (flam:Flambda.program) = + let current_compilation_unit = Compilation_unit.get_current_exn () in + let declared, _ = declared_var_within_closure flam in + let used = used_vars_within_closures flam in + let used_from_current_unit = + Var_within_closure.Set.filter (fun cu -> + Var_within_closure.in_compilation_unit cu current_compilation_unit) + used + in + let counter_examples = + Var_within_closure.Set.diff used_from_current_unit declared in + if Var_within_closure.Set.is_empty counter_examples + then () + else raise (Unbound_vars_within_closures counter_examples) + +let every_static_exception_is_caught flam = + let check env (flam : Flambda.t) = + match flam with + | Static_raise (exn, _) -> + if not (Static_exception.Set.mem exn env) + then raise (Static_exception_not_caught exn) + | _ -> () + in + let rec loop env (flam : Flambda.t) = + match flam with + | Static_catch (i, _, body, handler) -> + let env = Static_exception.Set.add i env in + loop env handler; + loop env body + | exp -> + check env exp; + Flambda_iterators.apply_on_subexpressions (loop env) + (fun (_ : Flambda.named) -> ()) exp + in + loop Static_exception.Set.empty flam + +let every_static_exception_is_caught_at_a_single_position flam = + let caught = ref Static_exception.Set.empty in + let f (flam : Flambda.t) = + match flam with + | Static_catch (i, _, _body, _handler) -> + if Static_exception.Set.mem i !caught then + raise (Static_exception_caught_in_multiple_places i); + caught := Static_exception.Set.add i !caught + | _ -> () + in + Flambda_iterators.iter f (fun (_ : Flambda.named) -> ()) flam + +let _every_move_within_set_of_closures_is_to_a_function_in_the_free_vars + program = + let moves = ref Closure_id.Map.empty in + Flambda_iterators.iter_named_of_program program + ~f:(function + | Move_within_set_of_closures { start_from; move_to; _ } -> + let moved_to = + try Closure_id.Map.find start_from !moves with + | Not_found -> Closure_id.Set.empty + in + moves := + Closure_id.Map.add start_from + (Closure_id.Set.add move_to moved_to) + !moves + | _ -> ()); + Flambda_iterators.iter_on_set_of_closures_of_program program + ~f:(fun ~constant:_ { Flambda.function_decls = { funs; _ }; _ } -> + Variable.Map.iter (fun fun_var { Flambda.free_variables; _ } -> + match Closure_id.Map.find (Closure_id.wrap fun_var) !moves with + | exception Not_found -> () + | moved_to -> + let missing_dependencies = + Variable.Set.diff (Closure_id.unwrap_set moved_to) + free_variables + in + if not (Variable.Set.is_empty missing_dependencies) then + raise (Move_to_a_closure_not_in_the_free_variables + (fun_var, missing_dependencies))) + funs) + +let check_exn ?(kind=Normal) (flam:Flambda.program) = + ignore kind; + try + variable_and_symbol_invariants flam; + no_closure_id_is_bound_multiple_times flam; + no_set_of_closures_id_is_bound_multiple_times flam; + every_used_function_from_current_compilation_unit_is_declared flam; + no_var_within_closure_is_bound_multiple_times flam; + every_used_var_within_closure_from_current_compilation_unit_is_declared + flam; + (* CR-soon pchambart: This invariant is not maintained. It should be + either relaxed or reformulated. Currently, it is safe to disable it as + the potential related errors would result in fatal errors, not in + miscompilations *) + (* every_move_within_set_of_closures_is_to_a_function_in_the_free_vars + flam; *) + Flambda_iterators.iter_exprs_at_toplevel_of_program flam ~f:(fun flam -> + primitive_invariants flam; + every_static_exception_is_caught flam; + every_static_exception_is_caught_at_a_single_position flam; + every_declared_closure_is_from_current_compilation_unit flam) + with exn -> begin + (* CR-someday split printing code into its own function *) + begin match exn with + | Binding_occurrence_not_from_current_compilation_unit var -> + Format.eprintf ">> Binding occurrence of variable marked as not being \ + from the current compilation unit: %a" + Variable.print var + | Mutable_binding_occurrence_not_from_current_compilation_unit mut_var -> + Format.eprintf ">> Binding occurrence of mutable variable marked as not \ + being from the current compilation unit: %a" + Mutable_variable.print mut_var + | Binding_occurrence_of_variable_already_bound var -> + Format.eprintf ">> Binding occurrence of variable that was already \ + bound: %a" + Variable.print var + | Binding_occurrence_of_mutable_variable_already_bound mut_var -> + Format.eprintf ">> Binding occurrence of mutable variable that was \ + already bound: %a" + Mutable_variable.print mut_var + | Binding_occurrence_of_symbol_already_bound sym -> + Format.eprintf ">> Binding occurrence of symbol that was already \ + bound: %a" + Symbol.print sym + | Unbound_variable var -> + Format.eprintf ">> Unbound variable: %a" Variable.print var + | Unbound_mutable_variable mut_var -> + Format.eprintf ">> Unbound mutable variable: %a" + Mutable_variable.print mut_var + | Unbound_symbol sym -> + Format.eprintf ">> Unbound symbol: %a %s" + Symbol.print sym + (Printexc.raw_backtrace_to_string (Printexc.get_callstack 100)) + | Vars_in_function_body_not_bound_by_closure_or_params + (vars, set_of_closures, fun_var) -> + Format.eprintf ">> Variable(s) (%a) in the body of a function \ + declaration (fun_var = %a) that is not bound by either the closure \ + or the function's parameter list. Set of closures: %a" + Variable.Set.print vars + Variable.print fun_var + Flambda.print_set_of_closures set_of_closures + | Function_decls_have_overlapping_parameters vars -> + Format.eprintf ">> Function declarations whose parameters overlap: \ + %a" + Variable.Set.print vars + | Specialised_arg_that_is_not_a_parameter var -> + Format.eprintf ">> Variable in [specialised_args] that is not a \ + parameter of any of the function(s) in the corresponding \ + declaration(s): %a" + Variable.print var + | Projection_must_be_a_free_var var -> + Format.eprintf ">> Projection %a in [free_vars] from a variable that is \ + not a (inner) free variable of the set of closures" + Projection.print var + | Projection_must_be_a_specialised_arg var -> + Format.eprintf ">> Projection %a in [specialised_args] from a variable \ + that is not a (inner) specialised argument variable of the set of \ + closures" + Projection.print var + | Free_variables_set_is_lying (var, claimed, calculated, function_decl) -> + Format.eprintf ">> Function declaration whose [free_variables] set (%a) \ + is not a superset of the result of [Flambda.free_variables] \ + applied to the body of the function (%a). Declaration: %a" + Variable.Set.print claimed + Variable.Set.print calculated + Flambda.print_function_declaration (var, function_decl) + | Set_of_closures_free_vars_map_has_wrong_range vars -> + Format.eprintf ">> [free_vars] map in set of closures has in its range \ + variables that are not free variables of the corresponding \ + functions: %a" + Variable.Set.print vars + | Sequential_logical_operator_primitives_must_be_expanded prim -> + Format.eprintf ">> Sequential logical operator primitives must be \ + expanded (see closure_conversion.ml): %a" + Printclambda_primitives.primitive prim + | Var_within_closure_bound_multiple_times var -> + Format.eprintf ">> Variable within a closure is bound multiple times: \ + %a" + Var_within_closure.print var + | Closure_id_is_bound_multiple_times closure_id -> + Format.eprintf ">> Closure ID is bound multiple times: %a" + Closure_id.print closure_id + | Set_of_closures_id_is_bound_multiple_times set_of_closures_id -> + Format.eprintf ">> Set of closures ID is bound multiple times: %a" + Set_of_closures_id.print set_of_closures_id + | Declared_closure_from_another_unit compilation_unit -> + Format.eprintf ">> Closure declared as being from another compilation \ + unit: %a" + Compilation_unit.print compilation_unit + | Unbound_closure_ids closure_ids -> + Format.eprintf ">> Unbound closure ID(s) from the current compilation \ + unit: %a" + Closure_id.Set.print closure_ids + | Unbound_vars_within_closures vars_within_closures -> + Format.eprintf ">> Unbound variable(s) within closure(s) from the \ + current compilation_unit: %a" + Var_within_closure.Set.print vars_within_closures + | Static_exception_not_caught static_exn -> + Format.eprintf ">> Uncaught static exception: %a" + Static_exception.print static_exn + | Static_exception_caught_in_multiple_places static_exn -> + Format.eprintf ">> Static exception caught in multiple places: %a" + Static_exception.print static_exn + | Move_to_a_closure_not_in_the_free_variables (start_from, move_to) -> + Format.eprintf ">> A Move_within_set_of_closures from the closure %a \ + to closures that are not parts of its free variables: %a" + Variable.print start_from + Variable.Set.print move_to + | exn -> raise exn + end; + Format.eprintf "\n@?"; + raise Flambda_invariants_failed + end diff --git a/middle_end/flambda/flambda_invariants.mli b/middle_end/flambda/flambda_invariants.mli new file mode 100644 index 00000000..252578e8 --- /dev/null +++ b/middle_end/flambda/flambda_invariants.mli @@ -0,0 +1,28 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +type flambda_kind = + | Normal + | Lifted + +(** Checking of invariants on Flambda expressions. Raises an exception if + a check fails. *) +val check_exn + : ?kind:flambda_kind + -> Flambda.program + -> unit diff --git a/middle_end/flambda/flambda_iterators.ml b/middle_end/flambda/flambda_iterators.ml new file mode 100644 index 00000000..a69575da --- /dev/null +++ b/middle_end/flambda/flambda_iterators.ml @@ -0,0 +1,808 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let apply_on_subexpressions f f_named (flam : Flambda.t) = + match flam with + | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable + | Static_raise _ -> () + | Let { defining_expr; body; _ } -> + f_named defining_expr; + f body + | Let_mutable { body; _ } -> + f body + | Let_rec (defs, body) -> + List.iter (fun (_,l) -> f_named l) defs; + f body + | Switch (_, sw) -> + List.iter (fun (_,l) -> f l) sw.consts; + List.iter (fun (_,l) -> f l) sw.blocks; + Misc.may f sw.failaction + | String_switch (_, sw, def) -> + List.iter (fun (_,l) -> f l) sw; + Misc.may f def + | Static_catch (_,_,f1,f2) -> + f f1; f f2; + | Try_with (f1,_,f2) -> + f f1; f f2 + | If_then_else (_,f1, f2) -> + f f1;f f2 + | While (f1,f2) -> + f f1; f f2 + | For { body; _ } -> f body + +let rec list_map_sharing f l = + match l with + | [] -> l + | h :: t -> + let new_t = list_map_sharing f t in + let new_h = f h in + if h == new_h && t == new_t then + l + else + new_h :: new_t + +let may_map_sharing f v = + match v with + | None -> v + | Some s -> + let new_s = f s in + if s == new_s then + v + else + Some new_s + +let map_snd_sharing f ((a, b) as cpl) = + let new_b = f a b in + if b == new_b then + cpl + else + (a, new_b) + +let map_subexpressions f f_named (tree:Flambda.t) : Flambda.t = + match tree with + | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable + | Static_raise _ -> tree + | Let { var; defining_expr; body; _ } -> + let new_named = f_named var defining_expr in + let new_body = f body in + if new_named == defining_expr && new_body == body then + tree + else + Flambda.create_let var new_named new_body + | Let_rec (defs, body) -> + let new_defs = + list_map_sharing (map_snd_sharing f_named) defs + in + let new_body = f body in + if new_defs == defs && new_body == body then + tree + else + Let_rec (new_defs, new_body) + | Let_mutable mutable_let -> + let new_body = f mutable_let.body in + if new_body == mutable_let.body then + tree + else + Let_mutable { mutable_let with body = new_body } + | Switch (arg, sw) -> + let aux = map_snd_sharing (fun _ v -> f v) in + let new_consts = list_map_sharing aux sw.consts in + let new_blocks = list_map_sharing aux sw.blocks in + let new_failaction = may_map_sharing f sw.failaction in + if sw.failaction == new_failaction && + new_consts == sw.consts && + new_blocks == sw.blocks then + tree + else + let sw = + { sw with + failaction = new_failaction; + consts = new_consts; + blocks = new_blocks; + } + in + Switch (arg, sw) + | String_switch (arg, sw, def) -> + let new_sw = list_map_sharing (map_snd_sharing (fun _ v -> f v)) sw in + let new_def = may_map_sharing f def in + if sw == new_sw && def == new_def then + tree + else + String_switch(arg, new_sw, new_def) + | Static_catch (i, vars, body, handler) -> + let new_body = f body in + let new_handler = f handler in + if new_body == body && new_handler == handler then + tree + else + Static_catch (i, vars, new_body, new_handler) + | Try_with(body, id, handler) -> + let new_body = f body in + let new_handler = f handler in + if body == new_body && handler == new_handler then + tree + else + Try_with(new_body, id, new_handler) + | If_then_else(arg, ifso, ifnot) -> + let new_ifso = f ifso in + let new_ifnot = f ifnot in + if new_ifso == ifso && new_ifnot == ifnot then + tree + else + If_then_else(arg, new_ifso, new_ifnot) + | While(cond, body) -> + let new_cond = f cond in + let new_body = f body in + if new_cond == cond && new_body == body then + tree + else + While(new_cond, new_body) + | For { bound_var; from_value; to_value; direction; body; } -> + let new_body = f body in + if new_body == body then + tree + else + For { bound_var; from_value; to_value; direction; body = new_body; } + +let iter_general = Flambda.iter_general + +let iter f f_named t = iter_general ~toplevel:false f f_named (Is_expr t) +let iter_expr f t = iter f (fun _ -> ()) t +let iter_on_named f f_named t = + iter_general ~toplevel:false f f_named (Is_named t) +let iter_named f_named t = iter (fun (_ : Flambda.t) -> ()) f_named t +let iter_named_on_named f_named named = + iter_general ~toplevel:false (fun (_ : Flambda.t) -> ()) f_named + (Is_named named) + +let iter_toplevel f f_named t = + iter_general ~toplevel:true f f_named (Is_expr t) +let iter_named_toplevel f f_named named = + iter_general ~toplevel:true f f_named (Is_named named) + +let iter_all_immutable_let_and_let_rec_bindings t ~f = + iter_expr (function + | Let { var; defining_expr; _ } -> f var defining_expr + | Let_rec (defs, _) -> List.iter (fun (var, named) -> f var named) defs + | _ -> ()) + t + +let iter_all_toplevel_immutable_let_and_let_rec_bindings t ~f = + iter_general ~toplevel:true + (function + | Let { var; defining_expr; _ } -> f var defining_expr + | Let_rec (defs, _) -> List.iter (fun (var, named) -> f var named) defs + | _ -> ()) + (fun _ -> ()) + (Is_expr t) + +let iter_on_sets_of_closures f t = + iter_named (function + | Set_of_closures clos -> f clos + | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field _ + | Project_closure _ | Move_within_set_of_closures _ | Project_var _ + | Prim _ | Expr _ -> ()) + t + +let iter_exprs_at_toplevel_of_program (program : Flambda.program) ~f = + let rec loop (program : Flambda.program_body) = + match program with + | Let_symbol (_, Set_of_closures set_of_closures, program) -> + Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) -> + f function_decl.body) + set_of_closures.function_decls.funs; + loop program + | Let_rec_symbol (defs, program) -> + List.iter (function + | (_, Flambda.Set_of_closures set_of_closures) -> + Variable.Map.iter + (fun _ (function_decl : Flambda.function_declaration) -> + f function_decl.body) + set_of_closures.function_decls.funs + | _ -> ()) defs; + loop program + | Let_symbol (_, _, program) -> + loop program + | Initialize_symbol (_, _, fields, program) -> + List.iter f fields; + loop program + | Effect (expr, program) -> + f expr; + loop program + | End _ -> () + in + loop program.program_body + +let iter_named_of_program program ~f = + iter_exprs_at_toplevel_of_program program ~f:(iter_named f) + +let iter_on_set_of_closures_of_program (program : Flambda.program) ~f = + let rec loop (program : Flambda.program_body) = + match program with + | Let_symbol (_, Set_of_closures set_of_closures, program) -> + f ~constant:true set_of_closures; + Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) -> + iter_on_sets_of_closures (f ~constant:false) function_decl.body) + set_of_closures.function_decls.funs; + loop program + | Let_rec_symbol (defs, program) -> + List.iter (function + | (_, Flambda.Set_of_closures set_of_closures) -> + f ~constant:true set_of_closures; + Variable.Map.iter + (fun _ (function_decl : Flambda.function_declaration) -> + iter_on_sets_of_closures (f ~constant:false) function_decl.body) + set_of_closures.function_decls.funs + | _ -> ()) defs; + loop program + | Let_symbol (_, _, program) -> + loop program + | Initialize_symbol (_, _, fields, program) -> + List.iter (iter_on_sets_of_closures (f ~constant:false)) fields; + loop program + | Effect (expr, program) -> + iter_on_sets_of_closures (f ~constant:false) expr; + loop program + | End _ -> () + in + loop program.program_body + +let iter_constant_defining_values_on_program (program : Flambda.program) ~f = + let rec loop (program : Flambda.program_body) = + match program with + | Let_symbol (_, const, program) -> + f const; + loop program + | Let_rec_symbol (defs, program) -> + List.iter (fun (_, const) -> f const) defs; + loop program + | Initialize_symbol (_, _, _, program) -> + loop program + | Effect (_, program) -> + loop program + | End _ -> () + in + loop program.program_body + +let map_general ~toplevel f f_named tree = + let rec aux (tree : Flambda.t) = + match tree with + | Let _ -> + Flambda.map_lets tree ~for_defining_expr:aux_named ~for_last_body:aux + ~after_rebuild:f + | _ -> + let exp : Flambda.t = + match tree with + | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable + | Static_raise _ -> tree + | Let _ -> assert false + | Let_mutable mutable_let -> + let new_body = aux mutable_let.body in + if new_body == mutable_let.body then + tree + else + Let_mutable { mutable_let with body = new_body } + | Let_rec (defs, body) -> + let done_something = ref false in + let defs = + List.map (fun (id, lam) -> + id, aux_named_done_something id lam done_something) + defs + in + let body = aux_done_something body done_something in + if not !done_something then + tree + else + Let_rec (defs, body) + | Switch (arg, sw) -> + let done_something = ref false in + let sw = + { sw with + failaction = + begin match sw.failaction with + | None -> None + | Some failaction -> + Some (aux_done_something failaction done_something) + end; + consts = + List.map (fun (i, v) -> + i, aux_done_something v done_something) + sw.consts; + blocks = + List.map (fun (i, v) -> + i, aux_done_something v done_something) + sw.blocks; + } + in + if not !done_something then + tree + else + Switch (arg, sw) + | String_switch (arg, sw, def) -> + let done_something = ref false in + let sw = + List.map (fun (i, v) -> i, aux_done_something v done_something) sw + in + let def = + match def with + | None -> None + | Some def -> Some (aux_done_something def done_something) + in + if not !done_something then + tree + else + String_switch(arg, sw, def) + | Static_catch (i, vars, body, handler) -> + let new_body = aux body in + let new_handler = aux handler in + if new_body == body && new_handler == handler then + tree + else + Static_catch (i, vars, new_body, new_handler) + | Try_with(body, id, handler) -> + let new_body = aux body in + let new_handler = aux handler in + if new_body == body && new_handler == handler then + tree + else + Try_with (new_body, id, new_handler) + | If_then_else (arg, ifso, ifnot) -> + let new_ifso = aux ifso in + let new_ifnot = aux ifnot in + if new_ifso == ifso && new_ifnot == ifnot then + tree + else + If_then_else (arg, new_ifso, new_ifnot) + | While (cond, body) -> + let new_cond = aux cond in + let new_body = aux body in + if new_cond == cond && new_body == body then + tree + else + While (new_cond, new_body) + | For { bound_var; from_value; to_value; direction; body; } -> + let new_body = aux body in + if new_body == body then + tree + else + For { bound_var; from_value; to_value; direction; + body = new_body; } + in + f exp + and aux_done_something expr done_something = + let new_expr = aux expr in + if not (new_expr == expr) then begin + done_something := true + end; + new_expr + and aux_named (id : Variable.t) (named : Flambda.named) = + let named : Flambda.named = + match named with + | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Project_closure _ | Move_within_set_of_closures _ | Project_var _ + | Prim _ | Read_symbol_field _ -> named + | Set_of_closures ({ function_decls; free_vars; specialised_args; + direct_call_surrogates }) -> + if toplevel then named + else begin + let done_something = ref false in + let funs = + Variable.Map.map (fun (func_decl : Flambda.function_declaration) -> + let new_body = aux func_decl.body in + if new_body == func_decl.body then begin + func_decl + end else begin + done_something := true; + Flambda.update_function_declaration func_decl + ~params:func_decl.params ~body:new_body + end) + function_decls.funs + in + if not !done_something then + named + else + let function_decls = + Flambda.update_function_declarations function_decls ~funs + in + let set_of_closures = + Flambda.create_set_of_closures ~function_decls ~free_vars + ~specialised_args ~direct_call_surrogates + in + Set_of_closures set_of_closures + end + | Expr expr -> + let new_expr = aux expr in + if new_expr == expr then named + else Expr new_expr + in + f_named id named + and aux_named_done_something id named done_something = + let new_named = aux_named id named in + if not (new_named == named) then begin + done_something := true + end; + new_named + in + aux tree + +let iter_apply_on_program program ~f = + iter_exprs_at_toplevel_of_program program ~f:(fun expr -> + iter (function + | Apply apply -> f apply + | _ -> ()) + (fun _ -> ()) + expr) + +let map f f_named tree = + map_general ~toplevel:false f (fun _ n -> f_named n) tree +let map_expr f tree = map f (fun named -> named) tree +let map_named f_named tree = map (fun expr -> expr) f_named tree +let map_named_with_id f_named tree = + map_general ~toplevel:false (fun expr -> expr) f_named tree +let map_toplevel f f_named tree = + map_general ~toplevel:true f (fun _ n -> f_named n) tree +let map_toplevel_expr f_expr tree = + map_toplevel f_expr (fun named -> named) tree +let map_toplevel_named f_named tree = + map_toplevel (fun tree -> tree) f_named tree + +let map_symbols tree ~f = + map_named (function + | (Symbol sym) as named -> + let new_sym = f sym in + if new_sym == sym then + named + else + Symbol new_sym + | ((Read_symbol_field (sym, field)) as named) -> + let new_sym = f sym in + if new_sym == sym then + named + else + Read_symbol_field (new_sym, field) + | (Const _ | Allocated_const _ | Set_of_closures _ | Read_mutable _ + | Project_closure _ | Move_within_set_of_closures _ | Project_var _ + | Prim _ | Expr _) as named -> named) + tree + +let map_symbols_on_set_of_closures + ({ Flambda.function_decls; free_vars; specialised_args; + direct_call_surrogates; } as + set_of_closures) + ~f = + let done_something = ref false in + let funs = + Variable.Map.map (fun (func_decl : Flambda.function_declaration) -> + let body = map_symbols func_decl.body ~f in + if not (body == func_decl.body) then begin + done_something := true; + end; + Flambda.update_function_declaration func_decl + ~params:func_decl.params ~body) + function_decls.funs + in + if not !done_something then + set_of_closures + else + let function_decls = + Flambda.update_function_declarations function_decls ~funs + in + Flambda.create_set_of_closures ~function_decls ~free_vars + ~specialised_args ~direct_call_surrogates + +let map_toplevel_sets_of_closures tree ~f = + map_toplevel_named (function + | (Set_of_closures set_of_closures) as named -> + let new_set_of_closures = f set_of_closures in + if new_set_of_closures == set_of_closures then + named + else + Set_of_closures new_set_of_closures + | (Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field _ + | Project_closure _ | Move_within_set_of_closures _ | Project_var _ + | Prim _ | Expr _) as named -> named) + tree + +let map_apply tree ~f = + map (function + | (Apply apply) as expr -> + let new_apply = f apply in + if new_apply == apply then + expr + else + Apply new_apply + | expr -> expr) + (fun named -> named) + tree + +let map_sets_of_closures tree ~f = + map_named (function + | (Set_of_closures set_of_closures) as named -> + let new_set_of_closures = f set_of_closures in + if new_set_of_closures == set_of_closures then + named + else + Set_of_closures new_set_of_closures + | (Symbol _ | Const _ | Allocated_const _ | Project_closure _ + | Move_within_set_of_closures _ | Project_var _ + | Prim _ | Expr _ | Read_mutable _ + | Read_symbol_field _) as named -> named) + tree + +let map_project_var_to_expr_opt tree ~f = + map_named (function + | (Project_var project_var) as named -> + begin match f project_var with + | None -> named + | Some expr -> Expr expr + end + | (Symbol _ | Const _ | Allocated_const _ + | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ + | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _) + as named -> named) + tree + +let map_project_var_to_named_opt tree ~f = + map_named (function + | (Project_var project_var) as named -> + begin match f project_var with + | None -> named + | Some named -> named + end + | (Symbol _ | Const _ | Allocated_const _ + | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ + | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _) + as named -> named) + tree + +let map_function_bodies (set_of_closures : Flambda.set_of_closures) ~f = + let done_something = ref false in + let funs = + Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> + let new_body = f function_decl.body in + if new_body == function_decl.body then + function_decl + else begin + done_something := true; + Flambda.update_function_declaration function_decl + ~body:new_body ~params:function_decl.params + end) + set_of_closures.function_decls.funs + in + if not !done_something then + set_of_closures + else + let function_decls = + Flambda.update_function_declarations set_of_closures.function_decls ~funs + in + Flambda.create_set_of_closures + ~function_decls + ~free_vars:set_of_closures.free_vars + ~specialised_args:set_of_closures.specialised_args + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + +let map_sets_of_closures_of_program (program : Flambda.program) + ~(f : Flambda.set_of_closures -> Flambda.set_of_closures) = + let rec loop (program : Flambda.program_body) : Flambda.program_body = + let map_constant_set_of_closures (set_of_closures:Flambda.set_of_closures) = + let done_something = ref false in + let function_decls = + let funs = + Variable.Map.map (fun + (function_decl : Flambda.function_declaration) -> + let body = map_sets_of_closures ~f function_decl.body in + if body == function_decl.body then + function_decl + else begin + done_something := true; + Flambda.update_function_declaration function_decl + ~body ~params:function_decl.params + end) + set_of_closures.function_decls.funs + in + if not !done_something then + set_of_closures.function_decls + else + Flambda.update_function_declarations set_of_closures.function_decls + ~funs + in + let new_set_of_closures = f set_of_closures in + if new_set_of_closures == set_of_closures then + set_of_closures + else + Flambda.create_set_of_closures ~function_decls + ~free_vars:set_of_closures.free_vars + ~specialised_args:set_of_closures.specialised_args + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + in + match program with + | Let_symbol (symbol, Set_of_closures set_of_closures, program') -> + let new_set_of_closures = map_constant_set_of_closures set_of_closures in + let new_program' = loop program' in + if new_set_of_closures == set_of_closures + && new_program' == program' then + program + else + Let_symbol (symbol, Set_of_closures new_set_of_closures, new_program') + | Let_symbol (symbol, const, program') -> + let new_program' = loop program' in + if new_program' == program' then + program + else + Let_symbol (symbol, const, new_program') + | Let_rec_symbol (defs, program') -> + let done_something = ref false in + let defs = + List.map (function + | (var, Flambda.Set_of_closures set_of_closures) -> + let new_set_of_closures = + map_constant_set_of_closures set_of_closures + in + if not (new_set_of_closures == set_of_closures) then begin + done_something := true + end; + var, Flambda.Set_of_closures new_set_of_closures + | def -> def) + defs + in + let new_program' = loop program' in + if new_program' == program' && not !done_something then + program + else + Let_rec_symbol (defs, loop program') + | Initialize_symbol (symbol, tag, fields, program') -> + let done_something = ref false in + let fields = + List.map (fun field -> + let new_field = map_sets_of_closures field ~f in + if not (new_field == field) then begin + done_something := true + end; + new_field) + fields + in + let new_program' = loop program' in + if new_program' == program' && not !done_something then + program + else + Initialize_symbol (symbol, tag, fields, new_program') + | Effect (expr, program') -> + let new_expr = map_sets_of_closures expr ~f in + let new_program' = loop program' in + if new_expr == expr && new_program' == program' then + program + else + Effect (new_expr, new_program') + | End _ -> program + in + { program with + program_body = loop program.program_body; + } + +let map_exprs_at_toplevel_of_program (program : Flambda.program) + ~(f : Flambda.t -> Flambda.t) = + let rec loop (program : Flambda.program_body) : Flambda.program_body = + let map_constant_set_of_closures (set_of_closures:Flambda.set_of_closures) = + let done_something = ref false in + let funs = + Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> + let body = f function_decl.body in + if body == function_decl.body then + function_decl + else begin + done_something := true; + Flambda.update_function_declaration function_decl + ~body ~params:function_decl.params + end) + set_of_closures.function_decls.funs + in + if not !done_something then + set_of_closures + else + let function_decls = + Flambda.update_function_declarations set_of_closures.function_decls + ~funs + in + Flambda.create_set_of_closures ~function_decls + ~free_vars:set_of_closures.free_vars + ~specialised_args:set_of_closures.specialised_args + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + in + (* CR-soon mshinwell: code very similar to the above function *) + match program with + | Let_symbol (symbol, Set_of_closures set_of_closures, program') -> + let new_set_of_closures = map_constant_set_of_closures set_of_closures in + let new_program' = loop program' in + if new_set_of_closures == set_of_closures + && new_program' == program' then + program + else + Let_symbol (symbol, Set_of_closures new_set_of_closures, new_program') + | Let_symbol (symbol, const, program') -> + let new_program' = loop program' in + if new_program' == program' then + program + else + Let_symbol (symbol, const, new_program') + | Let_rec_symbol (defs, program') -> + let done_something = ref false in + let defs = + List.map (function + | (var, Flambda.Set_of_closures set_of_closures) -> + let new_set_of_closures = + map_constant_set_of_closures set_of_closures + in + if not (new_set_of_closures == set_of_closures) then begin + done_something := true + end; + var, Flambda.Set_of_closures new_set_of_closures + | def -> def) + defs + in + let new_program' = loop program' in + if new_program' == program' && not !done_something then + program + else + Let_rec_symbol (defs, new_program') + | Initialize_symbol (symbol, tag, fields, program') -> + let done_something = ref false in + let fields = + List.map (fun field -> + let new_field = f field in + if not (new_field == field) then begin + done_something := true + end; + new_field) + fields + in + let new_program' = loop program' in + if new_program' == program' && not !done_something then + program + else + Initialize_symbol (symbol, tag, fields, new_program') + | Effect (expr, program') -> + let new_expr = f expr in + let new_program' = loop program' in + if new_expr == expr && new_program' == program' then + program + else + Effect (new_expr, new_program') + | End _ -> program + in + { program with + program_body = loop program.program_body; + } + +let map_named_of_program (program : Flambda.program) + ~(f : Variable.t -> Flambda.named -> Flambda.named) : Flambda.program = + map_exprs_at_toplevel_of_program program + ~f:(fun expr -> map_named_with_id f expr) + +let map_all_immutable_let_and_let_rec_bindings (expr : Flambda.t) + ~(f : Variable.t -> Flambda.named -> Flambda.named) : Flambda.t = + map_named_with_id f expr + +let fold_function_decls_ignoring_stubs + (set_of_closures : Flambda.set_of_closures) ~init ~f = + Variable.Map.fold (fun fun_var function_decl acc -> + f ~fun_var ~function_decl acc) + set_of_closures.function_decls.funs + init diff --git a/middle_end/flambda/flambda_iterators.mli b/middle_end/flambda/flambda_iterators.mli new file mode 100644 index 00000000..02fe6850 --- /dev/null +++ b/middle_end/flambda/flambda_iterators.mli @@ -0,0 +1,227 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(* CR-soon mshinwell: we need to document whether these iterators follow any + particular order. *) + +(** Apply the given functions to the immediate subexpressions of the given + Flambda expression. For avoidance of doubt, if a subexpression is + [Expr], it is passed to the function taking [Flambda.named], rather + than being followed and passed to the function taking [Flambda.t]. *) +val apply_on_subexpressions + : (Flambda.t -> unit) + -> (Flambda.named -> unit) + -> Flambda.t + -> unit + +val map_subexpressions + : (Flambda.t -> Flambda.t) + -> (Variable.t -> Flambda.named -> Flambda.named) + -> Flambda.t + -> Flambda.t + +(* CR-soon lwhite: add comment to clarify that these recurse unlike the + ones above *) +val iter + : (Flambda.t -> unit) + -> (Flambda.named -> unit) + -> Flambda.t + -> unit + +val iter_expr + : (Flambda.t -> unit) + -> Flambda.t + -> unit + +val iter_on_named + : (Flambda.t -> unit) + -> (Flambda.named -> unit) + -> Flambda.named + -> unit + +(* CR-someday mshinwell: we might need to add the corresponding variable to + the parameters of the user function for [iter_named] *) +val iter_named + : (Flambda.named -> unit) + -> Flambda.t + -> unit + +(* CR-someday lwhite: These names are pretty indecipherable, perhaps + create submodules for the normal and "on_named" variants of each + function. *) + +val iter_named_on_named + : (Flambda.named -> unit) + -> Flambda.named + -> unit + +(** [iter_toplevel f t] applies [f] on every toplevel subexpression of [t]. + In particular, it never applies [f] to the body of a function (which + will always be contained within an [Set_of_closures] expression). *) +val iter_toplevel + : (Flambda.t -> unit) + -> (Flambda.named -> unit) + -> Flambda.t + -> unit + +val iter_named_toplevel + : (Flambda.t -> unit) + -> (Flambda.named -> unit) + -> Flambda.named + -> unit + +val iter_on_sets_of_closures + : (Flambda.set_of_closures -> unit) + -> Flambda.t + -> unit + +val iter_on_set_of_closures_of_program + : Flambda.program + -> f:(constant:bool -> Flambda.set_of_closures -> unit) + -> unit + +val iter_all_immutable_let_and_let_rec_bindings + : Flambda.t + -> f:(Variable.t -> Flambda.named -> unit) + -> unit + +val iter_all_toplevel_immutable_let_and_let_rec_bindings + : Flambda.t + -> f:(Variable.t -> Flambda.named -> unit) + -> unit + +val iter_exprs_at_toplevel_of_program + : Flambda.program + -> f:(Flambda.t -> unit) + -> unit + +val iter_named_of_program + : Flambda.program + -> f:(Flambda.named -> unit) + -> unit + +val iter_constant_defining_values_on_program + : Flambda.program + -> f:(Flambda.constant_defining_value -> unit) + -> unit + +val iter_apply_on_program + : Flambda.program + -> f:(Flambda.apply -> unit) + -> unit + +val map + : (Flambda.t -> Flambda.t) + -> (Flambda.named -> Flambda.named) + -> Flambda.t + -> Flambda.t + +val map_expr + : (Flambda.t -> Flambda.t) + -> Flambda.t + -> Flambda.t + +val map_named + : (Flambda.named -> Flambda.named) + -> Flambda.t + -> Flambda.t + +val map_toplevel + : (Flambda.t -> Flambda.t) + -> (Flambda.named -> Flambda.named) + -> Flambda.t + -> Flambda.t + +val map_toplevel_expr + : (Flambda.t -> Flambda.t) + -> Flambda.t + -> Flambda.t + +val map_toplevel_named + : (Flambda.named -> Flambda.named) + -> Flambda.t + -> Flambda.t + +val map_symbols + : Flambda.t + -> f:(Symbol.t -> Symbol.t) + -> Flambda.t + +val map_symbols_on_set_of_closures + : Flambda.set_of_closures + -> f:(Symbol.t -> Symbol.t) + -> Flambda.set_of_closures + +val map_toplevel_sets_of_closures + : Flambda.t + -> f:(Flambda.set_of_closures -> Flambda.set_of_closures) + -> Flambda.t + +val map_apply + : Flambda.t + -> f:(Flambda.apply -> Flambda.apply) + -> Flambda.t + +val map_function_bodies + : Flambda.set_of_closures + -> f:(Flambda.t -> Flambda.t) + -> Flambda.set_of_closures + +val map_sets_of_closures + : Flambda.t + -> f:(Flambda.set_of_closures -> Flambda.set_of_closures) + -> Flambda.t + +val map_sets_of_closures_of_program + : Flambda.program + -> f:(Flambda.set_of_closures -> Flambda.set_of_closures) + -> Flambda.program + +val map_project_var_to_expr_opt + : Flambda.t + -> f:(Flambda.project_var -> Flambda.t option) + -> Flambda.t + +val map_project_var_to_named_opt + : Flambda.t + -> f:(Flambda.project_var -> Flambda.named option) + -> Flambda.t + +val map_exprs_at_toplevel_of_program + : Flambda.program + -> f:(Flambda.t -> Flambda.t) + -> Flambda.program + +val map_named_of_program + : Flambda.program + -> f:(Variable.t -> Flambda.named -> Flambda.named) + -> Flambda.program + +val map_all_immutable_let_and_let_rec_bindings + : Flambda.t + -> f:(Variable.t -> Flambda.named -> Flambda.named) + -> Flambda.t + +val fold_function_decls_ignoring_stubs + : Flambda.set_of_closures + -> init:'a + -> f:(fun_var:Variable.t + -> function_decl:Flambda.function_declaration + -> 'a + -> 'a) + -> 'a diff --git a/middle_end/flambda/flambda_middle_end.ml b/middle_end/flambda/flambda_middle_end.ml new file mode 100644 index 00000000..e604a328 --- /dev/null +++ b/middle_end/flambda/flambda_middle_end.ml @@ -0,0 +1,200 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let _dump_function_sizes flam ~backend = + let module Backend = (val backend : Backend_intf.S) in + let than = max_int in + Flambda_iterators.iter_on_set_of_closures_of_program flam + ~f:(fun ~constant:_ (set_of_closures : Flambda.set_of_closures) -> + Variable.Map.iter (fun fun_var + (function_decl : Flambda.function_declaration) -> + let closure_id = Closure_id.wrap fun_var in + let symbol = Backend.closure_symbol closure_id in + match Inlining_cost.lambda_smaller' function_decl.body ~than with + | Some size -> Format.eprintf "%a %d\n" Symbol.print symbol size + | None -> assert false) + set_of_closures.function_decls.funs) + +let middle_end ~ppf_dump ~prefixname ~backend + ~size + ~filename + ~module_ident + ~module_initializer = + Profile.record_call "flambda" (fun () -> + let previous_warning_reporter = !Location.warning_reporter in + let module WarningSet = + Set.Make (struct + type t = Location.t * Warnings.t + let compare = Stdlib.compare + end) + in + let warning_set = ref WarningSet.empty in + let flambda_warning_reporter loc w = + let elt = loc, w in + if not (WarningSet.mem elt !warning_set) then begin + warning_set := WarningSet.add elt !warning_set; + previous_warning_reporter loc w + end else None + in + Misc.protect_refs + [Misc.R (Location.warning_reporter, flambda_warning_reporter)] + (fun () -> + let pass_number = ref 0 in + let round_number = ref 0 in + let check flam = + if !Clflags.flambda_invariant_checks then begin + try Flambda_invariants.check_exn flam + with exn -> + Misc.fatal_errorf "After Flambda pass %d, round %d:@.%s:@.%a" + !pass_number !round_number (Printexc.to_string exn) + Flambda.print_program flam + end + in + let (+-+) flam (name, pass) = + incr pass_number; + if !Clflags.dump_flambda_verbose then begin + Format.fprintf ppf_dump "@.PASS: %s@." name; + Format.fprintf ppf_dump "Before pass %d, round %d:@ %a@." + !pass_number !round_number Flambda.print_program flam; + Format.fprintf ppf_dump "\n@?" + end; + let flam = Profile.record ~accumulate:true name pass flam in + if !Clflags.flambda_invariant_checks then begin + Profile.record ~accumulate:true "check" check flam + end; + flam + in + Profile.record_call ~accumulate:true "middle_end" (fun () -> + let flam = + Profile.record_call ~accumulate:true "closure_conversion" + (fun () -> + module_initializer + |> Closure_conversion.lambda_to_flambda ~backend + ~module_ident ~size ~filename) + in + if !Clflags.dump_rawflambda + then + Format.fprintf ppf_dump "After closure conversion:@ %a@." + Flambda.print_program flam; + check flam; + let fast_mode flam = + pass_number := 0; + let round = 0 in + flam + +-+ ("lift_lets 1", Lift_code.lift_lets) + +-+ ("Lift_constants", Lift_constants.lift_constants ~backend) + +-+ ("Share_constants", Share_constants.share_constants) + +-+ ("Lift_let_to_initialize_symbol", + Lift_let_to_initialize_symbol.lift ~backend) + +-+ ("Inline_and_simplify", + Inline_and_simplify.run ~never_inline:false ~backend + ~prefixname ~round ~ppf_dump) + +-+ ("Remove_unused_closure_vars 2", + Remove_unused_closure_vars.remove_unused_closure_variables + ~remove_direct_call_surrogates:false) + +-+ ("Ref_to_variables", + Ref_to_variables.eliminate_ref) + +-+ ("Initialize_symbol_to_let_symbol", + Initialize_symbol_to_let_symbol.run) + in + let rec loop flam = + pass_number := 0; + let round = !round_number in + incr round_number; + if !round_number > (Clflags.rounds ()) then flam + else + flam + (* Beware: [Lift_constants] must be run before any pass that + might duplicate strings. *) + +-+ ("lift_lets 1", Lift_code.lift_lets) + +-+ ("Lift_constants", Lift_constants.lift_constants ~backend) + +-+ ("Share_constants", Share_constants.share_constants) + +-+ ("Remove_unused_program_constructs", + Remove_unused_program_constructs.remove_unused_program_constructs) + +-+ ("Lift_let_to_initialize_symbol", + Lift_let_to_initialize_symbol.lift ~backend) + +-+ ("lift_lets 2", Lift_code.lift_lets) + +-+ ("Remove_unused_closure_vars 1", + Remove_unused_closure_vars.remove_unused_closure_variables + ~remove_direct_call_surrogates:false) + +-+ ("Inline_and_simplify", + Inline_and_simplify.run ~never_inline:false ~backend + ~prefixname ~round ~ppf_dump) + +-+ ("Remove_unused_closure_vars 2", + Remove_unused_closure_vars.remove_unused_closure_variables + ~remove_direct_call_surrogates:false) + +-+ ("lift_lets 3", Lift_code.lift_lets) + +-+ ("Inline_and_simplify noinline", + Inline_and_simplify.run ~never_inline:true ~backend + ~prefixname ~round ~ppf_dump) + +-+ ("Remove_unused_closure_vars 3", + Remove_unused_closure_vars.remove_unused_closure_variables + ~remove_direct_call_surrogates:false) + +-+ ("Ref_to_variables", + Ref_to_variables.eliminate_ref) + +-+ ("Initialize_symbol_to_let_symbol", + Initialize_symbol_to_let_symbol.run) + |> loop + in + let back_end flam = + flam + +-+ ("Remove_unused_closure_vars", + Remove_unused_closure_vars.remove_unused_closure_variables + ~remove_direct_call_surrogates:true) + +-+ ("Lift_constants", Lift_constants.lift_constants ~backend) + +-+ ("Share_constants", Share_constants.share_constants) + +-+ ("Remove_unused_program_constructs", + Remove_unused_program_constructs.remove_unused_program_constructs) + in + let flam = + if !Clflags.classic_inlining then + fast_mode flam + else + loop flam + in + let flam = back_end flam in + (* Check that there aren't any unused "always inline" attributes. *) + Flambda_iterators.iter_apply_on_program flam ~f:(fun apply -> + match apply.inline with + | Default_inline | Never_inline -> () + | Always_inline -> + (* CR-someday mshinwell: consider a different error message if + this triggers as a result of the propagation of a user's + attribute into the second part of an over application + (inline_and_simplify.ml line 710). *) + Location.prerr_warning (Debuginfo.to_location apply.dbg) + (Warnings.Inlining_impossible + "[@inlined] attribute was not used on this function \ + application (the optimizer did not know what function \ + was being applied)") + | Unroll _ -> + Location.prerr_warning (Debuginfo.to_location apply.dbg) + (Warnings.Inlining_impossible + "[@unroll] attribute was not used on this function \ + application (the optimizer did not know what function \ + was being applied)")); + if !Clflags.dump_flambda + then + Format.fprintf ppf_dump "End of middle end:@ %a@." + Flambda.print_program flam; + check flam; + (* CR-someday mshinwell: add -d... option for this *) + (* dump_function_sizes flam ~backend; *) + flam)) + ) diff --git a/middle_end/flambda/flambda_middle_end.mli b/middle_end/flambda/flambda_middle_end.mli new file mode 100644 index 00000000..584cb45a --- /dev/null +++ b/middle_end/flambda/flambda_middle_end.mli @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(* Translate Lambda code to Flambda code and then optimize it. *) + +val middle_end + : ppf_dump:Format.formatter + -> prefixname:string + -> backend:(module Backend_intf.S) + -> size:int + -> filename:string + -> module_ident:Ident.t + -> module_initializer:Lambda.lambda + -> Flambda.program diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml new file mode 100644 index 00000000..2f60f9fc --- /dev/null +++ b/middle_end/flambda/flambda_to_clambda.ml @@ -0,0 +1,749 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +module V = Backend_var +module VP = Backend_var.With_provenance + +type 'a for_one_or_more_units = { + fun_offset_table : int Closure_id.Map.t; + fv_offset_table : int Var_within_closure.Map.t; + constant_closures : Closure_id.Set.t; + closures: Closure_id.Set.t; +} + +type t = { + current_unit : + Set_of_closures_id.t for_one_or_more_units; + imported_units : + Simple_value_approx.function_declarations for_one_or_more_units; +} + +let get_fun_offset t closure_id = + let fun_offset_table = + if Closure_id.in_compilation_unit closure_id (Compilenv.current_unit ()) + then + t.current_unit.fun_offset_table + else + t.imported_units.fun_offset_table + in + try Closure_id.Map.find closure_id fun_offset_table + with Not_found -> + Misc.fatal_errorf "Flambda_to_clambda: missing offset for closure %a" + Closure_id.print closure_id + +let get_fv_offset t var_within_closure = + let fv_offset_table = + if Var_within_closure.in_compilation_unit var_within_closure + (Compilenv.current_unit ()) + then t.current_unit.fv_offset_table + else t.imported_units.fv_offset_table + in + try Var_within_closure.Map.find var_within_closure fv_offset_table + with Not_found -> + Misc.fatal_errorf "Flambda_to_clambda: missing offset for variable %a" + Var_within_closure.print var_within_closure + +let is_function_constant t closure_id = + if Closure_id.Set.mem closure_id t.current_unit.closures then + Closure_id.Set.mem closure_id t.current_unit.constant_closures + else if Closure_id.Set.mem closure_id t.imported_units.closures then + Closure_id.Set.mem closure_id t.imported_units.constant_closures + else + Misc.fatal_errorf "Flambda_to_clambda: missing closure %a" + Closure_id.print closure_id + +(* Instrumentation of closure and field accesses to try to catch compiler + bugs. *) + +let check_closure ulam named : Clambda.ulambda = + if not !Clflags.clambda_checks then ulam + else + let desc = + Primitive.simple ~name:"caml_check_value_is_closure" + ~arity:2 ~alloc:false + in + let str = Format.asprintf "%a" Flambda.print_named named in + let str_const = + Compilenv.new_structured_constant (Uconst_string str) ~shared:true + in + Uprim (Pccall desc, + [ulam; Clambda.Uconst (Uconst_ref (str_const, None))], + Debuginfo.none) + +let check_field ulam pos named_opt : Clambda.ulambda = + if not !Clflags.clambda_checks then ulam + else + let desc = + Primitive.simple ~name:"caml_check_field_access" + ~arity:3 ~alloc:false + in + let str = + match named_opt with + | None -> "" + | Some named -> Format.asprintf "%a" Flambda.print_named named + in + let str_const = + Compilenv.new_structured_constant (Uconst_string str) ~shared:true + in + Uprim (Pccall desc, [ulam; Clambda.Uconst (Uconst_int pos); + Clambda.Uconst (Uconst_ref (str_const, None))], + Debuginfo.none) + +module Env : sig + type t + + val empty : t + + val add_subst : t -> Variable.t -> Clambda.ulambda -> t + val find_subst_exn : t -> Variable.t -> Clambda.ulambda + + val add_fresh_ident : t -> Variable.t -> V.t * t + val ident_for_var_exn : t -> Variable.t -> V.t + + val add_fresh_mutable_ident : t -> Mutable_variable.t -> V.t * t + val ident_for_mutable_var_exn : t -> Mutable_variable.t -> V.t + + val add_allocated_const : t -> Symbol.t -> Allocated_const.t -> t + val allocated_const_for_symbol : t -> Symbol.t -> Allocated_const.t option + + val keep_only_symbols : t -> t +end = struct + type t = + { subst : Clambda.ulambda Variable.Map.t; + var : V.t Variable.Map.t; + mutable_var : V.t Mutable_variable.Map.t; + toplevel : bool; + allocated_constant_for_symbol : Allocated_const.t Symbol.Map.t; + } + + let empty = + { subst = Variable.Map.empty; + var = Variable.Map.empty; + mutable_var = Mutable_variable.Map.empty; + toplevel = false; + allocated_constant_for_symbol = Symbol.Map.empty; + } + + let add_subst t id subst = + { t with subst = Variable.Map.add id subst t.subst } + + let find_subst_exn t id = Variable.Map.find id t.subst + + let ident_for_var_exn t id = Variable.Map.find id t.var + + let add_fresh_ident t var = + let id = V.create_local (Variable.name var) in + id, { t with var = Variable.Map.add var id t.var } + + let ident_for_mutable_var_exn t mut_var = + Mutable_variable.Map.find mut_var t.mutable_var + + let add_fresh_mutable_ident t mut_var = + let id = V.create_local (Mutable_variable.name mut_var) in + let mutable_var = Mutable_variable.Map.add mut_var id t.mutable_var in + id, { t with mutable_var; } + + let add_allocated_const t sym cons = + { t with + allocated_constant_for_symbol = + Symbol.Map.add sym cons t.allocated_constant_for_symbol; + } + + let allocated_const_for_symbol t sym = + try + Some (Symbol.Map.find sym t.allocated_constant_for_symbol) + with Not_found -> None + + let keep_only_symbols t = + { empty with + allocated_constant_for_symbol = t.allocated_constant_for_symbol; + } +end + +let subst_var env var : Clambda.ulambda = + try Env.find_subst_exn env var + with Not_found -> + try Uvar (Env.ident_for_var_exn env var) + with Not_found -> + Misc.fatal_errorf "Flambda_to_clambda: unbound variable %a@." + Variable.print var + +let subst_vars env vars = List.map (subst_var env) vars + +let build_uoffset ulam offset : Clambda.ulambda = + if offset = 0 then ulam + else Uoffset (ulam, offset) + +let to_clambda_allocated_constant (const : Allocated_const.t) + : Clambda.ustructured_constant = + match const with + | Float f -> Uconst_float f + | Int32 i -> Uconst_int32 i + | Int64 i -> Uconst_int64 i + | Nativeint i -> Uconst_nativeint i + | Immutable_string s | String s -> Uconst_string s + | Immutable_float_array a | Float_array a -> Uconst_float_array a + +let to_uconst_symbol env symbol : Clambda.ustructured_constant option = + match Env.allocated_const_for_symbol env symbol with + | Some ((Float _ | Int32 _ | Int64 _ | Nativeint _) as const) -> + Some (to_clambda_allocated_constant const) + | None (* CR-soon mshinwell: Try to make this an error. *) + | Some _ -> None + +let to_clambda_symbol' env sym : Clambda.uconstant = + let lbl = Linkage_name.to_string (Symbol.label sym) in + Uconst_ref (lbl, to_uconst_symbol env sym) + +let to_clambda_symbol env sym : Clambda.ulambda = + Uconst (to_clambda_symbol' env sym) + +let to_clambda_const env (const : Flambda.constant_defining_value_block_field) + : Clambda.uconstant = + match const with + | Symbol symbol -> to_clambda_symbol' env symbol + | Const (Int i) -> Uconst_int i + | Const (Char c) -> Uconst_int (Char.code c) + | Const (Const_pointer i) -> Uconst_ptr i + +let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda = + match flam with + | Var var -> subst_var env var + | Let { var; defining_expr; body; _ } -> + (* TODO: synthesize proper value_kind *) + let id, env_body = Env.add_fresh_ident env var in + Ulet (Immutable, Pgenval, VP.create id, + to_clambda_named t env var defining_expr, + to_clambda t env_body body) + | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> + let id, env_body = Env.add_fresh_mutable_ident env mut_var in + let def = subst_var env var in + Ulet (Mutable, contents_kind, VP.create id, def, to_clambda t env_body body) + | Let_rec (defs, body) -> + let env, defs = + List.fold_right (fun (var, def) (env, defs) -> + let id, env = Env.add_fresh_ident env var in + env, (id, var, def) :: defs) + defs (env, []) + in + let defs = + List.map (fun (id, var, def) -> + VP.create id, to_clambda_named t env var def) + defs + in + Uletrec (defs, to_clambda t env body) + | Apply { func; args; kind = Direct direct_func; dbg = dbg } -> + (* The closure _parameter_ of the function is added by cmmgen. + At the call site, for a direct call, the closure argument must be + explicitly added (by [to_clambda_direct_apply]); there is no special + handling of such in the direct call primitive. + For an indirect call, we do not need to do anything here; Cmmgen will + do the equivalent of the previous paragraph when it generates a direct + call to [caml_apply]. *) + to_clambda_direct_apply t func args direct_func dbg env + | Apply { func; args; kind = Indirect; dbg = dbg } -> + let callee = subst_var env func in + Ugeneric_apply (check_closure callee (Flambda.Expr (Var func)), + subst_vars env args, dbg) + | Switch (arg, sw) -> + let aux () : Clambda.ulambda = + let const_index, const_actions = + to_clambda_switch t env sw.consts sw.numconsts sw.failaction + in + let block_index, block_actions = + to_clambda_switch t env sw.blocks sw.numblocks sw.failaction + in + Uswitch (subst_var env arg, + { us_index_consts = const_index; + us_actions_consts = const_actions; + us_index_blocks = block_index; + us_actions_blocks = block_actions; + }, + Debuginfo.none) (* debug info will be added by GPR#855 *) + in + (* Check that the [failaction] may be duplicated. If this is not the + case, share it through a static raise / static catch. *) + (* CR-someday pchambart for pchambart: This is overly simplified. + We should verify that this does not generates too bad code. + If it the case, handle some let cases. + *) + begin match sw.failaction with + | None -> aux () + | Some (Static_raise _) -> aux () + | Some failaction -> + let exn = Static_exception.create () in + let sw = + { sw with + failaction = Some (Flambda.Static_raise (exn, [])); + } + in + let expr : Flambda.t = + Static_catch (exn, [], Switch (arg, sw), failaction) + in + to_clambda t env expr + end + | String_switch (arg, sw, def) -> + let arg = subst_var env arg in + let sw = List.map (fun (s, e) -> s, to_clambda t env e) sw in + let def = Misc.may_map (to_clambda t env) def in + Ustringswitch (arg, sw, def) + | Static_raise (static_exn, args) -> + Ustaticfail (Static_exception.to_int static_exn, + List.map (subst_var env) args) + | Static_catch (static_exn, vars, body, handler) -> + let env_handler, ids = + List.fold_right (fun var (env, ids) -> + let id, env = Env.add_fresh_ident env var in + env, (VP.create id, Lambda.Pgenval) :: ids) + vars (env, []) + in + Ucatch (Static_exception.to_int static_exn, ids, + to_clambda t env body, to_clambda t env_handler handler) + | Try_with (body, var, handler) -> + let id, env_handler = Env.add_fresh_ident env var in + Utrywith (to_clambda t env body, VP.create id, + to_clambda t env_handler handler) + | If_then_else (arg, ifso, ifnot) -> + Uifthenelse (subst_var env arg, to_clambda t env ifso, + to_clambda t env ifnot) + | While (cond, body) -> + Uwhile (to_clambda t env cond, to_clambda t env body) + | For { bound_var; from_value; to_value; direction; body } -> + let id, env_body = Env.add_fresh_ident env bound_var in + Ufor (VP.create id, subst_var env from_value, subst_var env to_value, + direction, to_clambda t env_body body) + | Assign { being_assigned; new_value } -> + let id = + try Env.ident_for_mutable_var_exn env being_assigned + with Not_found -> + Misc.fatal_errorf "Unbound mutable variable %a in [Assign]: %a" + Mutable_variable.print being_assigned + Flambda.print flam + in + Uassign (id, subst_var env new_value) + | Send { kind; meth; obj; args; dbg } -> + Usend (kind, subst_var env meth, subst_var env obj, + subst_vars env args, dbg) + | Proved_unreachable -> Uunreachable + +and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda = + match named with + | Symbol sym -> to_clambda_symbol env sym + | Const (Const_pointer n) -> Uconst (Uconst_ptr n) + | Const (Int n) -> Uconst (Uconst_int n) + | Const (Char c) -> Uconst (Uconst_int (Char.code c)) + | Allocated_const _ -> + Misc.fatal_errorf "[Allocated_const] should have been lifted to a \ + [Let_symbol] construction before [Flambda_to_clambda]: %a = %a" + Variable.print var + Flambda.print_named named + | Read_mutable mut_var -> + begin try Uvar (Env.ident_for_mutable_var_exn env mut_var) + with Not_found -> + Misc.fatal_errorf "Unbound mutable variable %a in [Read_mutable]: %a" + Mutable_variable.print mut_var + Flambda.print_named named + end + | Read_symbol_field (symbol, field) -> + Uprim (Pfield field, [to_clambda_symbol env symbol], Debuginfo.none) + | Set_of_closures set_of_closures -> + to_clambda_set_of_closures t env set_of_closures + | Project_closure { set_of_closures; closure_id } -> + (* Note that we must use [build_uoffset] to ensure that we do not generate + a [Uoffset] construction in the event that the offset is zero, otherwise + we might break pattern matches in Cmmgen (in particular for the + compilation of "let rec"). *) + check_closure ( + build_uoffset + (check_closure (subst_var env set_of_closures) + (Flambda.Expr (Var set_of_closures))) + (get_fun_offset t closure_id)) + named + | Move_within_set_of_closures { closure; start_from; move_to } -> + check_closure (build_uoffset + (check_closure (subst_var env closure) + (Flambda.Expr (Var closure))) + ((get_fun_offset t move_to) - (get_fun_offset t start_from))) + named + | Project_var { closure; var; closure_id } -> + let ulam = subst_var env closure in + let fun_offset = get_fun_offset t closure_id in + let var_offset = get_fv_offset t var in + let pos = var_offset - fun_offset in + Uprim (Pfield pos, + [check_field (check_closure ulam (Expr (Var closure))) pos (Some named)], + Debuginfo.none) + | Prim (Pfield index, [block], dbg) -> + Uprim (Pfield index, [check_field (subst_var env block) index None], dbg) + | Prim (Psetfield (index, maybe_ptr, init), [block; new_value], dbg) -> + Uprim (Psetfield (index, maybe_ptr, init), [ + check_field (subst_var env block) index None; + subst_var env new_value; + ], dbg) + | Prim (Popaque, args, dbg) -> + Uprim (Popaque, subst_vars env args, dbg) + | Prim (p, args, dbg) -> + Uprim (p, subst_vars env args, dbg) + | Expr expr -> to_clambda t env expr + +and to_clambda_switch t env cases num_keys default = + let num_keys = + if Numbers.Int.Set.cardinal num_keys = 0 then 0 + else Numbers.Int.Set.max_elt num_keys + 1 + in + let store = Flambda_utils.Switch_storer.mk_store () in + let default_action = + match default with + | Some def when List.length cases < num_keys -> + store.act_store () def + | _ -> -1 + in + let index = Array.make num_keys default_action in + let smallest_key = ref num_keys in + List.iter + (fun (key, lam) -> + index.(key) <- store.act_store () lam; + smallest_key := min key !smallest_key + ) + cases; + if !smallest_key < num_keys then begin + let action = ref index.(!smallest_key) in + Array.iteri + (fun i act -> + if act >= 0 then action := act else index.(i) <- !action) + index + end; + let actions = Array.map (to_clambda t env) (store.act_get ()) in + match actions with + | [| |] -> [| |], [| |] (* May happen when [default] is [None]. *) + | _ -> index, actions + +and to_clambda_direct_apply t func args direct_func dbg env : Clambda.ulambda = + let closed = is_function_constant t direct_func in + let label = Compilenv.function_label direct_func in + let uargs = + let uargs = subst_vars env args in + (* Remove the closure argument if the closure is closed. (Note that the + closure argument is always a variable, so we can be sure we are not + dropping any side effects.) *) + if closed then uargs else uargs @ [subst_var env func] + in + Udirect_apply (label, uargs, dbg) + +(* Describe how to build a runtime closure block that corresponds to the + given Flambda set of closures. + + For instance the closure for the following set of closures: + + let rec fun_a x = + if x <= 0 then 0 else fun_b (x-1) v1 + and fun_b x y = + if x <= 0 then 0 else v1 + v2 + y + fun_a (x-1) + + will be represented in memory as: + + [ closure header; fun_a; + 1; infix header; fun caml_curry_2; + 2; fun_b; v1; v2 ] + + fun_a and fun_b will take an additional parameter 'env' to + access their closure. It will be arranged such that in the body + of each function the env parameter points to its own code + pointer. For example, in fun_b it will be shifted by 3 words. + + Hence accessing v1 in the body of fun_a is accessing the + 6th field of 'env' and in the body of fun_b the 1st field. +*) +and to_clambda_set_of_closures t env + (({ function_decls; free_vars } : Flambda.set_of_closures) + as set_of_closures) : Clambda.ulambda = + let all_functions = Variable.Map.bindings function_decls.funs in + let env_var = V.create_local "env" in + let to_clambda_function + (closure_id, (function_decl : Flambda.function_declaration)) + : Clambda.ufunction = + let closure_id = Closure_id.wrap closure_id in + let fun_offset = + Closure_id.Map.find closure_id t.current_unit.fun_offset_table + in + let env = + (* Inside the body of the function, we cannot access variables + declared outside, so start with a suitably clean environment. + Note that we must not forget the information about which allocated + constants contain which unboxed values. *) + let env = Env.keep_only_symbols env in + (* Add the Clambda expressions for the free variables of the function + to the environment. *) + let add_env_free_variable id _ env = + let var_offset = + try + Var_within_closure.Map.find + (Var_within_closure.wrap id) t.current_unit.fv_offset_table + with Not_found -> + Misc.fatal_errorf "Clambda.to_clambda_set_of_closures: offset for \ + free variable %a is unknown. Set of closures: %a" + Variable.print id + Flambda.print_set_of_closures set_of_closures + in + let pos = var_offset - fun_offset in + Env.add_subst env id + (Uprim (Pfield pos, [Clambda.Uvar env_var], Debuginfo.none)) + in + let env = Variable.Map.fold add_env_free_variable free_vars env in + (* Add the Clambda expressions for all functions defined in the current + set of closures to the environment. The various functions may be + retrieved by moving within the runtime closure, starting from the + current function's closure. *) + let add_env_function pos env (id, _) = + let offset = + Closure_id.Map.find (Closure_id.wrap id) + t.current_unit.fun_offset_table + in + let exp : Clambda.ulambda = Uoffset (Uvar env_var, offset - pos) in + Env.add_subst env id exp + in + List.fold_left (add_env_function fun_offset) env all_functions + in + let env_body, params = + List.fold_right (fun var (env, params) -> + let id, env = Env.add_fresh_ident env (Parameter.var var) in + env, id :: params) + function_decl.params (env, []) + in + { label = Compilenv.function_label closure_id; + arity = Flambda_utils.function_arity function_decl; + params = + List.map + (fun var -> VP.create var, Lambda.Pgenval) + (params @ [env_var]); + return = Lambda.Pgenval; + body = to_clambda t env_body function_decl.body; + dbg = function_decl.dbg; + env = Some env_var; + } + in + let funs = List.map to_clambda_function all_functions in + let free_vars = + Variable.Map.bindings (Variable.Map.map ( + fun (free_var : Flambda.specialised_to) -> + subst_var env free_var.var) free_vars) + in + Uclosure (funs, List.map snd free_vars) + +and to_clambda_closed_set_of_closures t env symbol + ({ function_decls; } : Flambda.set_of_closures) + : Clambda.ustructured_constant = + let functions = Variable.Map.bindings function_decls.funs in + let to_clambda_function (id, (function_decl : Flambda.function_declaration)) + : Clambda.ufunction = + (* All that we need in the environment, for translating one closure from + a closed set of closures, is the substitutions for variables bound to + the various closures in the set. Such closures will always be + referenced via symbols. *) + let env = + List.fold_left (fun env (var, _) -> + let closure_id = Closure_id.wrap var in + let symbol = Compilenv.closure_symbol closure_id in + Env.add_subst env var (to_clambda_symbol env symbol)) + (Env.keep_only_symbols env) + functions + in + let env_body, params = + List.fold_right (fun var (env, params) -> + let id, env = Env.add_fresh_ident env (Parameter.var var) in + env, id :: params) + function_decl.params (env, []) + in + { label = Compilenv.function_label (Closure_id.wrap id); + arity = Flambda_utils.function_arity function_decl; + params = List.map (fun var -> VP.create var, Lambda.Pgenval) params; + return = Lambda.Pgenval; + body = to_clambda t env_body function_decl.body; + dbg = function_decl.dbg; + env = None; + } + in + let ufunct = List.map to_clambda_function functions in + let closure_lbl = Linkage_name.to_string (Symbol.label symbol) in + Uconst_closure (ufunct, closure_lbl, []) + +let to_clambda_initialize_symbol t env symbol fields : Clambda.ulambda = + let fields = + List.map (fun (index, expr) -> index, to_clambda t env expr) fields + in + let build_setfield (index, field) : Clambda.ulambda = + (* Note that this will never cause a write barrier hit, owing to + the [Initialization]. *) + Uprim (Psetfield (index, Pointer, Root_initialization), + [to_clambda_symbol env symbol; field], + Debuginfo.none) + in + match fields with + | [] -> Uconst (Uconst_ptr 0) + | h :: t -> + List.fold_left (fun acc (p, field) -> + Clambda.Usequence (build_setfield (p, field), acc)) + (build_setfield h) t + +let accumulate_structured_constants t env symbol + (c : Flambda.constant_defining_value) acc = + match c with + | Allocated_const c -> + Symbol.Map.add symbol (to_clambda_allocated_constant c) acc + | Block (tag, fields) -> + let fields = List.map (to_clambda_const env) fields in + Symbol.Map.add symbol (Clambda.Uconst_block (Tag.to_int tag, fields)) acc + | Set_of_closures set_of_closures -> + let to_clambda_set_of_closures = + to_clambda_closed_set_of_closures t env symbol set_of_closures + in + Symbol.Map.add symbol to_clambda_set_of_closures acc + | Project_closure _ -> acc + +let to_clambda_program t env constants (program : Flambda.program) = + let rec loop env constants (program : Flambda.program_body) + : Clambda.ulambda * + Clambda.ustructured_constant Symbol.Map.t * + Clambda.preallocated_block list = + match program with + | Let_symbol (symbol, alloc, program) -> + (* Useful only for unboxing. Since floats and boxed integers will + never be part of a Let_rec_symbol, handling only the Let_symbol + is sufficient. *) + let env = + match alloc with + | Allocated_const const -> Env.add_allocated_const env symbol const + | _ -> env + in + let constants = + accumulate_structured_constants t env symbol alloc constants + in + loop env constants program + | Let_rec_symbol (defs, program) -> + let constants = + List.fold_left (fun constants (symbol, alloc) -> + accumulate_structured_constants t env symbol alloc constants) + constants defs + in + loop env constants program + | Initialize_symbol (symbol, tag, fields, program) -> + let fields = + List.mapi (fun i field -> + i, field, + Initialize_symbol_to_let_symbol.constant_field field) + fields + in + let init_fields = + List.filter_map (function + | (i, field, None) -> Some (i, field) + | (_, _, Some _) -> None) + fields + in + let constant_fields = + List.map (fun (_, _, constant_field) -> + match constant_field with + | None -> None + | Some (Flambda.Const const) -> + let n = + match const with + | Int i -> i + | Char c -> Char.code c + | Const_pointer i -> i + in + Some (Clambda.Uconst_field_int n) + | Some (Flambda.Symbol sym) -> + let lbl = Linkage_name.to_string (Symbol.label sym) in + Some (Clambda.Uconst_field_ref lbl)) + fields + in + let e1 = to_clambda_initialize_symbol t env symbol init_fields in + let preallocated_block : Clambda.preallocated_block = + { symbol = Linkage_name.to_string (Symbol.label symbol); + exported = true; + tag = Tag.to_int tag; + fields = constant_fields; + provenance = None; + } + in + let e2, constants, preallocated_blocks = loop env constants program in + Usequence (e1, e2), constants, preallocated_block :: preallocated_blocks + | Effect (expr, program) -> + let e1 = to_clambda t env expr in + let e2, constants, preallocated_blocks = loop env constants program in + Usequence (e1, e2), constants, preallocated_blocks + | End _ -> + Uconst (Uconst_ptr 0), constants, [] + in + loop env constants program.program_body + +type result = { + expr : Clambda.ulambda; + preallocated_blocks : Clambda.preallocated_block list; + structured_constants : Clambda.ustructured_constant Symbol.Map.t; + exported : Export_info.t; +} + +let convert (program, exported_transient) : result = + let current_unit = + let closures = + Closure_id.Map.keys (Flambda_utils.make_closure_map program) + in + let constant_closures = + Flambda_utils.all_lifted_constant_closures program + in + let offsets = Closure_offsets.compute program in + { fun_offset_table = offsets.function_offsets; + fv_offset_table = offsets.free_variable_offsets; + constant_closures; + closures; + } + in + let imported_units = + let imported = Compilenv.approx_env () in + let closures = + Set_of_closures_id.Map.fold + (fun (_ : Set_of_closures_id.t) fun_decls acc -> + Variable.Map.fold + (fun var (_ : Simple_value_approx.function_declaration) acc -> + let closure_id = Closure_id.wrap var in + Closure_id.Set.add closure_id acc) + fun_decls.Simple_value_approx.funs + acc) + imported.sets_of_closures + Closure_id.Set.empty + in + { fun_offset_table = imported.offset_fun; + fv_offset_table = imported.offset_fv; + constant_closures = imported.constant_closures; + closures; + } + in + let t = { current_unit; imported_units; } in + let expr, structured_constants, preallocated_blocks = + to_clambda_program t Env.empty Symbol.Map.empty program + in + let exported = + Export_info.t_of_transient exported_transient + ~program + ~local_offset_fun:current_unit.fun_offset_table + ~local_offset_fv:current_unit.fv_offset_table + ~imported_offset_fun:imported_units.fun_offset_table + ~imported_offset_fv:imported_units.fv_offset_table + ~constant_closures:current_unit.constant_closures + in + { expr; preallocated_blocks; structured_constants; exported; } diff --git a/middle_end/flambda/flambda_to_clambda.mli b/middle_end/flambda/flambda_to_clambda.mli new file mode 100644 index 00000000..8c493d40 --- /dev/null +++ b/middle_end/flambda/flambda_to_clambda.mli @@ -0,0 +1,38 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +type result = { + expr : Clambda.ulambda; + preallocated_blocks : Clambda.preallocated_block list; + structured_constants : Clambda.ustructured_constant Symbol.Map.t; + exported : Export_info.t; +} + +(** Convert an Flambda program, with associated proto-export information, + to Clambda. + This yields a Clambda expression together with augmented export + information and details about required statically-allocated values + (preallocated blocks, for [Initialize_symbol], and structured + constants). + + It is during this process that accesses to variables within + closures are transformed to field accesses within closure values. + For direct calls, the hidden closure parameter is added. Switch + tables are also built. +*) +val convert : Flambda.program * Export_info.transient -> result diff --git a/middle_end/flambda/flambda_utils.ml b/middle_end/flambda/flambda_utils.ml new file mode 100644 index 00000000..c204f5e6 --- /dev/null +++ b/middle_end/flambda/flambda_utils.ml @@ -0,0 +1,929 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let name_expr ~name (named : Flambda.named) : Flambda.t = + let var = + Variable.create + ~current_compilation_unit:(Compilation_unit.get_current_exn ()) + name + in + Flambda.create_let var named (Var var) + +let name_expr_from_var ~var (named : Flambda.named) : Flambda.t = + let var = + Variable.rename + ~current_compilation_unit:(Compilation_unit.get_current_exn ()) + var + in + Flambda.create_let var named (Var var) + +let find_declaration cf ({ funs } : Flambda.function_declarations) = + Variable.Map.find (Closure_id.unwrap cf) funs + +let find_declaration_variable cf ({ funs } : Flambda.function_declarations) = + let var = Closure_id.unwrap cf in + if not (Variable.Map.mem var funs) + then raise Not_found + else var + +let find_free_variable cv ({ free_vars } : Flambda.set_of_closures) = + let var : Flambda.specialised_to = + Variable.Map.find (Var_within_closure.unwrap cv) free_vars + in + var.var + +let function_arity (f : Flambda.function_declaration) = List.length f.params + +let variables_bound_by_the_closure cf + (decls : Flambda.function_declarations) = + let func = find_declaration cf decls in + let params = Parameter.Set.vars func.params in + let functions = Variable.Map.keys decls.funs in + Variable.Set.diff + (Variable.Set.diff func.free_variables params) + functions + +let description_of_toplevel_node (expr : Flambda.t) = + match expr with + | Var id -> Format.asprintf "var %a" Variable.print id + | Apply _ -> "apply" + | Assign _ -> "assign" + | Send _ -> "send" + | Proved_unreachable -> "unreachable" + | Let { var; _ } -> Format.asprintf "let %a" Variable.print var + | Let_mutable _ -> "let_mutable" + | Let_rec _ -> "letrec" + | If_then_else _ -> "if" + | Switch _ -> "switch" + | String_switch _ -> "stringswitch" + | Static_raise _ -> "staticraise" + | Static_catch _ -> "catch" + | Try_with _ -> "trywith" + | While _ -> "while" + | For _ -> "for" + +let equal_direction_flag + (x : Asttypes.direction_flag) + (y : Asttypes.direction_flag) = + match x, y with + | Upto, Upto -> true + | Downto, Downto -> true + | (Upto | Downto), _ -> false + +let rec same (l1 : Flambda.t) (l2 : Flambda.t) = + l1 == l2 || (* it is ok for the string case: if they are physically the same, + it is the same original branch *) + match (l1, l2) with + | Var v1 , Var v2 -> Variable.equal v1 v2 + | Var _, _ | _, Var _ -> false + | Apply a1 , Apply a2 -> + Flambda.equal_call_kind a1.kind a2.kind + && Variable.equal a1.func a2.func + && Misc.Stdlib.List.equal Variable.equal a1.args a2.args + | Apply _, _ | _, Apply _ -> false + | Let { var = var1; defining_expr = defining_expr1; body = body1; _ }, + Let { var = var2; defining_expr = defining_expr2; body = body2; _ } -> + Variable.equal var1 var2 && same_named defining_expr1 defining_expr2 + && same body1 body2 + | Let _, _ | _, Let _ -> false + | Let_mutable {var = mv1; initial_value = v1; contents_kind = ck1; body = b1}, + Let_mutable {var = mv2; initial_value = v2; contents_kind = ck2; body = b2} + -> + Mutable_variable.equal mv1 mv2 + && Variable.equal v1 v2 + && Lambda.equal_value_kind ck1 ck2 + && same b1 b2 + | Let_mutable _, _ | _, Let_mutable _ -> false + | Let_rec (bl1, a1), Let_rec (bl2, a2) -> + Misc.Stdlib.List.equal samebinding bl1 bl2 && same a1 a2 + | Let_rec _, _ | _, Let_rec _ -> false + | Switch (a1, s1), Switch (a2, s2) -> + Variable.equal a1 a2 && sameswitch s1 s2 + | Switch _, _ | _, Switch _ -> false + | String_switch (a1, s1, d1), String_switch (a2, s2, d2) -> + Variable.equal a1 a2 + && Misc.Stdlib.List.equal + (fun (s1, e1) (s2, e2) -> String.equal s1 s2 && same e1 e2) s1 s2 + && Option.equal same d1 d2 + | String_switch _, _ | _, String_switch _ -> false + | Static_raise (e1, a1), Static_raise (e2, a2) -> + Static_exception.equal e1 e2 && Misc.Stdlib.List.equal Variable.equal a1 a2 + | Static_raise _, _ | _, Static_raise _ -> false + | Static_catch (s1, v1, a1, b1), Static_catch (s2, v2, a2, b2) -> + Static_exception.equal s1 s2 + && Misc.Stdlib.List.equal Variable.equal v1 v2 + && same a1 a2 + && same b1 b2 + | Static_catch _, _ | _, Static_catch _ -> false + | Try_with (a1, v1, b1), Try_with (a2, v2, b2) -> + same a1 a2 && Variable.equal v1 v2 && same b1 b2 + | Try_with _, _ | _, Try_with _ -> false + | If_then_else (a1, b1, c1), If_then_else (a2, b2, c2) -> + Variable.equal a1 a2 && same b1 b2 && same c1 c2 + | If_then_else _, _ | _, If_then_else _ -> false + | While (a1, b1), While (a2, b2) -> + same a1 a2 && same b1 b2 + | While _, _ | _, While _ -> false + | For { bound_var = bound_var1; from_value = from_value1; + to_value = to_value1; direction = direction1; body = body1; }, + For { bound_var = bound_var2; from_value = from_value2; + to_value = to_value2; direction = direction2; body = body2; } -> + Variable.equal bound_var1 bound_var2 + && Variable.equal from_value1 from_value2 + && Variable.equal to_value1 to_value2 + && equal_direction_flag direction1 direction2 + && same body1 body2 + | For _, _ | _, For _ -> false + | Assign { being_assigned = being_assigned1; new_value = new_value1; }, + Assign { being_assigned = being_assigned2; new_value = new_value2; } -> + Mutable_variable.equal being_assigned1 being_assigned2 + && Variable.equal new_value1 new_value2 + | Assign _, _ | _, Assign _ -> false + | Send { kind = kind1; meth = meth1; obj = obj1; args = args1; dbg = _; }, + Send { kind = kind2; meth = meth2; obj = obj2; args = args2; dbg = _; } -> + Lambda.equal_meth_kind kind1 kind2 + && Variable.equal meth1 meth2 + && Variable.equal obj1 obj2 + && Misc.Stdlib.List.equal Variable.equal args1 args2 + | Send _, _ | _, Send _ -> false + | Proved_unreachable, Proved_unreachable -> true + +and same_named (named1 : Flambda.named) (named2 : Flambda.named) = + match named1, named2 with + | Symbol s1 , Symbol s2 -> Symbol.equal s1 s2 + | Symbol _, _ | _, Symbol _ -> false + | Const c1, Const c2 -> Flambda.compare_const c1 c2 = 0 + | Const _, _ | _, Const _ -> false + | Allocated_const c1, Allocated_const c2 -> + Allocated_const.compare c1 c2 = 0 + | Allocated_const _, _ | _, Allocated_const _ -> false + | Read_mutable mv1, Read_mutable mv2 -> Mutable_variable.equal mv1 mv2 + | Read_mutable _, _ | _, Read_mutable _ -> false + | Read_symbol_field (s1, i1), Read_symbol_field (s2, i2) -> + Symbol.equal s1 s2 && i1 = i2 + | Read_symbol_field _, _ | _, Read_symbol_field _ -> false + | Set_of_closures s1, Set_of_closures s2 -> same_set_of_closures s1 s2 + | Set_of_closures _, _ | _, Set_of_closures _ -> false + | Project_closure f1, Project_closure f2 -> same_project_closure f1 f2 + | Project_closure _, _ | _, Project_closure _ -> false + | Project_var v1, Project_var v2 -> + Variable.equal v1.closure v2.closure + && Closure_id.equal v1.closure_id v2.closure_id + && Var_within_closure.equal v1.var v2.var + | Project_var _, _ | _, Project_var _ -> false + | Move_within_set_of_closures m1, Move_within_set_of_closures m2 -> + same_move_within_set_of_closures m1 m2 + | Move_within_set_of_closures _, _ | _, Move_within_set_of_closures _ -> + false + | Prim (p1, al1, _), Prim (p2, al2, _) -> + Clambda_primitives.equal p1 p2 + && Misc.Stdlib.List.equal Variable.equal al1 al2 + | Prim _, _ | _, Prim _ -> false + | Expr e1, Expr e2 -> same e1 e2 + +and sameclosure (c1 : Flambda.function_declaration) + (c2 : Flambda.function_declaration) = + Misc.Stdlib.List.equal Parameter.equal c1.params c2.params + && same c1.body c2.body + +and same_set_of_closures (c1 : Flambda.set_of_closures) + (c2 : Flambda.set_of_closures) = + Variable.Map.equal sameclosure c1.function_decls.funs c2.function_decls.funs + && Variable.Map.equal Flambda.equal_specialised_to + c1.free_vars c2.free_vars + && Variable.Map.equal Flambda.equal_specialised_to c1.specialised_args + c2.specialised_args + +and same_project_closure (s1 : Flambda.project_closure) + (s2 : Flambda.project_closure) = + Variable.equal s1.set_of_closures s2.set_of_closures + && Closure_id.equal s1.closure_id s2.closure_id + +and same_move_within_set_of_closures (m1 : Flambda.move_within_set_of_closures) + (m2 : Flambda.move_within_set_of_closures) = + Variable.equal m1.closure m2.closure + && Closure_id.equal m1.start_from m2.start_from + && Closure_id.equal m1.move_to m2.move_to + +and samebinding (v1, n1) (v2, n2) = + Variable.equal v1 v2 && same_named n1 n2 + +and sameswitch (fs1 : Flambda.switch) (fs2 : Flambda.switch) = + let samecase (n1, a1) (n2, a2) = n1 = n2 && same a1 a2 in + Numbers.Int.Set.equal fs1.numconsts fs2.numconsts + && Numbers.Int.Set.equal fs1.numblocks fs2.numblocks + && Misc.Stdlib.List.equal samecase fs1.consts fs2.consts + && Misc.Stdlib.List.equal samecase fs1.blocks fs2.blocks + && Option.equal same fs1.failaction fs2.failaction + +let can_be_merged = same + +(* CR-soon mshinwell: this should use the explicit ignore functions *) +let toplevel_substitution sb tree = + let sb' = sb in + let sb v = try Variable.Map.find v sb with Not_found -> v in + let aux (flam : Flambda.t) : Flambda.t = + match flam with + | Var var -> + let var = sb var in + Var var + | Let_mutable mutable_let -> + let initial_value = sb mutable_let.initial_value in + Let_mutable { mutable_let with initial_value } + | Assign { being_assigned; new_value; } -> + let new_value = sb new_value in + Assign { being_assigned; new_value; } + | Apply { func; args; kind; dbg; inline; specialise; } -> + let func = sb func in + let args = List.map sb args in + Apply { func; args; kind; dbg; inline; specialise; } + | If_then_else (cond, e1, e2) -> + let cond = sb cond in + If_then_else (cond, e1, e2) + | Switch (cond, sw) -> + let cond = sb cond in + Switch (cond, sw) + | String_switch (cond, branches, def) -> + let cond = sb cond in + String_switch (cond, branches, def) + | Send { kind; meth; obj; args; dbg } -> + let meth = sb meth in + let obj = sb obj in + let args = List.map sb args in + Send { kind; meth; obj; args; dbg } + | For { bound_var; from_value; to_value; direction; body } -> + let from_value = sb from_value in + let to_value = sb to_value in + For { bound_var; from_value; to_value; direction; body } + | Static_raise (static_exn, args) -> + let args = List.map sb args in + Static_raise (static_exn, args) + | Static_catch _ | Try_with _ | While _ + | Let _ | Let_rec _ | Proved_unreachable -> flam + in + let aux_named (named : Flambda.named) : Flambda.named = + match named with + | Symbol _ | Const _ | Expr _ -> named + | Allocated_const _ | Read_mutable _ -> named + | Read_symbol_field _ -> named + | Set_of_closures set_of_closures -> + let set_of_closures = + Flambda.create_set_of_closures + ~function_decls:set_of_closures.function_decls + ~free_vars: + (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> + { spec_to with var = sb spec_to.var; }) + set_of_closures.free_vars) + ~specialised_args: + (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> + { spec_to with var = sb spec_to.var; }) + set_of_closures.specialised_args) + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + in + Set_of_closures set_of_closures + | Project_closure project_closure -> + Project_closure { + project_closure with + set_of_closures = sb project_closure.set_of_closures; + } + | Move_within_set_of_closures move_within_set_of_closures -> + Move_within_set_of_closures { + move_within_set_of_closures with + closure = sb move_within_set_of_closures.closure; + } + | Project_var project_var -> + Project_var { + project_var with + closure = sb project_var.closure; + } + | Prim (prim, args, dbg) -> + Prim (prim, List.map sb args, dbg) + in + if Variable.Map.is_empty sb' then tree + else Flambda_iterators.map_toplevel aux aux_named tree + +(* CR-someday mshinwell: Fix [Flambda_iterators] so this can be implemented + properly. *) +let toplevel_substitution_named sb named = + let name = Internal_variable_names.toplevel_substitution_named in + let expr = name_expr named ~name in + match toplevel_substitution sb expr with + | Let let_expr -> let_expr.defining_expr + | _ -> assert false + +let make_closure_declaration + ~is_classic_mode ~id ~body ~params ~stub : Flambda.t = + let free_variables = Flambda.free_variables body in + let param_set = Parameter.Set.vars params in + if not (Variable.Set.subset param_set free_variables) then begin + Misc.fatal_error "Flambda_utils.make_closure_declaration" + end; + let sb = + Variable.Set.fold + (fun id sb -> Variable.Map.add id (Variable.rename id) sb) + free_variables Variable.Map.empty + in + (* CR-soon mshinwell: try to eliminate this [toplevel_substitution]. This + function is only called from [Inline_and_simplify], so we should be able + to do something similar to what happens in [Inlining_transforms] now. *) + let body = toplevel_substitution sb body in + let subst id = Variable.Map.find id sb in + let subst_param param = Parameter.map_var subst param in + let function_declaration = + Flambda.create_function_declaration ~params:(List.map subst_param params) + ~body ~stub ~dbg:Debuginfo.none ~inline:Default_inline + ~specialise:Default_specialise ~is_a_functor:false + ~closure_origin:(Closure_origin.create (Closure_id.wrap id)) + in + assert (Variable.Set.equal (Variable.Set.map subst free_variables) + function_declaration.free_variables); + let free_vars = + Variable.Map.fold (fun id id' fv' -> + let spec_to : Flambda.specialised_to = + { var = id; + projection = None; + } + in + Variable.Map.add id' spec_to fv') + (Variable.Map.filter + (fun id _ -> not (Variable.Set.mem id param_set)) + sb) + Variable.Map.empty + in + let compilation_unit = Compilation_unit.get_current_exn () in + let set_of_closures_var = + Variable.create Internal_variable_names.set_of_closures + ~current_compilation_unit:compilation_unit + in + let set_of_closures = + let function_decls = + Flambda.create_function_declarations + ~is_classic_mode + ~funs:(Variable.Map.singleton id function_declaration) + in + Flambda.create_set_of_closures ~function_decls ~free_vars + ~specialised_args:Variable.Map.empty + ~direct_call_surrogates:Variable.Map.empty + in + let project_closure : Flambda.named = + Project_closure { + set_of_closures = set_of_closures_var; + closure_id = Closure_id.wrap id; + } + in + let project_closure_var = + Variable.create Internal_variable_names.project_closure + ~current_compilation_unit:compilation_unit + in + Flambda.create_let set_of_closures_var (Set_of_closures set_of_closures) + (Flambda.create_let project_closure_var project_closure + (Var (project_closure_var))) + +let bind ~bindings ~body = + List.fold_left (fun expr (var, var_def) -> + Flambda.create_let var var_def expr) + body bindings + +let all_lifted_constants (program : Flambda.program) = + let rec loop (program : Flambda.program_body) = + match program with + | Let_symbol (symbol, decl, program) -> (symbol, decl) :: (loop program) + | Let_rec_symbol (decls, program) -> + List.fold_left (fun l (symbol, decl) -> (symbol, decl) :: l) + (loop program) + decls + | Initialize_symbol (_, _, _, program) + | Effect (_, program) -> loop program + | End _ -> [] + in + loop program.program_body + +let all_lifted_constants_as_map program = + Symbol.Map.of_list (all_lifted_constants program) + +let initialize_symbols (program : Flambda.program) = + let rec loop (program : Flambda.program_body) = + match program with + | Initialize_symbol (symbol, tag, fields, program) -> + (symbol, tag, fields) :: (loop program) + | Effect (_, program) + | Let_symbol (_, _, program) + | Let_rec_symbol (_, program) -> loop program + | End _ -> [] + in + loop program.program_body + +let imported_symbols (program : Flambda.program) = + program.imported_symbols + +let needed_import_symbols (program : Flambda.program) = + let dependencies = Flambda.free_symbols_program program in + let defined_symbol = + Symbol.Set.union + (Symbol.Set.of_list + (List.map fst (all_lifted_constants program))) + (Symbol.Set.of_list + (List.map (fun (s, _, _) -> s) (initialize_symbols program))) + in + Symbol.Set.diff dependencies defined_symbol + +let introduce_needed_import_symbols program : Flambda.program = + { program with + imported_symbols = needed_import_symbols program; + } + +let root_symbol (program : Flambda.program) = + let rec loop (program : Flambda.program_body) = + match program with + | Effect (_, program) + | Let_symbol (_, _, program) + | Let_rec_symbol (_, program) + | Initialize_symbol (_, _, _, program) -> loop program + | End root -> + root + in + loop program.program_body + +let might_raise_static_exn flam stexn = + try + Flambda_iterators.iter_on_named + (function + | Flambda.Static_raise (ex, _) when Static_exception.equal ex stexn -> + raise Exit + | _ -> ()) + (fun _ -> ()) + flam; + false + with Exit -> true + +let make_closure_map program = + let map = ref Closure_id.Map.empty in + let add_set_of_closures ~constant:_ : Flambda.set_of_closures -> unit = fun + { function_decls } -> + Variable.Map.iter (fun var _ -> + let closure_id = Closure_id.wrap var in + let set_of_closures_id = function_decls.set_of_closures_id in + map := Closure_id.Map.add closure_id set_of_closures_id !map) + function_decls.funs + in + Flambda_iterators.iter_on_set_of_closures_of_program + program + ~f:add_set_of_closures; + !map + +let all_lifted_constant_closures program = + List.fold_left (fun unchanged flambda -> + match flambda with + | (_, Flambda.Set_of_closures { function_decls = { funs } }) -> + Variable.Map.fold + (fun key (_ : Flambda.function_declaration) acc -> + Closure_id.Set.add (Closure_id.wrap key) acc) + funs + unchanged + | _ -> unchanged) + Closure_id.Set.empty + (all_lifted_constants program) + +let all_lifted_constant_sets_of_closures program = + let set = ref Set_of_closures_id.Set.empty in + List.iter (function + | (_, Flambda.Set_of_closures { + function_decls = { set_of_closures_id } }) -> + set := Set_of_closures_id.Set.add set_of_closures_id !set + | _ -> ()) + (all_lifted_constants program); + !set + +let all_sets_of_closures program = + let list = ref [] in + Flambda_iterators.iter_on_set_of_closures_of_program program + ~f:(fun ~constant:_ set_of_closures -> + list := set_of_closures :: !list); + !list + +let all_sets_of_closures_map program = + let r = ref Set_of_closures_id.Map.empty in + Flambda_iterators.iter_on_set_of_closures_of_program program + ~f:(fun ~constant:_ set_of_closures -> + r := Set_of_closures_id.Map.add + set_of_closures.function_decls.set_of_closures_id + set_of_closures !r); + !r + +let substitute_read_symbol_field_for_variables + (substitution : (Symbol.t * int list) Variable.Map.t) + (expr : Flambda.t) = + let bind var fresh_var (expr:Flambda.t) : Flambda.t = + let symbol, path = Variable.Map.find var substitution in + let rec make_named (path:int list) : Flambda.named = + match path with + | [] -> Symbol symbol + | [i] -> Read_symbol_field (symbol, i) + | h :: t -> + let block_name = Internal_variable_names.symbol_field_block in + let block = Variable.create block_name in + let field_name = Internal_variable_names.get_symbol_field in + let field = Variable.create field_name in + Expr ( + Flambda.create_let block (make_named t) + (Flambda.create_let field + (Prim (Pfield h, [block], Debuginfo.none)) + (Var field))) + in + Flambda.create_let fresh_var (make_named path) expr + in + let substitute_named bindings (named:Flambda.named) : Flambda.named = + let sb to_substitute = + try Variable.Map.find to_substitute bindings with + | Not_found -> + to_substitute + in + match named with + | Symbol _ | Const _ | Expr _ -> named + | Allocated_const _ | Read_mutable _ -> named + | Read_symbol_field _ -> named + | Set_of_closures set_of_closures -> + let set_of_closures = + Flambda.create_set_of_closures + ~function_decls:set_of_closures.function_decls + ~free_vars: + (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> + { spec_to with var = sb spec_to.var; }) + set_of_closures.free_vars) + ~specialised_args: + (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> + { spec_to with var = sb spec_to.var; }) + set_of_closures.specialised_args) + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + in + Set_of_closures set_of_closures + | Project_closure project_closure -> + Project_closure { + project_closure with + set_of_closures = sb project_closure.set_of_closures; + } + | Move_within_set_of_closures move_within_set_of_closures -> + Move_within_set_of_closures { + move_within_set_of_closures with + closure = sb move_within_set_of_closures.closure; + } + | Project_var project_var -> + Project_var { + project_var with + closure = sb project_var.closure; + } + | Prim (prim, args, dbg) -> + Prim (prim, List.map sb args, dbg) + in + let make_var_subst var = + if Variable.Map.mem var substitution then + let fresh = Variable.rename var in + fresh, (fun expr -> bind var fresh expr) + else + var, (fun x -> x) + in + let f (expr:Flambda.t) : Flambda.t = + match expr with + | Var v when Variable.Map.mem v substitution -> + let fresh = Variable.rename v in + bind v fresh (Var fresh) + | Var _ -> expr + | Let ({ var = v; defining_expr = named; _ } as let_expr) -> + let to_substitute = + Variable.Set.filter + (fun v -> Variable.Map.mem v substitution) + (Flambda.free_variables_named named) + in + if Variable.Set.is_empty to_substitute then + expr + else + let bindings = + Variable.Map.of_set (fun var -> Variable.rename var) to_substitute + in + let named = + substitute_named bindings named + in + let expr = + let module W = Flambda.With_free_variables in + W.create_let_reusing_body v named (W.of_body_of_let let_expr) + in + Variable.Map.fold (fun to_substitute fresh expr -> + bind to_substitute fresh expr) + bindings expr + | Let_mutable let_mutable when + Variable.Map.mem let_mutable.initial_value substitution -> + let fresh = Variable.rename let_mutable.initial_value in + bind let_mutable.initial_value fresh + (Let_mutable { let_mutable with initial_value = fresh }) + | Let_mutable _ -> + expr + | Let_rec (defs, body) -> + let free_variables_of_defs = + List.fold_left (fun set (_, named) -> + Variable.Set.union set (Flambda.free_variables_named named)) + Variable.Set.empty defs + in + let to_substitute = + Variable.Set.filter + (fun v -> Variable.Map.mem v substitution) + free_variables_of_defs + in + if Variable.Set.is_empty to_substitute then + expr + else begin + let bindings = + Variable.Map.of_set (fun var -> Variable.rename var) to_substitute + in + let defs = + List.map (fun (var, named) -> + var, substitute_named bindings named) + defs + in + let expr = + Flambda.Let_rec (defs, body) + in + Variable.Map.fold (fun to_substitute fresh expr -> + bind to_substitute fresh expr) + bindings expr + end + | If_then_else (cond, ifso, ifnot) + when Variable.Map.mem cond substitution -> + let fresh = Variable.rename cond in + bind cond fresh (If_then_else (fresh, ifso, ifnot)) + | If_then_else _ -> + expr + | Switch (cond, sw) when Variable.Map.mem cond substitution -> + let fresh = Variable.rename cond in + bind cond fresh (Switch (fresh, sw)) + | Switch _ -> + expr + | String_switch (cond, sw, def) when Variable.Map.mem cond substitution -> + let fresh = Variable.rename cond in + bind cond fresh (String_switch (fresh, sw, def)) + | String_switch _ -> + expr + | Assign { being_assigned; new_value } + when Variable.Map.mem new_value substitution -> + let fresh = Variable.rename new_value in + bind new_value fresh (Assign { being_assigned; new_value = fresh }) + | Assign _ -> + expr + | Static_raise (exn, args) -> + let args, bind_args = + List.split (List.map make_var_subst args) + in + List.fold_right (fun f expr -> f expr) bind_args @@ + Flambda.Static_raise (exn, args) + | For { bound_var; from_value; to_value; direction; body } -> + let from_value, bind_from_value = make_var_subst from_value in + let to_value, bind_to_value = make_var_subst to_value in + bind_from_value @@ + bind_to_value @@ + Flambda.For { bound_var; from_value; to_value; direction; body } + | Apply { func; args; kind; dbg; inline; specialise } -> + let func, bind_func = make_var_subst func in + let args, bind_args = + List.split (List.map make_var_subst args) + in + bind_func @@ + List.fold_right (fun f expr -> f expr) bind_args @@ + Flambda.Apply { func; args; kind; dbg; inline; specialise } + | Send { kind; meth; obj; args; dbg } -> + let meth, bind_meth = make_var_subst meth in + let obj, bind_obj = make_var_subst obj in + let args, bind_args = + List.split (List.map make_var_subst args) + in + bind_meth @@ + bind_obj @@ + List.fold_right (fun f expr -> f expr) bind_args @@ + Flambda.Send { kind; meth; obj; args; dbg } + | Proved_unreachable + | While _ + | Try_with _ + | Static_catch _ -> + (* No variables directly used in those expressions *) + expr + in + Flambda_iterators.map_toplevel f (fun v -> v) expr + +module Switch_storer = Switch.Store (struct + type t = Flambda.t + + (* An easily-comparable subset of [Flambda.t]: currently this only + supports that required to share switch branches. *) + type key = + | Var of Variable.t + | Let of Variable.t * key_named * key + | Static_raise of Static_exception.t * Variable.t list + and key_named = + | Symbol of Symbol.t + | Const of Flambda.const + | Prim of Clambda_primitives.primitive * Variable.t list + | Expr of key + + exception Not_comparable + + let rec make_expr_key (expr : Flambda.t) : key = + match expr with + | Var v -> Var v + | Let { var; defining_expr; body; } -> + Let (var, make_named_key defining_expr, make_expr_key body) + | Static_raise (e, args) -> Static_raise (e, args) + | _ -> raise Not_comparable + and make_named_key (named:Flambda.named) : key_named = + match named with + | Symbol s -> Symbol s + | Const c -> Const c + | Expr e -> Expr (make_expr_key e) + | Prim (prim, args, _dbg) -> Prim (prim, args) + | _ -> raise Not_comparable + + let make_key expr = + match make_expr_key expr with + | exception Not_comparable -> None + | key -> Some key + + let compare_key e1 e2 = + (* The environment [env] maps variables bound in [e2] to the corresponding + bound variables in [e1]. Every variable to compare in [e2] must have an + equivalent in [e1], otherwise the comparison wouldn't have gone + past the [Let] binding. Hence [Variable.Map.find] is safe here. *) + let compare_var env v1 v2 = + match Variable.Map.find v2 env with + | exception Not_found -> + (* The variable is free in the expression [e2], hence we can + compare it with [v1] directly. *) + Variable.compare v1 v2 + | bound -> + Variable.compare v1 bound + in + let rec compare_expr env (e1 : key) (e2 : key) : int = + match e1, e2 with + | Var v1, Var v2 -> + compare_var env v1 v2 + | Var _, (Let _| Static_raise _) -> -1 + | (Let _| Static_raise _), Var _ -> 1 + | Let (v1, n1, b1), Let (v2, n2, b2) -> + let comp_named = compare_named env n1 n2 in + if comp_named <> 0 then comp_named + else + let env = Variable.Map.add v2 v1 env in + compare_expr env b1 b2 + | Let _, Static_raise _ -> -1 + | Static_raise _, Let _ -> 1 + | Static_raise (sexn1, args1), Static_raise (sexn2, args2) -> + let comp_sexn = Static_exception.compare sexn1 sexn2 in + if comp_sexn <> 0 then comp_sexn + else Misc.Stdlib.List.compare (compare_var env) args1 args2 + and compare_named env (n1:key_named) (n2:key_named) : int = + match n1, n2 with + | Symbol s1, Symbol s2 -> Symbol.compare s1 s2 + | Symbol _, (Const _ | Expr _ | Prim _) -> -1 + | (Const _ | Expr _ | Prim _), Symbol _ -> 1 + | Const c1, Const c2 -> Flambda.compare_const c1 c2 + | Const _, (Expr _ | Prim _) -> -1 + | (Expr _ | Prim _), Const _ -> 1 + | Expr e1, Expr e2 -> compare_expr env e1 e2 + | Expr _, Prim _ -> -1 + | Prim _, Expr _ -> 1 + | Prim (prim1, args1), Prim (prim2, args2) -> + let comp_prim = Stdlib.compare prim1 prim2 in + if comp_prim <> 0 then comp_prim + else Misc.Stdlib.List.compare (compare_var env) args1 args2 + in + compare_expr Variable.Map.empty e1 e2 +end) + +let fun_vars_referenced_in_decls + (function_decls : Flambda.function_declarations) ~closure_symbol = + let fun_vars = Variable.Map.keys function_decls.funs in + let symbols_to_fun_vars = + Variable.Set.fold (fun fun_var symbols_to_fun_vars -> + let closure_id = Closure_id.wrap fun_var in + let symbol = closure_symbol closure_id in + Symbol.Map.add symbol fun_var symbols_to_fun_vars) + fun_vars + Symbol.Map.empty + in + Variable.Map.map (fun (func_decl : Flambda.function_declaration) -> + let from_symbols = + Symbol.Set.fold (fun symbol fun_vars' -> + match Symbol.Map.find symbol symbols_to_fun_vars with + | exception Not_found -> fun_vars' + | fun_var -> + assert (Variable.Set.mem fun_var fun_vars); + Variable.Set.add fun_var fun_vars') + func_decl.free_symbols + Variable.Set.empty + in + let from_variables = + Variable.Set.inter func_decl.free_variables fun_vars + in + Variable.Set.union from_symbols from_variables) + function_decls.funs + +let closures_required_by_entry_point ~(entry_point : Closure_id.t) + ~closure_symbol (function_decls : Flambda.function_declarations) = + let dependencies = + fun_vars_referenced_in_decls function_decls ~closure_symbol + in + let set = ref Variable.Set.empty in + let queue = Queue.create () in + let add v = + if not (Variable.Set.mem v !set) then begin + set := Variable.Set.add v !set; + Queue.push v queue + end + in + add (Closure_id.unwrap entry_point); + while not (Queue.is_empty queue) do + let fun_var = Queue.pop queue in + match Variable.Map.find fun_var dependencies with + | exception Not_found -> () + | fun_dependencies -> + Variable.Set.iter (fun dep -> + if Variable.Map.mem dep function_decls.funs then + add dep) + fun_dependencies + done; + !set + +let all_functions_parameters (function_decls : Flambda.function_declarations) = + Variable.Map.fold (fun _ ({ params } : Flambda.function_declaration) set -> + Variable.Set.union set (Parameter.Set.vars params)) + function_decls.funs Variable.Set.empty + +let all_free_symbols (function_decls : Flambda.function_declarations) = + Variable.Map.fold (fun _ (function_decl : Flambda.function_declaration) + syms -> + Symbol.Set.union syms function_decl.free_symbols) + function_decls.funs Symbol.Set.empty + +let contains_stub (fun_decls : Flambda.function_declarations) = + let number_of_stub_functions = + Variable.Map.cardinal + (Variable.Map.filter (fun _ { Flambda.stub } -> stub) + fun_decls.funs) + in + number_of_stub_functions > 0 + +let clean_projections ~which_variables = + Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> + match spec_to.projection with + | None -> spec_to + | Some projection -> + let from = Projection.projecting_from projection in + if Variable.Map.mem from which_variables then + spec_to + else + ({ spec_to with projection = None; } : Flambda.specialised_to)) + which_variables + +let projection_to_named (projection : Projection.t) : Flambda.named = + match projection with + | Project_var project_var -> Project_var project_var + | Project_closure project_closure -> Project_closure project_closure + | Move_within_set_of_closures move -> Move_within_set_of_closures move + | Field (field_index, var) -> + Prim (Pfield field_index, [var], Debuginfo.none) + +type specialised_to_same_as = + | Not_specialised + | Specialised_and_aliased_to of Variable.Set.t + +let parameters_specialised_to_the_same_variable + ~(function_decls : Flambda.function_declarations) + ~(specialised_args : Flambda.specialised_to Variable.Map.t) = + let specialised_arg_aliasing = + (* For each external variable involved in a specialisation, which + internal variable(s) it maps to via that specialisation. *) + Variable.Map.transpose_keys_and_data_set + (Variable.Map.map (fun ({ var; _ } : Flambda.specialised_to) -> var) + specialised_args) + in + Variable.Map.map (fun ({ params; _ } : Flambda.function_declaration) -> + List.map (fun param -> + match Variable.Map.find (Parameter.var param) specialised_args with + | exception Not_found -> Not_specialised + | { var; _ } -> + Specialised_and_aliased_to + (Variable.Map.find var specialised_arg_aliasing)) + params) + function_decls.funs diff --git a/middle_end/flambda/flambda_utils.mli b/middle_end/flambda/flambda_utils.mli new file mode 100644 index 00000000..0f7b3186 --- /dev/null +++ b/middle_end/flambda/flambda_utils.mli @@ -0,0 +1,220 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Utility functions for the Flambda intermediate language. *) + +(** Access functions *) + +(** [find_declaration f decl] raises [Not_found] if [f] is not in [decl]. *) +val find_declaration : + Closure_id.t -> Flambda.function_declarations -> Flambda.function_declaration + +(** [find_declaration_variable f decl] raises [Not_found] if [f] is not in + [decl]. *) +val find_declaration_variable : + Closure_id.t -> Flambda.function_declarations -> Variable.t + +(** [find_free_variable v clos] raises [Not_found] if [c] is not in [clos]. *) +val find_free_variable : + Var_within_closure.t -> Flambda.set_of_closures -> Variable.t + +(** Utility functions *) + +val function_arity : Flambda.function_declaration -> int + +(** Variables "bound by a closure" are those variables free in the + corresponding function's body that are neither: + - bound as parameters of that function; nor + - bound by the [let] binding that introduces the function declaration(s). + In particular, if [f], [g] and [h] are being introduced by a + simultaneous, possibly mutually-recursive [let] binding then none of + [f], [g] or [h] are bound in any of the closures for [f], [g] and [h]. +*) +val variables_bound_by_the_closure : + Closure_id.t -> Flambda.function_declarations -> Variable.Set.t + +(** If [can_be_merged f1 f2] is [true], it is safe to merge switch + branches containing [f1] and [f2]. *) +val can_be_merged : Flambda.t -> Flambda.t -> bool + +val description_of_toplevel_node : Flambda.t -> string + +(* Given an expression, freshen all variables within it, and form a function + whose body is the resulting expression. The variables specified by + [params] will become the parameters of the function; the closure will be + identified by [id]. [params] must only reference variables that are + free variables of [body]. *) +(* CR-soon mshinwell: consider improving name and names of arguments + lwhite: the params restriction seems odd, perhaps give a reason + in the comment. *) +val make_closure_declaration + : is_classic_mode:bool + -> id:Variable.t + -> body:Flambda.t + -> params:Parameter.t list + -> stub:bool + -> Flambda.t + +val toplevel_substitution + : Variable.t Variable.Map.t + -> Flambda.expr + -> Flambda.expr + +val toplevel_substitution_named + : Variable.t Variable.Map.t + -> Flambda.named + -> Flambda.named + +(** [bind [var1, expr1; ...; varN, exprN] body] binds using + [Immutable] [Let] expressions the given [(var, expr)] pairs around the + body. *) +val bind + : bindings:(Variable.t * Flambda.named) list + -> body:Flambda.t + -> Flambda.t + +val name_expr + : name:Internal_variable_names.t + -> Flambda.named + -> Flambda.t + +val name_expr_from_var + : var:Variable.t + -> Flambda.named + -> Flambda.t + +val initialize_symbols + : Flambda.program + -> (Symbol.t * Tag.t * Flambda.t list) list + +val imported_symbols : Flambda.program -> Symbol.Set.t + +val needed_import_symbols : Flambda.program -> Symbol.Set.t + +val introduce_needed_import_symbols : Flambda.program -> Flambda.program + +val root_symbol : Flambda.program -> Symbol.t + +(** Returns [true] iff the given term might raise the given static + exception. *) +val might_raise_static_exn : Flambda.named -> Static_exception.t -> bool + +(** Creates a map from closure IDs to set_of_closure IDs by iterating over + all sets of closures in the given program. *) +val make_closure_map + : Flambda.program + -> Set_of_closures_id.t Closure_id.Map.t + +(** The definitions of all constants that have been lifted out to [Let_symbol] + or [Let_rec_symbol] constructions. *) +val all_lifted_constants + : Flambda.program + -> (Symbol.t * Flambda.constant_defining_value) list + +(** Like [all_lifted_constant_symbols], but returns a map instead of a list. *) +val all_lifted_constants_as_map + : Flambda.program + -> Flambda.constant_defining_value Symbol.Map.t + +(** The identifiers of all constant sets of closures that have been lifted out + to [Let_symbol] or [Let_rec_symbol] constructions. *) +val all_lifted_constant_sets_of_closures + : Flambda.program + -> Set_of_closures_id.Set.t + +val all_lifted_constant_closures : Flambda.program -> Closure_id.Set.t + +(** All sets of closures in the given program (whether or not bound to a + symbol.) *) +val all_sets_of_closures : Flambda.program -> Flambda.set_of_closures list + +val all_sets_of_closures_map + : Flambda.program + -> Flambda.set_of_closures Set_of_closures_id.Map.t + + +(* CR-someday pchambart: A more general version of this function might + take a [named] instead of a symbol and be called with + [Read_symbol_field (symbol, 0)]. *) +val substitute_read_symbol_field_for_variables + : (Symbol.t * int list) Variable.Map.t + -> Flambda.t + -> Flambda.t + +(** For the compilation of switch statements. *) +module Switch_storer : sig + val mk_store : unit -> (Flambda.t, unit) Switch.t_store +end + +(** Within a set of function declarations there is a set of function bodies, + each of which may (or may not) reference one of the other functions in + the same set. Initially such intra-set references are by [Var]s (known + as "fun_var"s) but if the function is lifted by [Lift_constants] then the + references will be translated to [Symbol]s. This means that optimization + passes that need to identify whether a given "fun_var" (i.e. a key in the + [funs] map in a value of type [function_declarations]) is used in one of + the function bodies need to examine the [free_symbols] as well as the + [free_variables] members of [function_declarations]. This function makes + that process easier by computing all used "fun_var"s in the bodies of + the given set of function declarations, including the cases where the + references are [Symbol]s. The returned value is a map from "fun_var"s + to the "fun_var"s (if any) used in the body of the function associated + with that "fun_var". +*) +val fun_vars_referenced_in_decls + : Flambda.function_declarations + -> closure_symbol:(Closure_id.t -> Symbol.t) + -> Variable.Set.t Variable.Map.t + +(** Computes the set of closure_id in the set of closures that are + required used (transitively) the entry_point *) +val closures_required_by_entry_point + : entry_point:Closure_id.t + -> closure_symbol:(Closure_id.t -> Symbol.t) + -> Flambda.function_declarations + -> Variable.Set.t + +val all_functions_parameters : Flambda.function_declarations -> Variable.Set.t + +val all_free_symbols : Flambda.function_declarations -> Symbol.Set.t + +val contains_stub : Flambda.function_declarations -> bool + +(* Ensure that projection information is suitably erased from + free_vars and specialised_args if we have deleted the variable being + projected from. *) +val clean_projections + : which_variables : Flambda.specialised_to Variable.Map.t + -> Flambda.specialised_to Variable.Map.t + +val projection_to_named : Projection.t -> Flambda.named + +type specialised_to_same_as = + | Not_specialised + | Specialised_and_aliased_to of Variable.Set.t + +(** For each parameter in a given set of function declarations and the usual + specialised-args mapping, determine which other parameters are specialised + to the same variable as that parameter. + The result is presented as a map from [fun_vars] to lists, corresponding + componentwise to the usual [params] list in the corresponding function + declaration. *) +val parameters_specialised_to_the_same_variable + : function_decls:Flambda.function_declarations + -> specialised_args:Flambda.specialised_to Variable.Map.t + -> specialised_to_same_as list Variable.Map.t diff --git a/middle_end/flambda/freshening.ml b/middle_end/flambda/freshening.ml new file mode 100644 index 00000000..891861a3 --- /dev/null +++ b/middle_end/flambda/freshening.ml @@ -0,0 +1,458 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type tbl = { + sb_var : Variable.t Variable.Map.t; + sb_mutable_var : Mutable_variable.t Mutable_variable.Map.t; + sb_exn : Static_exception.t Static_exception.Map.t; + (* Used to handle substitution sequences: we cannot call the substitution + recursively because there can be name clashes. *) + back_var : Variable.t list Variable.Map.t; + back_mutable_var : Mutable_variable.t list Mutable_variable.Map.t; +} + +type t = + | Inactive + | Active of tbl + +type subst = t + +let empty_tbl = { + sb_var = Variable.Map.empty; + sb_mutable_var = Mutable_variable.Map.empty; + sb_exn = Static_exception.Map.empty; + back_var = Variable.Map.empty; + back_mutable_var = Mutable_variable.Map.empty; +} + +let print ppf = function + | Inactive -> Format.fprintf ppf "Inactive" + | Active tbl -> + Format.fprintf ppf "Active:@ "; + Variable.Map.iter (fun var1 var2 -> + Format.fprintf ppf "%a -> %a@ " + Variable.print var1 + Variable.print var2) + tbl.sb_var; + Mutable_variable.Map.iter (fun mut_var1 mut_var2 -> + Format.fprintf ppf "(mutable) %a -> %a@ " + Mutable_variable.print mut_var1 + Mutable_variable.print mut_var2) + tbl.sb_mutable_var; + Variable.Map.iter (fun var vars -> + Format.fprintf ppf "%a -> %a@ " + Variable.print var + Variable.Set.print (Variable.Set.of_list vars)) + tbl.back_var; + Mutable_variable.Map.iter (fun mut_var mut_vars -> + Format.fprintf ppf "(mutable) %a -> %a@ " + Mutable_variable.print mut_var + Mutable_variable.Set.print (Mutable_variable.Set.of_list mut_vars)) + tbl.back_mutable_var + +let empty = Inactive + +let is_empty = function + | Inactive -> true + | Active _ -> false + +let empty_preserving_activation_state = function + | Inactive -> Inactive + | Active _ -> Active empty_tbl + +let activate = function + | Inactive -> Active empty_tbl + | Active _ as t -> t + +let rec add_sb_var sb id id' = + let sb = { sb with sb_var = Variable.Map.add id id' sb.sb_var } in + let sb = + try let pre_vars = Variable.Map.find id sb.back_var in + List.fold_left (fun sb pre_id -> add_sb_var sb pre_id id') sb pre_vars + with Not_found -> sb in + let back_var = + let l = try Variable.Map.find id' sb.back_var with Not_found -> [] in + Variable.Map.add id' (id :: l) sb.back_var in + { sb with back_var } + +let rec add_sb_mutable_var sb id id' = + let sb = + { sb with + sb_mutable_var = Mutable_variable.Map.add id id' sb.sb_mutable_var; + } + in + let sb = + try + let pre_vars = Mutable_variable.Map.find id sb.back_mutable_var in + List.fold_left (fun sb pre_id -> add_sb_mutable_var sb pre_id id') + sb pre_vars + with Not_found -> sb in + let back_mutable_var = + let l = + try Mutable_variable.Map.find id' sb.back_mutable_var + with Not_found -> [] + in + Mutable_variable.Map.add id' (id :: l) sb.back_mutable_var + in + { sb with back_mutable_var } + +let apply_static_exception t i = + match t with + | Inactive -> + i + | Active t -> + try Static_exception.Map.find i t.sb_exn + with Not_found -> i + +let add_static_exception t i = + match t with + | Inactive -> i, t + | Active t -> + let i' = Static_exception.create () in + let sb_exn = + Static_exception.Map.add i i' t.sb_exn + in + i', Active { t with sb_exn; } + +let active_add_variable t id = + let id' = Variable.rename id in + let t = add_sb_var t id id' in + id', t + +let active_add_parameter t param = + let param' = Parameter.rename param in + let t = add_sb_var t (Parameter.var param) (Parameter.var param') in + param', t + +let add_variable t id = + match t with + | Inactive -> id, t + | Active t -> + let id', t = active_add_variable t id in + id', Active t + +let active_add_parameters' t (params:Parameter.t list) = + List.fold_right (fun param (params, t) -> + let param', t = active_add_parameter t param in + param' :: params, t) + params ([], t) + +let add_variables t defs = + List.fold_right (fun (id, data) (defs, t) -> + let id', t = add_variable t id in + (id', data) :: defs, t) defs ([], t) + +let add_variables' t ids = + List.fold_right (fun id (ids, t) -> + let id', t = add_variable t id in + id' :: ids, t) ids ([], t) + +let active_add_mutable_variable t id = + let id' = Mutable_variable.rename id in + let t = add_sb_mutable_var t id id' in + id', t + +let add_mutable_variable t id = + match t with + | Inactive -> id, t + | Active t -> + let id', t = active_add_mutable_variable t id in + id', Active t + +let active_find_var_exn t id = + try Variable.Map.find id t.sb_var with + | Not_found -> + Misc.fatal_error (Format.asprintf "find_var: can't find %a@." + Variable.print id) + +let apply_variable t var = + match t with + | Inactive -> var + | Active t -> + try Variable.Map.find var t.sb_var with + | Not_found -> var + +let apply_mutable_variable t mut_var = + match t with + | Inactive -> mut_var + | Active t -> + try Mutable_variable.Map.find mut_var t.sb_mutable_var with + | Not_found -> mut_var + +let rewrite_recursive_calls_with_symbols t + (function_declarations : Flambda.function_declarations) + ~make_closure_symbol = + match t with + | Inactive -> function_declarations + | Active _ -> + let all_free_symbols = + Variable.Map.fold + (fun _ (function_decl : Flambda.function_declaration) + syms -> + Symbol.Set.union syms function_decl.free_symbols) + function_declarations.funs Symbol.Set.empty + in + let closure_symbols_used = ref false in + let closure_symbols = + Variable.Map.fold (fun var _ map -> + let closure_id = Closure_id.wrap var in + let sym = make_closure_symbol closure_id in + if Symbol.Set.mem sym all_free_symbols then begin + closure_symbols_used := true; + Symbol.Map.add sym var map + end else begin + map + end) + function_declarations.funs Symbol.Map.empty + in + if not !closure_symbols_used then begin + (* Don't waste time rewriting the function declaration(s) if there + are no occurrences of any of the closure symbols. *) + function_declarations + end else begin + let funs = + Variable.Map.map (fun (ffun : Flambda.function_declaration) -> + let body = + Flambda_iterators.map_toplevel_named + (* CR-someday pchambart: This may be worth deep substituting + below the closures, but that means that we need to take care + of functions' free variables. *) + (function + | Symbol sym when Symbol.Map.mem sym closure_symbols -> + Expr (Var (Symbol.Map.find sym closure_symbols)) + | e -> e) + ffun.body + in + Flambda.update_body_of_function_declaration ffun ~body) + function_declarations.funs + in + Flambda.update_function_declarations function_declarations ~funs + end + +module Project_var = struct + type t = + { vars_within_closure : Var_within_closure.t Var_within_closure.Map.t; + closure_id : Closure_id.t Closure_id.Map.t } + + let empty = + { vars_within_closure = Var_within_closure.Map.empty; + closure_id = Closure_id.Map.empty; + } + + let print ppf t = + Format.fprintf ppf "{ vars_within_closure %a, closure_id %a }" + (Var_within_closure.Map.print Var_within_closure.print) + t.vars_within_closure + (Closure_id.Map.print Closure_id.print) + t.closure_id + + let new_subst_fv t id subst = + match subst with + | Inactive -> id, subst, t + | Active subst -> + let id' = Variable.rename id in + let subst = add_sb_var subst id id' in + let off = Var_within_closure.wrap id in + let off' = Var_within_closure.wrap id' in + let off_sb = Var_within_closure.Map.add off off' t.vars_within_closure in + id', Active subst, { t with vars_within_closure = off_sb; } + + let new_subst_fun t id subst = + let id' = Variable.rename id in + let subst = add_sb_var subst id id' in + let off = Closure_id.wrap id in + let off' = Closure_id.wrap id' in + let off_sb = Closure_id.Map.add off off' t.closure_id in + id', subst, { t with closure_id = off_sb; } + + (** Returns : + * The map of new_identifiers -> expression + * The new environment with added substitution + * a fresh ffunction_subst with only the substitution of free variables + *) + let subst_free_vars fv subst ~only_freshen_parameters + : (Flambda.specialised_to * _) Variable.Map.t * _ * _ = + Variable.Map.fold (fun id lam (fv, subst, t) -> + let id, subst, t = + if only_freshen_parameters then + id, subst, t + else + new_subst_fv t id subst + in + Variable.Map.add id lam fv, subst, t) + fv + (Variable.Map.empty, subst, empty) + + (** Returns : + * The function_declaration with renamed function identifiers + * The new environment with added substitution + * The ffunction_subst completed with function substitution + + subst_free_vars must have been used to build off_sb + *) + let func_decls_subst t (subst : subst) + (func_decls : Flambda.function_declarations) + ~only_freshen_parameters = + match subst with + | Inactive -> func_decls, subst, t + | Active subst -> + let subst_func_decl _fun_id (func_decl : Flambda.function_declaration) + subst = + let params, subst = active_add_parameters' subst func_decl.params in + (* Since all parameters are distinct, even between functions, we can + just use a single substitution. *) + let body = + Flambda_utils.toplevel_substitution subst.sb_var func_decl.body + in + let function_decl = + Flambda.create_function_declaration ~params ~body + ~stub:func_decl.stub ~dbg:func_decl.dbg + ~inline:func_decl.inline ~specialise:func_decl.specialise + ~is_a_functor:func_decl.is_a_functor + ~closure_origin:func_decl.closure_origin + in + function_decl, subst + in + let subst, t = + if only_freshen_parameters then + subst, t + else + Variable.Map.fold (fun orig_id _func_decl (subst, t) -> + let _id, subst, t = new_subst_fun t orig_id subst in + subst, t) + func_decls.funs + (subst, t) + in + let funs, subst = + Variable.Map.fold (fun orig_id func_decl (funs, subst) -> + let func_decl, subst = subst_func_decl orig_id func_decl subst in + let id = + if only_freshen_parameters then orig_id + else active_find_var_exn subst orig_id + in + let funs = Variable.Map.add id func_decl funs in + funs, subst) + func_decls.funs + (Variable.Map.empty, subst) + in + let function_decls = + Flambda.update_function_declarations func_decls ~funs + in + function_decls, Active subst, t + + let apply_closure_id t closure_id = + try Closure_id.Map.find closure_id t.closure_id + with Not_found -> closure_id + + let apply_var_within_closure t var_in_closure = + try Var_within_closure.Map.find var_in_closure t.vars_within_closure + with Not_found -> var_in_closure + + module Compose (T : Identifiable.S) = struct + let compose ~earlier ~later = + if (T.Map.equal T.equal) earlier later + || T.Map.cardinal later = 0 + then + earlier + else + T.Map.mapi (fun src_var var -> + if T.Map.mem src_var later then begin + Misc.fatal_errorf "Freshening.Project_var.compose: domains \ + of substitutions must be disjoint. earlier=%a later=%a" + (T.Map.print T.print) earlier + (T.Map.print T.print) later + end; + match T.Map.find var later with + | exception Not_found -> var + | var -> var) + earlier + end + + module V = Compose (Var_within_closure) + module C = Compose (Closure_id) + + let compose ~earlier ~later : t = + { vars_within_closure = + V.compose ~earlier:earlier.vars_within_closure + ~later:later.vars_within_closure; + closure_id = + C.compose ~earlier:earlier.closure_id + ~later:later.closure_id; + } +end + +let apply_function_decls_and_free_vars t fv func_decls + ~only_freshen_parameters = + let module I = Project_var in + let fv, t, of_closures = I.subst_free_vars fv t ~only_freshen_parameters in + let func_decls, t, of_closures = + I.func_decls_subst of_closures t func_decls ~only_freshen_parameters + in + fv, func_decls, t, of_closures + +let does_not_freshen t vars = + match t with + | Inactive -> true + | Active subst -> + not (List.exists (fun var -> Variable.Map.mem var subst.sb_var) vars) + +let freshen_projection (projection : Projection.t) ~freshening + ~closure_freshening : Projection.t = + match projection with + | Project_var { closure; closure_id; var; } -> + Project_var { + closure = apply_variable freshening closure; + closure_id = Project_var.apply_closure_id closure_freshening closure_id; + var = Project_var.apply_var_within_closure closure_freshening var; + } + | Project_closure { set_of_closures; closure_id; } -> + Project_closure { + set_of_closures = apply_variable freshening set_of_closures; + closure_id = Project_var.apply_closure_id closure_freshening closure_id; + } + | Move_within_set_of_closures { closure; start_from; move_to; } -> + Move_within_set_of_closures { + closure = apply_variable freshening closure; + start_from = Project_var.apply_closure_id closure_freshening start_from; + move_to = Project_var.apply_closure_id closure_freshening move_to; + } + | Field (field_index, var) -> + Field (field_index, apply_variable freshening var) + +let freshen_projection_relation relation ~freshening ~closure_freshening = + Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> + let projection = + match spec_to.projection with + | None -> None + | Some projection -> + Some (freshen_projection projection ~freshening ~closure_freshening) + in + { spec_to with projection; }) + relation + +let freshen_projection_relation' relation ~freshening ~closure_freshening = + Variable.Map.map (fun ((spec_to : Flambda.specialised_to), data) -> + let projection = + match spec_to.projection with + | None -> None + | Some projection -> + Some (freshen_projection projection ~freshening ~closure_freshening) + in + { spec_to with projection; }, data) + relation diff --git a/middle_end/flambda/freshening.mli b/middle_end/flambda/freshening.mli new file mode 100644 index 00000000..1550797a --- /dev/null +++ b/middle_end/flambda/freshening.mli @@ -0,0 +1,167 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Freshening of various identifiers. *) + +(** A table used for freshening variables and static exception identifiers. *) +type t +type subst = t + +(** The freshening that does nothing. This is the unique inactive + freshening. *) +val empty : t + +val is_empty : t -> bool + +(** Activate the freshening. Without activation, operations to request + freshenings have no effect (cf. the documentation below for + [add_variable]). As such, the inactive renaming is unique. *) +val activate : t -> t + +(** Given the inactive freshening, return the same; otherwise, return an + empty active freshening. *) +val empty_preserving_activation_state : t -> t + +(** [add_variable t var] + If [t] is active: + It returns a fresh variable [new_var] and adds [var] -> [new_var] + to the freshening. + If a renaming [other_var] -> [var] or [symbol] -> [var] was already + present in [t], it will also add [other_var] -> [new_var] and + [symbol] -> [new_var]. + If [t] is inactive, this is the identity. +*) +val add_variable : t -> Variable.t -> Variable.t * t + +(** Like [add_variable], but for multiple variables, each freshened + separately. *) +val add_variables' + : t + -> Variable.t list + -> Variable.t list * t + +(** Like [add_variables'], but passes through the second component of the + input list unchanged. *) +val add_variables + : t + -> (Variable.t * 'a) list + -> (Variable.t * 'a) list * t + +(** Like [add_variable], but for mutable variables. *) +val add_mutable_variable : t -> Mutable_variable.t -> Mutable_variable.t * t + +(** As for [add_variable], but for static exception identifiers. *) +val add_static_exception : t -> Static_exception.t -> Static_exception.t * t + +(** [apply_variable t var] applies the freshening [t] to [var]. + If no renaming is specified in [t] for [var] it is returned unchanged. *) +val apply_variable : t -> Variable.t -> Variable.t + +(** As for [apply_variable], but for mutable variables. *) +val apply_mutable_variable : t -> Mutable_variable.t -> Mutable_variable.t + +(** As for [apply_variable], but for static exception identifiers. *) +val apply_static_exception : t -> Static_exception.t -> Static_exception.t + +(** Replace recursive accesses to the closures in the set through + [Symbol] by the corresponding [Var]. This is used to recover + the recursive call when importing code from another compilation unit. + + If the renaming is inactive, this is the identity. +*) +val rewrite_recursive_calls_with_symbols + : t + -> Flambda.function_declarations + -> make_closure_symbol:(Closure_id.t -> Symbol.t) + -> Flambda.function_declarations + +(* CR-soon mshinwell for mshinwell: maybe inaccurate module name, it freshens + closure IDs as well. Check use points though *) +module Project_var : sig + (** A table used for freshening of identifiers in [Project_closure] and + [Move_within_set_of_closures] ("ids of closures"); and [Project_var] + ("bound vars of closures") expressions. + + This information is propagated bottom up and populated when inlining a + function containing a closure declaration. + + For instance, + [let f x = + let g y = ... x ... in + ... g.x ... (Project_var x) + ... g 1 ... (Apply (Project_closure g ...)) + ] + + If f is inlined, g is renamed. The approximation of g will carry this + table such that later the access to the field x of g and selection of + g in the closure can be substituted. + *) + type t + + (* The freshening that does nothing. *) + val empty : t + + (** Composition of two freshenings. *) + val compose : earlier:t -> later:t -> t + + (** Freshen a closure ID based on the given renaming. The same ID is + returned if the renaming does not affect it. + If dealing with approximations, you probably want to use + [Simple_value_approx.freshen_and_check_closure_id] instead of this + function. + *) + val apply_closure_id : t -> Closure_id.t -> Closure_id.t + + (** Like [apply_closure_id], but for variables within closures. *) + val apply_var_within_closure + : t + -> Var_within_closure.t + -> Var_within_closure.t + + val print : Format.formatter -> t -> unit +end + +(* CR-soon mshinwell for mshinwell: add comment *) +val apply_function_decls_and_free_vars + : t + -> (Flambda.specialised_to * 'a) Variable.Map.t + -> Flambda.function_declarations + -> only_freshen_parameters:bool + -> (Flambda.specialised_to * 'a) Variable.Map.t + * Flambda.function_declarations + * t + * Project_var.t + +val does_not_freshen : t -> Variable.t list -> bool + +val print : Format.formatter -> t -> unit + +(** N.B. This does not freshen the domain of the supplied map, only the + range. *) +(* CR-someday mshinwell: consider fixing that *) +val freshen_projection_relation + : Flambda.specialised_to Variable.Map.t + -> freshening:t + -> closure_freshening:Project_var.t + -> Flambda.specialised_to Variable.Map.t + +val freshen_projection_relation' + : (Flambda.specialised_to * 'a) Variable.Map.t + -> freshening:t + -> closure_freshening:Project_var.t + -> (Flambda.specialised_to * 'a) Variable.Map.t diff --git a/middle_end/flambda/import_approx.ml b/middle_end/flambda/import_approx.ml new file mode 100644 index 00000000..64fbbb8b --- /dev/null +++ b/middle_end/flambda/import_approx.ml @@ -0,0 +1,222 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +module A = Simple_value_approx + +let import_set_of_closures = + let import_function_declarations (clos : A.function_declarations) + : A.function_declarations = + (* CR-soon mshinwell for pchambart: Do we still need to do this + rewriting? I'm wondering if maybe we don't have to any more. *) + let sym_to_fun_var_map (clos : A.function_declarations) = + Variable.Map.fold (fun fun_var _ acc -> + let closure_id = Closure_id.wrap fun_var in + let sym = Compilenv.closure_symbol closure_id in + Symbol.Map.add sym fun_var acc) + clos.funs Symbol.Map.empty + in + let sym_map = sym_to_fun_var_map clos in + let f_named (named : Flambda.named) = + match named with + | Symbol sym -> + begin try Flambda.Expr (Var (Symbol.Map.find sym sym_map)) with + | Not_found -> named + end + | named -> named + in + let funs = + Variable.Map.map (fun (function_decl : A.function_declaration) -> + A.update_function_declaration_body function_decl + (Flambda_iterators.map_toplevel_named f_named)) + clos.funs + in + A.update_function_declarations clos ~funs + in + let aux set_of_closures_id = + match + Compilenv.approx_for_global + (Set_of_closures_id.get_compilation_unit set_of_closures_id) + with + | None -> None + | Some ex_info -> + try + let function_declarations = + Set_of_closures_id.Map.find set_of_closures_id + ex_info.sets_of_closures + in + Some (import_function_declarations function_declarations) + with Not_found -> + Misc.fatal_error "Cannot find set of closures" + in + Set_of_closures_id.Tbl.memoize Compilenv.imported_sets_of_closures_table aux + +let rec import_ex ex = + let import_value_set_of_closures ~set_of_closures_id ~bound_vars ~free_vars + ~(ex_info : Export_info.t) ~what : A.value_set_of_closures option = + let bound_vars = Var_within_closure.Map.map import_approx bound_vars in + match import_set_of_closures set_of_closures_id with + | None -> None + | Some function_decls -> + (* CR-someday xclerc: add a test to the test suite to ensure that + classic mode behaves as expected. *) + let is_classic_mode = function_decls.is_classic_mode in + let invariant_params = + match + Set_of_closures_id.Map.find set_of_closures_id + ex_info.invariant_params + with + | exception Not_found -> + if is_classic_mode then + Variable.Map.empty + else + Misc.fatal_errorf "Set of closures ID %a not found in \ + invariant_params (when importing [%a: %s])" + Set_of_closures_id.print set_of_closures_id + Export_id.print ex + what + | found -> found + in + let recursive = + match + Set_of_closures_id.Map.find set_of_closures_id ex_info.recursive + with + | exception Not_found -> + if is_classic_mode then + Variable.Set.empty + else + Misc.fatal_errorf "Set of closures ID %a not found in \ + recursive (when importing [%a: %s])" + Set_of_closures_id.print set_of_closures_id + Export_id.print ex + what + | found -> found + in + Some (A.create_value_set_of_closures + ~function_decls + ~bound_vars + ~free_vars + ~invariant_params:(lazy invariant_params) + ~recursive:(lazy recursive) + ~specialised_args:Variable.Map.empty + ~freshening:Freshening.Project_var.empty + ~direct_call_surrogates:Closure_id.Map.empty) + in + let compilation_unit = Export_id.get_compilation_unit ex in + match Compilenv.approx_for_global compilation_unit with + | None -> A.value_unknown Other + | Some ex_info -> + match Export_info.find_description ex_info ex with + | exception Not_found -> + Misc.fatal_errorf "Cannot find export id %a" Export_id.print ex + | Value_unknown_descr -> A.value_unknown Other + | Value_int i -> A.value_int i + | Value_char c -> A.value_char c + | Value_constptr i -> A.value_constptr i + | Value_float f -> A.value_float f + | Value_float_array float_array -> + begin match float_array.contents with + | Unknown_or_mutable -> + A.value_mutable_float_array ~size:float_array.size + | Contents contents -> + A.value_immutable_float_array + (Array.map (function + | None -> A.value_any_float + | Some f -> A.value_float f) + contents) + end + | Export_info.Value_boxed_int (t, i) -> A.value_boxed_int t i + | Value_string { size; contents } -> + let contents = + match contents with + | Unknown_or_mutable -> None + | Contents contents -> Some contents + in + A.value_string size contents + | Value_mutable_block _ -> A.value_unknown Other + | Value_block (tag, fields) -> + A.value_block tag (Array.map import_approx fields) + | Value_closure { closure_id; + set_of_closures = + { set_of_closures_id; bound_vars; free_vars; aliased_symbol } } -> + let value_set_of_closures = + import_value_set_of_closures + ~set_of_closures_id ~bound_vars ~free_vars ~ex_info + ~what:(Format.asprintf "Value_closure %a" Closure_id.print closure_id) + in + begin match value_set_of_closures with + | None -> A.value_unresolved (Set_of_closures_id set_of_closures_id) + | Some value_set_of_closures -> + A.value_closure ?set_of_closures_symbol:aliased_symbol + value_set_of_closures closure_id + end + | Value_set_of_closures + { set_of_closures_id; bound_vars; free_vars; aliased_symbol } -> + let value_set_of_closures = + import_value_set_of_closures ~set_of_closures_id + ~bound_vars ~free_vars ~ex_info ~what:"Value_set_of_closures" + in + match value_set_of_closures with + | None -> + A.value_unresolved (Set_of_closures_id set_of_closures_id) + | Some value_set_of_closures -> + let approx = A.value_set_of_closures value_set_of_closures in + match aliased_symbol with + | None -> approx + | Some symbol -> A.augment_with_symbol approx symbol + +and import_approx (ap : Export_info.approx) = + match ap with + | Value_unknown -> A.value_unknown Other + | Value_id ex -> A.value_extern ex + | Value_symbol sym -> A.value_symbol sym + +let import_symbol sym = + if Compilenv.is_predefined_exception sym then + A.value_unknown Other + else begin + let compilation_unit = Symbol.compilation_unit sym in + match Compilenv.approx_for_global compilation_unit with + | None -> A.value_unresolved (Symbol sym) + | Some export_info -> + match Symbol.Map.find sym export_info.symbol_id with + | approx -> A.augment_with_symbol (import_ex approx) sym + | exception Not_found -> + Misc.fatal_errorf + "Compilation unit = %a Cannot find symbol %a" + Compilation_unit.print compilation_unit + Symbol.print sym + end + +(* Note for code reviewers: Observe that [really_import] iterates until + the approximation description is fully resolved (or a necessary .cmx + file is missing). *) + +let rec really_import (approx : A.descr) = + match approx with + | Value_extern ex -> really_import_ex ex + | Value_symbol sym -> really_import_symbol sym + | r -> r + +and really_import_ex ex = + really_import (import_ex ex).descr + +and really_import_symbol sym = + really_import (import_symbol sym).descr + +let really_import_approx (approx : Simple_value_approx.t) = + A.replace_description approx (really_import approx.descr) diff --git a/middle_end/flambda/import_approx.mli b/middle_end/flambda/import_approx.mli new file mode 100644 index 00000000..23d9d294 --- /dev/null +++ b/middle_end/flambda/import_approx.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Create simple value approximations from the export information in + .cmx files. *) + +(** Given an approximation description, load .cmx files (possibly more + than one) until the description is fully resolved. If a necessary .cmx + file cannot be found, "unresolved" will be returned. *) +val really_import : Simple_value_approx.descr -> Simple_value_approx.descr + +(** Maps the description of the given approximation through [really_import]. *) +val really_import_approx : Simple_value_approx.t -> Simple_value_approx.t + +(** Read and convert the approximation of a given symbol from the + relevant .cmx file. Unlike the "really_" functions, this does not + continue to load .cmx files until the approximation is fully + resolved. *) +val import_symbol : Symbol.t -> Simple_value_approx.t diff --git a/middle_end/flambda/inconstant_idents.ml b/middle_end/flambda/inconstant_idents.ml new file mode 100644 index 00000000..59f8aa8a --- /dev/null +++ b/middle_end/flambda/inconstant_idents.ml @@ -0,0 +1,502 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +(* This cannot be done in a single simple pass due to expressions like: + + let rec ... = + ... + let rec f1 x = + let f2 y = + f1 rec_list + in + f2 v + and rec_list = f1 :: rec_list in + ... + + and v = ... + + f1, f2 and rec_list are constants iff v is a constant. + + To handle this we populate both a 'not constant' set NC and a set of + implications between variables. + + For example, the above code would generate the implications: + + f1 in NC => rec_list in NC + f2 in NC => f1 in NC + rec_list in NC => f2 in NC + v in NC => f1 in NC + + then if v is found to be in NC this will be propagated to place + f1, f2 and rec_list in NC as well. + +*) + +(* CR-someday lwhite: I think this pass could be combined with + alias_analysis and other parts of lift_constants into a single + type-based analysis which infers a "type" for each variable that is + either an allocated_constant expression or "not constant". Recursion + would be handled with unification variables. *) + +module Int = Numbers.Int +module Symbol_field = struct + type t = Symbol.t * Int.t + include Identifiable.Make (Identifiable.Pair (Symbol) (Int)) +end + +type dep = + | Closure of Set_of_closures_id.t + | Var of Variable.t + | Symbol of Symbol.t + | Symbol_field of Symbol_field.t + +type state = + | Not_constant + | Implication of dep list + +type result = { + id : state Variable.Tbl.t; + closure : state Set_of_closures_id.Tbl.t; +} + +module type Param = sig + val program : Flambda.program + val compilation_unit : Compilation_unit.t +end + +(* CR-soon mshinwell: consider removing functor *) +module Inconstants (P:Param) (Backend:Backend_intf.S) = struct + let program = P.program + let compilation_unit = P.compilation_unit + let imported_symbols = Flambda_utils.imported_symbols program + + (* Sets representing NC *) + let variables : state Variable.Tbl.t = Variable.Tbl.create 42 + let closures : state Set_of_closures_id.Tbl.t = + Set_of_closures_id.Tbl.create 42 + let symbols : state Symbol.Tbl.t = Symbol.Tbl.create 42 + let symbol_fields : state Symbol_field.Tbl.t = Symbol_field.Tbl.create 42 + + let mark_queue = Queue.create () + + (* CR-soon pchambart: We could probably improve that quite a lot by adding + (the future annotation) [@unrolled] at the right call sites. Or more + directly mark mark_dep as [@inline] and call it instead of mark_curr in + some situations. + *) + + (* adds 'dep in NC' *) + let rec mark_dep = function + | Var id -> begin + match Variable.Tbl.find variables id with + | Not_constant -> () + | Implication deps -> + Variable.Tbl.replace variables id Not_constant; + Queue.push deps mark_queue + | exception Not_found -> + Variable.Tbl.add variables id Not_constant + end + | Closure cl -> begin + match Set_of_closures_id.Tbl.find closures cl with + | Not_constant -> () + | Implication deps -> + Set_of_closures_id.Tbl.replace closures cl Not_constant; + Queue.push deps mark_queue + | exception Not_found -> + Set_of_closures_id.Tbl.add closures cl Not_constant + end + | Symbol s -> begin + match Symbol.Tbl.find symbols s with + | Not_constant -> () + | Implication deps -> + Symbol.Tbl.replace symbols s Not_constant; + Queue.push deps mark_queue + | exception Not_found -> + Symbol.Tbl.add symbols s Not_constant + end + | Symbol_field s -> begin + match Symbol_field.Tbl.find symbol_fields s with + | Not_constant -> () + | Implication deps -> + Symbol_field.Tbl.replace symbol_fields s Not_constant; + Queue.push deps mark_queue + | exception Not_found -> + Symbol_field.Tbl.add symbol_fields s Not_constant + end + + and mark_deps deps = + List.iter mark_dep deps + + and complete_marking () = + while not (Queue.is_empty mark_queue) do + let deps = + try + Queue.take mark_queue + with Not_found -> [] + in + mark_deps deps; + done + + (* adds 'curr in NC' *) + let mark_curr curr = + mark_deps curr; + complete_marking () + + (* adds in the tables 'dep in NC => curr in NC' *) + let register_implication ~in_nc:dep ~implies_in_nc:curr = + match dep with + | Var id -> begin + match Variable.Tbl.find variables id with + | Not_constant -> + mark_deps curr; + complete_marking (); + | Implication deps -> + let deps = List.rev_append curr deps in + Variable.Tbl.replace variables id (Implication deps) + | exception Not_found -> + Variable.Tbl.add variables id (Implication curr); + end + | Closure cl -> begin + match Set_of_closures_id.Tbl.find closures cl with + | Not_constant -> + mark_deps curr; + complete_marking (); + | Implication deps -> + let deps = List.rev_append curr deps in + Set_of_closures_id.Tbl.replace closures cl (Implication deps) + | exception Not_found -> + Set_of_closures_id.Tbl.add closures cl (Implication curr); + end + | Symbol symbol -> begin + match Symbol.Tbl.find symbols symbol with + | Not_constant -> + mark_deps curr; + complete_marking (); + | Implication deps -> + let deps = List.rev_append curr deps in + Symbol.Tbl.replace symbols symbol (Implication deps) + | exception Not_found -> + Symbol.Tbl.add symbols symbol (Implication curr); + end + | Symbol_field ((symbol, _) as field) -> begin + match Symbol_field.Tbl.find symbol_fields field with + | Not_constant -> + mark_deps curr; + complete_marking (); + | Implication deps -> + let deps = List.rev_append curr deps in + Symbol_field.Tbl.replace symbol_fields field (Implication deps) + | exception Not_found -> + (* There is no information available about the contents of imported + symbols, so we must consider all their fields as inconstant. *) + (* CR-someday pchambart: recover that from the cmx information *) + if Symbol.Set.mem symbol imported_symbols then begin + Symbol_field.Tbl.add symbol_fields field Not_constant; + mark_deps curr; + complete_marking (); + end else begin + Symbol_field.Tbl.add symbol_fields field (Implication curr) + end + end + + (* First loop: iterates on the tree to mark dependencies. + + curr is the variables or closures to which we add constraints like + '... in NC => curr in NC' or 'curr in NC' + + It can be empty when no constraint can be added like in the toplevel + expression or in the body of a function. + *) + let rec mark_loop ~toplevel (curr : dep list) (flam : Flambda.t) = + match flam with + | Let { var; defining_expr = lam; body; _ } -> + mark_named ~toplevel [Var var] lam; + (* adds 'var in NC => curr in NC' + This is not really necessary, but compiling this correctly is + trickier than eliminating that earlier. *) + mark_var var curr; + mark_loop ~toplevel curr body + | Let_mutable { initial_value = var; body } -> + mark_var var curr; + mark_loop ~toplevel curr body + | Let_rec(defs, body) -> + List.iter (fun (var, def) -> + mark_named ~toplevel [Var var] def; + (* adds 'var in NC => curr in NC' same remark as let case *) + mark_var var curr) + defs; + mark_loop ~toplevel curr body + | Var var -> mark_var var curr + (* Not constant cases: we mark directly 'curr in NC' and mark + bound variables as in NC also *) + | Assign _ -> + mark_curr curr + | Try_with (f1,id,f2) -> + mark_curr [Var id]; + mark_curr curr; + mark_loop ~toplevel [] f1; + mark_loop ~toplevel [] f2 + | Static_catch (_,ids,f1,f2) -> + List.iter (fun id -> mark_curr [Var id]) ids; + mark_curr curr; + mark_loop ~toplevel [] f1; + mark_loop ~toplevel [] f2 + (* CR-someday pchambart: If recursive staticcatch is introduced: + this becomes ~toplevel:false *) + | For { bound_var; from_value; to_value; direction = _; body; } -> + mark_curr [Var bound_var]; + mark_var from_value curr; + mark_var to_value curr; + mark_curr curr; + mark_loop ~toplevel:false [] body + | While (f1,body) -> + mark_curr curr; + mark_loop ~toplevel [] f1; + mark_loop ~toplevel:false [] body + | If_then_else (f1,f2,f3) -> + mark_curr curr; + mark_curr [Var f1]; + mark_loop ~toplevel [] f2; + mark_loop ~toplevel [] f3 + | Static_raise (_,l) -> + mark_curr curr; + List.iter (fun v -> mark_var v curr) l + | Apply ({func; args; _ }) -> + mark_curr curr; + mark_var func curr; + mark_vars args curr; + | Switch (arg,sw) -> + mark_curr curr; + mark_var arg curr; + List.iter (fun (_,l) -> mark_loop ~toplevel [] l) sw.consts; + List.iter (fun (_,l) -> mark_loop ~toplevel [] l) sw.blocks; + Misc.may (fun l -> mark_loop ~toplevel [] l) sw.failaction + | String_switch (arg,sw,def) -> + mark_curr curr; + mark_var arg curr; + List.iter (fun (_,l) -> mark_loop ~toplevel [] l) sw; + Misc.may (fun l -> mark_loop ~toplevel [] l) def + | Send { kind = _; meth; obj; args; dbg = _; } -> + mark_curr curr; + mark_var meth curr; + mark_var obj curr; + List.iter (fun arg -> mark_var arg curr) args + | Proved_unreachable -> + mark_curr curr + + and mark_named ~toplevel curr (named : Flambda.named) = + match named with + | Set_of_closures (set_of_closures) -> + mark_loop_set_of_closures ~toplevel curr set_of_closures + | Const _ | Allocated_const _ -> () + | Read_mutable _ -> mark_curr curr + | Symbol symbol -> begin + let current_unit = Compilation_unit.get_current_exn () in + if Compilation_unit.equal current_unit (Symbol.compilation_unit symbol) + then + () + else + match (Backend.import_symbol symbol).descr with + | Value_unresolved _ -> + (* Constant when 'for_clambda' means: can be a symbol (which is + obviously the case here) with a known approximation. If this + condition is not satisfied we mark as inconstant to reflect + the fact that the symbol's contents are unknown and thus + prevent attempts to examine it. (This is a bit of a hack.) *) + mark_curr curr + | _ -> + () + end + | Read_symbol_field (symbol, index) -> + register_implication ~in_nc:(Symbol_field (symbol, index)) + ~implies_in_nc:curr + (* Constant constructors: those expressions are constant if all their + parameters are: + - makeblock is compiled to a constant block + - offset is compiled to a pointer inside a constant closure. + See Cmmgen for the details + + makeblock(Mutable) can be a 'constant' if it is allocated at + toplevel: if this expression is evaluated only once. + *) + | Prim (Pmakeblock (_tag, Asttypes.Immutable, _value_kind), args, + _dbg) -> + mark_vars args curr +(* (* CR-someday pchambart: If global mutables are allowed: *) + | Prim(Lambda.Pmakeblock(_tag, Asttypes.Mutable), args, _dbg, _) + when toplevel -> + List.iter (mark_loop ~toplevel curr) args +*) + | Prim (Pmakearray (Pfloatarray, Immutable), args, _) -> + mark_vars args curr + | Prim (Pmakearray (Pfloatarray, Mutable), args, _) -> + (* CR-someday pchambart: Toplevel float arrays could always be + statically allocated using an equivalent of the + Initialize_symbol construction. + Toplevel non-float arrays could also be turned into an + Initialize_symbol, but only when declared as immutable since + preallocated symbols does not allow mutation after + initialisation + *) + if toplevel then mark_vars args curr + else mark_curr curr + | Prim (Pduparray (Pfloatarray, Immutable), [arg], _) -> + mark_var arg curr + | Prim (Pduparray (Pfloatarray, Mutable), [arg], _) -> + if toplevel then mark_var arg curr + else mark_curr curr + | Prim (Pduparray _, _, _) -> + (* See Lift_constants *) + mark_curr curr + | Project_closure ({ set_of_closures; closure_id; }) -> + if Closure_id.in_compilation_unit closure_id compilation_unit then + mark_var set_of_closures curr + else + mark_curr curr + | Move_within_set_of_closures ({ closure; start_from; move_to; }) -> + (* CR-someday mshinwell: We should be able to deem these projections + (same for the cases below) as constant when from another + compilation unit, but there isn't code to handle this yet. (Note + that for Project_var we cannot yet generate a projection from a + closure in another compilation unit, since we only lift closed + closures.) *) + if Closure_id.in_compilation_unit start_from compilation_unit then begin + assert (Closure_id.in_compilation_unit move_to compilation_unit); + mark_var closure curr + end else begin + mark_curr curr + end + | Project_var ({ closure; closure_id; var = _ }) -> + if Closure_id.in_compilation_unit closure_id compilation_unit then + mark_var closure curr + else + mark_curr curr + | Prim (Pfield _, [f1], _) -> + mark_curr curr; + mark_var f1 curr + | Prim (_, args, _) -> + mark_curr curr; + mark_vars args curr + | Expr flam -> + mark_loop ~toplevel curr flam + + and mark_var var curr = + (* adds 'id in NC => curr in NC' *) + register_implication ~in_nc:(Var var) ~implies_in_nc:curr + + and mark_vars vars curr = + (* adds 'id in NC => curr in NC' *) + List.iter (fun var -> mark_var var curr) vars + + (* [toplevel] is intended for allowing static allocations of mutable + blocks. This feature should be available in a future release once the + necessary GC changes have been merged. (See GPR#178.) *) + and mark_loop_set_of_closures ~toplevel:_ curr + { Flambda. function_decls; free_vars; specialised_args } = + (* If a function in the set of closures is specialised, do not consider + it constant, unless all specialised args are also constant. *) + Variable.Map.iter (fun _ (spec_arg : Flambda.specialised_to) -> + register_implication + ~in_nc:(Var spec_arg.var) + ~implies_in_nc:[Closure function_decls.set_of_closures_id]) + specialised_args; + (* adds 'function_decls in NC => curr in NC' *) + register_implication ~in_nc:(Closure function_decls.set_of_closures_id) + ~implies_in_nc:curr; + (* a closure is constant if its free variables are constants. *) + Variable.Map.iter (fun inner_id (var : Flambda.specialised_to) -> + register_implication ~in_nc:(Var var.var) + ~implies_in_nc:[ + Var inner_id; + Closure function_decls.set_of_closures_id + ]) + free_vars; + Variable.Map.iter (fun fun_id (ffunc : Flambda.function_declaration) -> + (* for each function f in a closure c 'c in NC => f' *) + register_implication ~in_nc:(Closure function_decls.set_of_closures_id) + ~implies_in_nc:[Var fun_id]; + (* function parameters are in NC unless specialised *) + List.iter (fun param -> + match Variable.Map.find param specialised_args with + | exception Not_found -> mark_curr [Var param] + | outer_var -> + register_implication ~in_nc:(Var outer_var.var) + ~implies_in_nc:[Var param]) + (Parameter.List.vars ffunc.params); + mark_loop ~toplevel:false [] ffunc.body) + function_decls.funs + + let mark_constant_defining_value (const:Flambda.constant_defining_value) = + match const with + | Allocated_const _ + | Block _ + | Project_closure _ -> () + | Set_of_closures set_of_closure -> + mark_loop_set_of_closures ~toplevel:true [] set_of_closure + + let mark_program (program : Flambda.program) = + let rec loop (program : Flambda.program_body) = + match program with + | End _ -> () + | Initialize_symbol (symbol,_tag,fields,program) -> + List.iteri (fun i field -> + mark_loop ~toplevel:true + [Symbol symbol; Symbol_field (symbol,i)] field) + fields; + loop program + | Effect (expr, program) -> + mark_loop ~toplevel:true [] expr; + loop program + | Let_symbol (_, def, program) -> + mark_constant_defining_value def; + loop program + | Let_rec_symbol (defs, program) -> + List.iter (fun (_, def) -> mark_constant_defining_value def) defs; + loop program + in + loop program.program_body + + let res = + mark_program program; + { id = variables; + closure = closures; + } +end + +let inconstants_on_program ~compilation_unit ~backend + (program : Flambda.program) = + let module P = struct + let program = program + let compilation_unit = compilation_unit + end in + let module Backend = (val backend : Backend_intf.S) in + let module I = Inconstants (P) (Backend) in + I.res + +let variable var { id; _ } = + match Variable.Tbl.find id var with + | Not_constant -> true + | Implication _ -> false + | exception Not_found -> false + +let closure cl { closure; _ } = + match Set_of_closures_id.Tbl.find closure cl with + | Not_constant -> true + | Implication _ -> false + | exception Not_found -> false diff --git a/middle_end/flambda/inconstant_idents.mli b/middle_end/flambda/inconstant_idents.mli new file mode 100644 index 00000000..2c5309e0 --- /dev/null +++ b/middle_end/flambda/inconstant_idents.mli @@ -0,0 +1,36 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +type result + +(** [inconstants_on_program] finds those variables and set-of-closures + identifiers that cannot be compiled to constants by [Flambda_to_clambda]. +*) +val inconstants_on_program + : compilation_unit:Compilation_unit.t + -> backend:(module Backend_intf.S) + -> Flambda.program + -> result + +(** [variable var res] returns [true] if [var] is marked as inconstant + in [res]. *) +val variable : Variable.t -> result -> bool + +(** [closure cl res] returns [true] if [cl] is marked as inconstant + in [res]. *) +val closure : Set_of_closures_id.t -> result -> bool diff --git a/middle_end/flambda/initialize_symbol_to_let_symbol.ml b/middle_end/flambda/initialize_symbol_to_let_symbol.ml new file mode 100644 index 00000000..31246b0d --- /dev/null +++ b/middle_end/flambda/initialize_symbol_to_let_symbol.ml @@ -0,0 +1,57 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let constant_field (expr:Flambda.t) + : Flambda.constant_defining_value_block_field option = + match expr with + | Let { var; defining_expr = Const c; body = Var var' ; _ } -> + assert(Variable.equal var var'); + (* This must be true since var is the only variable in scope *) + Some (Flambda.Const c) + | Let { var; defining_expr = Symbol s; body = Var var' ; _ } -> + assert(Variable.equal var var'); + Some (Flambda.Symbol s) + | _ -> + None + +let rec loop (program : Flambda.program_body) : Flambda.program_body = + match program with + | Initialize_symbol (symbol, tag, fields, program) -> + let constant_fields = List.map constant_field fields in + begin + match Misc.Stdlib.List.some_if_all_elements_are_some constant_fields + with + | None -> + Initialize_symbol (symbol, tag, fields, loop program) + | Some fields -> + Let_symbol (symbol, Block (tag, fields), loop program) + end + | Let_symbol (symbol, const, program) -> + Let_symbol (symbol, const, loop program) + | Let_rec_symbol (defs, program) -> + Let_rec_symbol (defs, loop program) + | Effect (expr, program) -> + Effect (expr, loop program) + | End symbol -> + End symbol + +let run (program : Flambda.program) = + { program with + program_body = loop program.program_body; + } diff --git a/middle_end/flambda/initialize_symbol_to_let_symbol.mli b/middle_end/flambda/initialize_symbol_to_let_symbol.mli new file mode 100644 index 00000000..fc54f760 --- /dev/null +++ b/middle_end/flambda/initialize_symbol_to_let_symbol.mli @@ -0,0 +1,25 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +val constant_field + : Flambda.t + -> Flambda.constant_defining_value_block_field option + +(** Transform Initialize_symbol with only constant fields to + let_symbol construction. *) +val run : Flambda.program -> Flambda.program diff --git a/middle_end/flambda/inline_and_simplify.ml b/middle_end/flambda/inline_and_simplify.ml new file mode 100644 index 00000000..7d304cd8 --- /dev/null +++ b/middle_end/flambda/inline_and_simplify.ml @@ -0,0 +1,1703 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module A = Simple_value_approx +module B = Inlining_cost.Benefit +module E = Inline_and_simplify_aux.Env +module R = Inline_and_simplify_aux.Result + +(** Values of two types hold the information propagated during simplification: + - [E.t] "environments", top-down, almost always called "env"; + - [R.t] "results", bottom-up approximately following the evaluation order, + almost always called "r". These results come along with rewritten + Flambda terms. + The environments map variables to approximations, which enable various + simplifications to be performed; for example, some variable may be known + to always hold a particular constant. +*) + +let ret = R.set_approx + +type simplify_variable_result = + | No_binding of Variable.t + | Binding of Variable.t * (Flambda.named Flambda.With_free_variables.t) + +let simplify_free_variable_internal env original_var = + let var = Freshening.apply_variable (E.freshening env) original_var in + let original_var = var in + (* In the case where an approximation is useful, we introduce a [let] + to bind (e.g.) the constant or symbol replacing [var], unless this + would introduce a useless [let] as a consequence of [var] already being + in the current scope. + + Even when the approximation is not useful, this simplification helps. + In particular, it squashes aliases of the form: + let var1 = var2 in ... var2 ... + by replacing [var2] in the body with [var1]. Simplification can then + eliminate the [let]. + *) + let var = + let approx = E.find_exn env var in + match approx.var with + | Some var when E.mem env var -> var + | Some _ | None -> var + in + (* CR-soon mshinwell: Should we update [r] when we *add* code? + Aside from that, it looks like maybe we don't need [r] in this function, + because the approximation within it wouldn't be used by any of the + call sites. *) + match E.find_with_scope_exn env var with + | Current, approx -> No_binding var, approx (* avoid useless [let] *) + | Outer, approx -> + match A.simplify_var approx with + | None -> No_binding var, approx + | Some (named, approx) -> + let module W = Flambda.With_free_variables in + Binding (original_var, W.of_named named), approx + +let simplify_free_variable env var ~f : Flambda.t * R.t = + match simplify_free_variable_internal env var with + | No_binding var, approx -> f env var approx + | Binding (var, named), approx -> + let module W = Flambda.With_free_variables in + let var = Variable.rename var in + let env = E.add env var approx in + let body, r = f env var approx in + (W.create_let_reusing_defining_expr var named body), r + +let simplify_free_variables env vars ~f : Flambda.t * R.t = + let rec collect_bindings vars env bound_vars approxs : Flambda.t * R.t = + match vars with + | [] -> f env (List.rev bound_vars) (List.rev approxs) + | var::vars -> + match simplify_free_variable_internal env var with + | No_binding var, approx -> + collect_bindings vars env (var::bound_vars) (approx::approxs) + | Binding (var, named), approx -> + let module W = Flambda.With_free_variables in + let var = Variable.rename var in + let env = E.add env var approx in + let body, r = + collect_bindings vars env (var::bound_vars) (approx::approxs) + in + (W.create_let_reusing_defining_expr var named body), r + in + collect_bindings vars env [] [] + +let simplify_free_variables_named env vars ~f : Flambda.named * R.t = + let rec collect_bindings vars env bound_vars approxs + : Flambda.maybe_named * R.t = + match vars with + | [] -> + let named, r = f env (List.rev bound_vars) (List.rev approxs) in + Is_named named, r + | var::vars -> + match simplify_free_variable_internal env var with + | No_binding var, approx -> + collect_bindings vars env (var::bound_vars) (approx::approxs) + | Binding (var, named), approx -> + let module W = Flambda.With_free_variables in + let var = Variable.rename var in + let env = E.add env var approx in + let body, r = + collect_bindings vars env (var::bound_vars) (approx::approxs) + in + let body = + match body with + | Is_named body -> + let name = Internal_variable_names.simplify_fv in + Flambda_utils.name_expr body ~name + | Is_expr body -> body + in + Is_expr (W.create_let_reusing_defining_expr var named body), r + in + let named_or_expr, r = collect_bindings vars env [] [] in + match named_or_expr with + | Is_named named -> named, r + | Is_expr expr -> Expr expr, r + +(* CR-soon mshinwell: tidy this up *) +let simplify_free_variable_named env var ~f : Flambda.named * R.t = + simplify_free_variables_named env [var] ~f:(fun env vars vars_approxs -> + match vars, vars_approxs with + | [var], [approx] -> f env var approx + | _ -> assert false) + +let simplify_named_using_approx r lam approx = + let lam, _summary, approx = A.simplify_named approx lam in + lam, R.set_approx r approx + +let simplify_using_approx_and_env env r original_lam approx = + let lam, summary, approx = + A.simplify_using_env approx ~is_present_in_env:(E.mem env) original_lam + in + let r = + let r = ret r approx in + match summary with + (* CR-soon mshinwell: Why is [r] not updated with the cost of adding the + new code? + mshinwell: similar to CR above *) + | Replaced_term -> R.map_benefit r (B.remove_code original_lam) + | Nothing_done -> r + in + lam, r + +let simplify_named_using_approx_and_env env r original_named approx = + let named, summary, approx = + A.simplify_named_using_env approx ~is_present_in_env:(E.mem env) + original_named + in + let r = + let r = ret r approx in + match summary with + | Replaced_term -> R.map_benefit r (B.remove_code_named original_named) + | Nothing_done -> r + in + named, r + +let simplify_const (const : Flambda.const) = + match const with + | Int i -> A.value_int i + | Char c -> A.value_char c + | Const_pointer i -> A.value_constptr i + +let approx_for_allocated_const (const : Allocated_const.t) = + match const with + | String s -> A.value_string (String.length s) None + | Immutable_string s -> A.value_string (String.length s) (Some s) + | Int32 i -> A.value_boxed_int Int32 i + | Int64 i -> A.value_boxed_int Int64 i + | Nativeint i -> A.value_boxed_int Nativeint i + | Float f -> A.value_float f + | Float_array a -> A.value_mutable_float_array ~size:(List.length a) + | Immutable_float_array a -> + A.value_immutable_float_array + (Array.map A.value_float (Array.of_list a)) + +type filtered_switch_branches = + | Must_be_taken of Flambda.t + | Can_be_taken of (int * Flambda.t) list + +(* Determine whether a given closure ID corresponds directly to a variable + (bound to a closure) in the given environment. This happens when the body + of a [let rec]-bound function refers to another in the same set of closures. + If we succeed in this process, we can change [Project_closure] + expressions into [Var] expressions, thus sharing closure projections. *) +let reference_recursive_function_directly env closure_id = + let closure_id = Closure_id.unwrap closure_id in + match E.find_opt env closure_id with + | None -> None + | Some approx -> Some (Flambda.Expr (Var closure_id), approx) + +(* Simplify an expression that takes a set of closures and projects an + individual closure from it. *) +let simplify_project_closure env r ~(project_closure : Flambda.project_closure) + : Flambda.named * R.t = + simplify_free_variable_named env project_closure.set_of_closures + ~f:(fun _env set_of_closures set_of_closures_approx -> + match A.check_approx_for_set_of_closures set_of_closures_approx with + | Wrong -> + Misc.fatal_errorf "Wrong approximation when projecting closure: %a" + Flambda.print_project_closure project_closure + | Unresolved value -> + (* A set of closures coming from another compilation unit, whose .cmx is + missing; as such, we cannot have rewritten the function and don't + need to do any freshening. *) + Project_closure { + set_of_closures; + closure_id = project_closure.closure_id; + }, ret r (A.value_unresolved value) + | Unknown -> + (* CR-soon mshinwell: see CR comment in e.g. simple_value_approx.ml + [check_approx_for_closure_allowing_unresolved] *) + Project_closure { + set_of_closures; + closure_id = project_closure.closure_id; + }, ret r (A.value_unknown Other) + | Unknown_because_of_unresolved_value value -> + Project_closure { + set_of_closures; + closure_id = project_closure.closure_id; + }, ret r (A.value_unknown (Unresolved_value value)) + | Ok (set_of_closures_var, value_set_of_closures) -> + let closure_id = + A.freshen_and_check_closure_id value_set_of_closures + project_closure.closure_id + in + let projecting_from = + match set_of_closures_var with + | None -> None + | Some set_of_closures_var -> + let projection : Projection.t = + Project_closure { + set_of_closures = set_of_closures_var; + closure_id; + } + in + match E.find_projection env ~projection with + | None -> None + | Some var -> Some (var, projection) + in + match projecting_from with + | Some (var, projection) -> + simplify_free_variable_named env var ~f:(fun _env var var_approx -> + let r = R.map_benefit r (B.remove_projection projection) in + Expr (Var var), ret r var_approx) + | None -> + match reference_recursive_function_directly env closure_id with + | Some (flam, approx) -> flam, ret r approx + | None -> + let set_of_closures_var = + match set_of_closures_var with + | Some set_of_closures_var' when E.mem env set_of_closures_var' -> + set_of_closures_var + | Some _ | None -> None + in + let approx = + A.value_closure ?set_of_closures_var value_set_of_closures + closure_id + in + Project_closure { set_of_closures; closure_id; }, ret r approx) + +(* Simplify an expression that, given one closure within some set of + closures, returns another closure (possibly the same one) within the + same set. *) +let simplify_move_within_set_of_closures env r + ~(move_within_set_of_closures : Flambda.move_within_set_of_closures) + : Flambda.named * R.t = + simplify_free_variable_named env move_within_set_of_closures.closure + ~f:(fun _env closure closure_approx -> + match A.check_approx_for_closure_allowing_unresolved closure_approx with + | Wrong -> + Misc.fatal_errorf "Wrong approximation when moving within set of \ + closures. Approximation: %a Term: %a" + A.print closure_approx + Flambda.print_move_within_set_of_closures move_within_set_of_closures + | Unresolved sym -> + Move_within_set_of_closures { + closure; + start_from = move_within_set_of_closures.start_from; + move_to = move_within_set_of_closures.move_to; + }, + ret r (A.value_unresolved sym) + | Unknown -> + Move_within_set_of_closures { + closure; + start_from = move_within_set_of_closures.start_from; + move_to = move_within_set_of_closures.move_to; + }, + ret r (A.value_unknown Other) + | Unknown_because_of_unresolved_value value -> + (* For example: a move upon a (move upon a closure whose .cmx file + is missing). *) + Move_within_set_of_closures { + closure; + start_from = move_within_set_of_closures.start_from; + move_to = move_within_set_of_closures.move_to; + }, + ret r (A.value_unknown (Unresolved_value value)) + | Ok (_value_closure, set_of_closures_var, set_of_closures_symbol, + value_set_of_closures) -> + let freshen = + (* CR-soon mshinwell: potentially misleading name---not freshening with + new names, but with previously fresh names *) + A.freshen_and_check_closure_id value_set_of_closures + in + let move_to = freshen move_within_set_of_closures.move_to in + let start_from = freshen move_within_set_of_closures.start_from in + let projection : Projection.t = + Move_within_set_of_closures { + closure; + start_from; + move_to; + } + in + match E.find_projection env ~projection with + | Some var -> + simplify_free_variable_named env var ~f:(fun _env var var_approx -> + let r = R.map_benefit r (B.remove_projection projection) in + Expr (Var var), ret r var_approx) + | None -> + match reference_recursive_function_directly env move_to with + | Some (flam, approx) -> flam, ret r approx + | None -> + if Closure_id.equal start_from move_to then + (* Moving from one closure to itself is a no-op. We can return an + [Var] since we already have a variable bound to the closure. *) + Expr (Var closure), ret r closure_approx + else + match set_of_closures_var with + | Some set_of_closures_var when E.mem env set_of_closures_var -> + (* A variable bound to the set of closures is in scope, + meaning we can rewrite the [Move_within_set_of_closures] to a + [Project_closure]. *) + let project_closure : Flambda.project_closure = + { set_of_closures = set_of_closures_var; + closure_id = move_to; + } + in + let approx = + A.value_closure ~set_of_closures_var value_set_of_closures + move_to + in + Project_closure project_closure, ret r approx + | Some _ | None -> + match set_of_closures_symbol with + | Some set_of_closures_symbol -> + let set_of_closures_var = + Variable.create Internal_variable_names.symbol + in + let project_closure : Flambda.project_closure = + { set_of_closures = set_of_closures_var; + closure_id = move_to; + } + in + let project_closure_var = + Variable.create Internal_variable_names.project_closure + in + let let1 = + Flambda.create_let project_closure_var + (Project_closure project_closure) + (Var project_closure_var) + in + let expr = + Flambda.create_let set_of_closures_var + (Symbol set_of_closures_symbol) + let1 + in + let approx = + A.value_closure ~set_of_closures_var ~set_of_closures_symbol + value_set_of_closures move_to + in + Expr expr, ret r approx + | None -> + (* The set of closures is not available in scope, and we + have no other information by which to simplify the move. *) + let move_within : Flambda.move_within_set_of_closures = + { closure; start_from; move_to; } + in + let approx = A.value_closure value_set_of_closures move_to in + Move_within_set_of_closures move_within, ret r approx) + +(* Transform an expression denoting an access to a variable bound in + a closure. Variables in the closure ([project_var.closure]) may + have been freshened since [expr] was constructed; as such, we + must ensure the same happens to [expr]. The renaming information is + contained within the approximation deduced from [closure] (as + such, that approximation *must* identify which closure it is). + + For instance in some imaginary syntax for flambda: + + [let f x = + let g y ~closure:{a} = a + y in + let closure = { a = x } in + g 12 ~closure] + + when [f] is traversed, [g] can be inlined, resulting in the + expression + + [let f z = + let g y ~closure:{a} = a + y in + let closure = { a = x } in + closure.a + 12] + + [closure.a] being a notation for: + + [Project_var{closure = closure; closure_id = g; var = a}] + + If [f] is inlined later, the resulting code will be + + [let x = ... in + let g' y' ~closure':{a'} = a' + y' in + let closure' = { a' = x } in + closure'.a' + 12] + + in particular the field [a] of the closure has been alpha renamed to [a']. + This information must be carried from the declaration to the use. + + If the function is declared outside of the alpha renamed part, there is + no need for renaming in the [Ffunction] and [Project_var]. + This is not usually the case, except when the closure declaration is a + symbol. + + What ensures that this information is available at [Project_var] + point is that those constructions can only be introduced by inlining, + which requires that same information. For this to still be valid, + other transformation must avoid transforming the information flow in + a way that the inline function can't propagate it. +*) +let rec simplify_project_var env r ~(project_var : Flambda.project_var) + : Flambda.named * R.t = + simplify_free_variable_named env project_var.closure + ~f:(fun _env closure approx -> + match A.check_approx_for_closure_allowing_unresolved approx with + | Ok (value_closure, _set_of_closures_var, _set_of_closures_symbol, + value_set_of_closures) -> + let module F = Freshening.Project_var in + let freshening = value_set_of_closures.freshening in + let var = F.apply_var_within_closure freshening project_var.var in + let closure_id = F.apply_closure_id freshening project_var.closure_id in + let closure_id_in_approx = value_closure.closure_id in + if not (Closure_id.equal closure_id closure_id_in_approx) then begin + Misc.fatal_errorf "When simplifying [Project_var], the closure ID %a \ + in the approximation of the set of closures did not match the \ + closure ID %a in the [Project_var] term. Approximation: %a@. \ + Var-within-closure being projected: %a@." + Closure_id.print closure_id_in_approx + Closure_id.print closure_id + Simple_value_approx.print approx + Var_within_closure.print var + end; + let projection : Projection.t = + Project_var { + closure; + closure_id; + var; + } + in + begin match E.find_projection env ~projection with + | Some var -> + simplify_free_variable_named env var ~f:(fun _env var var_approx -> + let r = R.map_benefit r (B.remove_projection projection) in + Expr (Var var), ret r var_approx) + | None -> + let approx = A.approx_for_bound_var value_set_of_closures var in + let expr : Flambda.named = Project_var { closure; closure_id; var; } in + let unwrapped = Var_within_closure.unwrap var in + let expr = + if E.mem env unwrapped then + Flambda.Expr (Var unwrapped) + else + expr + in + simplify_named_using_approx_and_env env r expr approx + end + | Unresolved symbol -> + (* This value comes from a symbol for which we couldn't find any + approximation, telling us that names within the closure couldn't + have been renamed. So we don't need to change the variable or + closure ID in the [Project_var] expression. *) + Project_var { project_var with closure }, + ret r (A.value_unresolved symbol) + | Unknown -> + Project_var { project_var with closure }, + ret r (A.value_unknown Other) + | Unknown_because_of_unresolved_value value -> + Project_var { project_var with closure }, + ret r (A.value_unknown (Unresolved_value value)) + | Wrong -> + (* We must have the correct approximation of the value to ensure + we take account of all freshenings. *) + Misc.fatal_errorf "[Project_var] from a value with wrong \ + approximation: %a@.closure=%a@.approx of closure=%a@." + Flambda.print_project_var project_var + Variable.print closure + Simple_value_approx.print approx) + +(* Transforms closure definitions by applying [loop] on the code of every + one of the set and on the expressions of the free variables. + If the substitution is activated, alpha renaming also occur on everything + defined by the set of closures: + * Variables bound by a closure of the set + * closure identifiers + * parameters + + The rewriting occurs in a clean environment without any of the variables + defined outside reachable. This helps increase robustness against + accidental, potentially unsound simplification of variable accesses by + [simplify_using_approx_and_env]. + + The rewriting occurs in an environment filled with: + * The approximation of the free variables + * An explicitly unknown approximation for function parameters, + except for those where it is known to be safe: those present in the + [specialised_args] set. + * An approximation for the closures in the set. It contains the code of + the functions before rewriting. + + The approximation of the currently defined closures is available to + allow marking recursives calls as direct and in some cases, allow + inlining of one closure from the set inside another one. For this to + be correct an alpha renaming is first applied on the expressions by + [apply_function_decls_and_free_vars]. + + For instance when rewriting the declaration + + [let rec f_1 x_1 = + let y_1 = x_1 + 1 in + g_1 y_1 + and g_1 z_1 = f_1 (f_1 z_1)] + + When rewriting this function, the first substitution will contain + some mapping: + { f_1 -> f_2; + g_1 -> g_2; + x_1 -> x_2; + z_1 -> z_2 } + + And the approximation for the closure will contain + + { f_2: + fun x_2 -> + let y_1 = x_2 + 1 in + g_2 y_1 + g_2: + fun z_2 -> f_2 (f_2 z_2) } + + Note that no substitution is applied to the let-bound variable [y_1]. + If [f_2] where to be inlined inside [g_2], we known that a new substitution + will be introduced in the current scope for [y_1] each time. + + + If the function where a recursive one coming from another compilation + unit, the code already went through [Flambdasym] that could have + replaced the function variable by the symbol identifying the function + (this occur if the function contains only constants in its closure). + To handle that case, we first replace those symbols by the original + variable. +*) +and simplify_set_of_closures original_env r + (set_of_closures : Flambda.set_of_closures) + : Flambda.set_of_closures * R.t * Freshening.Project_var.t = + let function_decls = + let module Backend = (val (E.backend original_env) : Backend_intf.S) in + (* CR-soon mshinwell: Does this affect + [reference_recursive_function_directly]? + mshinwell: This should be thought about as part of the wider issue of + references to functions via symbols or variables. *) + Freshening.rewrite_recursive_calls_with_symbols (E.freshening original_env) + set_of_closures.function_decls + ~make_closure_symbol:Backend.closure_symbol + in + let env = E.increase_closure_depth original_env in + let free_vars, specialised_args, function_decls, parameter_approximations, + internal_value_set_of_closures, set_of_closures_env = + Inline_and_simplify_aux.prepare_to_simplify_set_of_closures ~env + ~set_of_closures ~function_decls ~only_for_function_decl:None + ~freshen:true + in + let simplify_function fun_var (function_decl : Flambda.function_declaration) + (funs, used_params, r) + : Flambda.function_declaration Variable.Map.t * Variable.Set.t * R.t = + let closure_env = + Inline_and_simplify_aux.prepare_to_simplify_closure ~function_decl + ~free_vars ~specialised_args ~parameter_approximations + ~set_of_closures_env + in + let body, r = + E.enter_closure closure_env ~closure_id:(Closure_id.wrap fun_var) + ~inline_inside: + (Inlining_decision.should_inline_inside_declaration function_decl) + ~dbg:function_decl.dbg + ~f:(fun body_env -> + assert (E.inside_set_of_closures_declaration + function_decls.set_of_closures_origin body_env); + simplify body_env r function_decl.body) + in + let function_decl = + Flambda.create_function_declaration ~params:function_decl.params + ~body ~stub:function_decl.stub ~dbg:function_decl.dbg + ~inline:function_decl.inline ~specialise:function_decl.specialise + ~is_a_functor:function_decl.is_a_functor + ~closure_origin:function_decl.closure_origin + in + let used_params' = Flambda.used_params function_decl in + Variable.Map.add fun_var function_decl funs, + Variable.Set.union used_params used_params', r + in + let funs, _used_params, r = + Variable.Map.fold simplify_function function_decls.funs + (Variable.Map.empty, Variable.Set.empty, r) + in + let function_decls = + Flambda.update_function_declarations function_decls ~funs + in + let invariant_params = + lazy (Invariant_params.invariant_params_in_recursion function_decls + ~backend:(E.backend env)) + in + let recursive = + lazy (Find_recursive_functions.in_function_declarations function_decls + ~backend:(E.backend env)) + in + let keep_body = + Inline_and_simplify_aux.keep_body_check + ~is_classic_mode:function_decls.is_classic_mode ~recursive + in + let function_decls_approx = + A.function_declarations_approx ~keep_body function_decls + in + let value_set_of_closures = + A.create_value_set_of_closures + ~function_decls:function_decls_approx + ~bound_vars:internal_value_set_of_closures.bound_vars + ~invariant_params + ~recursive + ~specialised_args:internal_value_set_of_closures.specialised_args + ~free_vars:internal_value_set_of_closures.free_vars + ~freshening:internal_value_set_of_closures.freshening + ~direct_call_surrogates: + internal_value_set_of_closures.direct_call_surrogates + in + let direct_call_surrogates = + Closure_id.Map.fold (fun existing surrogate surrogates -> + Variable.Map.add (Closure_id.unwrap existing) + (Closure_id.unwrap surrogate) surrogates) + internal_value_set_of_closures.direct_call_surrogates + Variable.Map.empty + in + let set_of_closures = + Flambda.create_set_of_closures ~function_decls + ~free_vars:(Variable.Map.map fst free_vars) + ~specialised_args + ~direct_call_surrogates + in + let r = ret r (A.value_set_of_closures value_set_of_closures) in + set_of_closures, r, value_set_of_closures.freshening + +and simplify_apply env r ~(apply : Flambda.apply) : Flambda.t * R.t = + let { + Flambda. func = lhs_of_application; args; kind = _; dbg; + inline = inline_requested; specialise = specialise_requested; + } = apply in + let dbg = E.add_inlined_debuginfo env ~dbg in + simplify_free_variable env lhs_of_application + ~f:(fun env lhs_of_application lhs_of_application_approx -> + simplify_free_variables env args ~f:(fun env args args_approxs -> + (* By using the approximation of the left-hand side of the + application, attempt to determine which function is being applied + (even if the application is currently [Indirect]). If + successful---in which case we then have a direct + application---consider inlining. *) + match A.check_approx_for_closure lhs_of_application_approx with + | Ok (value_closure, set_of_closures_var, + set_of_closures_symbol, value_set_of_closures) -> + let lhs_of_application, closure_id_being_applied, + value_set_of_closures, env, wrap = + let closure_id_being_applied = value_closure.closure_id in + (* If the call site is a direct call to a function that has a + "direct call surrogate" (see inline_and_simplify_aux.mli), + repoint the call to the surrogate. *) + let surrogates = value_set_of_closures.direct_call_surrogates in + match Closure_id.Map.find closure_id_being_applied surrogates with + | exception Not_found -> + lhs_of_application, closure_id_being_applied, + value_set_of_closures, env, (fun expr -> expr) + | surrogate -> + let rec find_transitively surrogate = + match Closure_id.Map.find surrogate surrogates with + | exception Not_found -> surrogate + | surrogate -> find_transitively surrogate + in + let surrogate = find_transitively surrogate in + let surrogate_var = Variable.rename lhs_of_application in + let move_to_surrogate : Projection.move_within_set_of_closures = + { closure = lhs_of_application; + start_from = closure_id_being_applied; + move_to = surrogate; + } + in + let approx_for_surrogate = + A.value_closure ~closure_var:surrogate_var + ?set_of_closures_var ?set_of_closures_symbol + value_set_of_closures surrogate + in + let env = E.add env surrogate_var approx_for_surrogate in + let wrap expr = + Flambda.create_let surrogate_var + (Move_within_set_of_closures move_to_surrogate) + expr + in + surrogate_var, surrogate, value_set_of_closures, env, wrap + in + let function_decls = value_set_of_closures.function_decls in + let function_decl = + try + Variable.Map.find + (Closure_id.unwrap closure_id_being_applied) + function_decls.funs + with + | Not_found -> + Misc.fatal_errorf "When handling application expression, \ + approximation references non-existent closure %a@." + Closure_id.print closure_id_being_applied + in + let r = + match apply.kind with + | Indirect -> + R.map_benefit r Inlining_cost.Benefit.direct_call_of_indirect + | Direct _ -> r + in + let nargs = List.length args in + let arity = A.function_arity function_decl in + let result, r = + if nargs = arity then + simplify_full_application env r ~function_decls + ~lhs_of_application ~closure_id_being_applied ~function_decl + ~value_set_of_closures ~args ~args_approxs ~dbg + ~inline_requested ~specialise_requested + else if nargs > arity then + simplify_over_application env r ~args ~args_approxs + ~function_decls ~lhs_of_application ~closure_id_being_applied + ~function_decl ~value_set_of_closures ~dbg ~inline_requested + ~specialise_requested + else if nargs > 0 && nargs < arity then + simplify_partial_application env r ~lhs_of_application + ~closure_id_being_applied ~function_decl ~args ~dbg + ~inline_requested ~specialise_requested + else + Misc.fatal_errorf "Function with arity %d when simplifying \ + application expression: %a" + arity Flambda.print (Flambda.Apply apply) + in + wrap result, r + | Wrong -> (* Insufficient approximation information to simplify. *) + Apply ({ func = lhs_of_application; args; kind = Indirect; dbg; + inline = inline_requested; specialise = specialise_requested; }), + ret r (A.value_unknown Other))) + +and simplify_full_application env r ~function_decls ~lhs_of_application + ~closure_id_being_applied ~function_decl ~value_set_of_closures ~args + ~args_approxs ~dbg ~inline_requested ~specialise_requested = + Inlining_decision.for_call_site ~env ~r ~function_decls + ~lhs_of_application ~closure_id_being_applied ~function_decl + ~value_set_of_closures ~args ~args_approxs ~dbg ~simplify + ~inline_requested ~specialise_requested + +and simplify_partial_application env r ~lhs_of_application + ~closure_id_being_applied ~function_decl ~args ~dbg + ~inline_requested ~specialise_requested = + let arity = A.function_arity function_decl in + assert (arity > List.length args); + (* For simplicity, we disallow [@inline] attributes on partial + applications. The user may always write an explicit wrapper instead + with such an attribute. *) + (* CR-someday mshinwell: Pierre noted that we might like a function to be + inlined when applied to its first set of arguments, e.g. for some kind + of type class like thing. *) + begin match (inline_requested : Lambda.inline_attribute) with + | Always_inline | Never_inline -> + Location.prerr_warning (Debuginfo.to_location dbg) + (Warnings.Inlining_impossible "[@inlined] attributes may not be used \ + on partial applications") + | Unroll _ -> + Location.prerr_warning (Debuginfo.to_location dbg) + (Warnings.Inlining_impossible "[@unroll] attributes may not be used \ + on partial applications") + | Default_inline -> () + end; + begin match (specialise_requested : Lambda.specialise_attribute) with + | Always_specialise | Never_specialise -> + Location.prerr_warning (Debuginfo.to_location dbg) + (Warnings.Inlining_impossible "[@specialised] attributes may not be used \ + on partial applications") + | Default_specialise -> () + end; + let freshened_params = + List.map (fun p -> Parameter.rename p) function_decl.A.params + in + let applied_args, remaining_args = + Misc.Stdlib.List.map2_prefix (fun arg id' -> id', arg) + args freshened_params + in + let wrapper_accepting_remaining_args = + let body : Flambda.t = + Apply { + func = lhs_of_application; + args = Parameter.List.vars freshened_params; + kind = Direct closure_id_being_applied; + dbg; + inline = Default_inline; + specialise = Default_specialise; + } + in + let closure_variable = + Variable.rename + (Closure_id.unwrap closure_id_being_applied) + in + Flambda_utils.make_closure_declaration ~id:closure_variable + ~is_classic_mode:false + ~body + ~params:remaining_args + ~stub:true + in + let with_known_args = + Flambda_utils.bind + ~bindings:(List.map (fun (param, arg) -> + Parameter.var param, Flambda.Expr (Var arg)) applied_args) + ~body:wrapper_accepting_remaining_args + in + simplify env r with_known_args + +and simplify_over_application env r ~args ~args_approxs ~function_decls + ~lhs_of_application ~closure_id_being_applied ~function_decl + ~value_set_of_closures ~dbg ~inline_requested ~specialise_requested = + let arity = A.function_arity function_decl in + assert (arity < List.length args); + assert (List.length args = List.length args_approxs); + let full_app_args, remaining_args = + Misc.Stdlib.List.split_at arity args + in + let full_app_approxs, _ = + Misc.Stdlib.List.split_at arity args_approxs + in + let expr, r = + simplify_full_application env r ~function_decls ~lhs_of_application + ~closure_id_being_applied ~function_decl ~value_set_of_closures + ~args:full_app_args ~args_approxs:full_app_approxs ~dbg + ~inline_requested ~specialise_requested + in + let func_var = Variable.create Internal_variable_names.full_apply in + let expr : Flambda.t = + Flambda.create_let func_var (Expr expr) + (Apply { func = func_var; args = remaining_args; kind = Indirect; dbg; + inline = inline_requested; specialise = specialise_requested; }) + in + let expr = Lift_code.lift_lets_expr expr ~toplevel:true in + simplify (E.set_never_inline env) r expr + +and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t = + match tree with + | Symbol sym -> + (* New Symbol construction could have been introduced during + transformation (by simplify_named_using_approx_and_env). + When this comes from another compilation unit, we must load it. *) + let approx = E.find_or_load_symbol env sym in + simplify_named_using_approx r tree approx + | Const cst -> tree, ret r (simplify_const cst) + | Allocated_const cst -> tree, ret r (approx_for_allocated_const cst) + | Read_mutable mut_var -> + (* See comment on the [Assign] case. *) + let mut_var = + Freshening.apply_mutable_variable (E.freshening env) mut_var + in + Read_mutable mut_var, ret r (A.value_unknown Other) + | Read_symbol_field (symbol, field_index) -> + let approx = E.find_or_load_symbol env symbol in + begin match A.get_field approx ~field_index with + (* CR-someday mshinwell: Think about [Unreachable] vs. [Value_bottom]. *) + | Unreachable -> (Flambda.Expr Proved_unreachable), r + | Ok approx -> + let approx = A.augment_with_symbol_field approx symbol field_index in + simplify_named_using_approx_and_env env r tree approx + end + | Set_of_closures set_of_closures -> begin + let backend = E.backend env in + let set_of_closures, r, first_freshening = + simplify_set_of_closures env r set_of_closures + in + let simplify env r expr ~pass_name : Flambda.named * R.t = + (* If simplifying a set of closures more than once during any given round + of simplification, the [Freshening.Project_var] substitutions arising + from each call to [simplify_set_of_closures] must be composed. + Note that this function only composes with [first_freshening] owing + to the structure of the code below (this new [simplify] is always + in tail position). *) + (* CR-someday mshinwell: It was mooted that maybe we could try + structurally-typed closures (i.e. where we would never rename the + closure elements), or something else, to try to remove + the "closure freshening" thing in the approximation which is hard + to deal with. *) + let expr, r = simplify (E.set_never_inline env) r expr in + let approx = R.approx r in + let value_set_of_closures = + match A.strict_check_approx_for_set_of_closures approx with + | Wrong -> + Misc.fatal_errorf "Unexpected approximation returned from \ + simplification of [%s] result: %a" + pass_name A.print approx + | Ok (_var, value_set_of_closures) -> + let freshening = + Freshening.Project_var.compose ~earlier:first_freshening + ~later:value_set_of_closures.freshening + in + A.update_freshening_of_value_set_of_closures value_set_of_closures + ~freshening + in + Expr expr, (ret r (A.value_set_of_closures value_set_of_closures)) + in + (* This does the actual substitutions of specialised args introduced + by [Unbox_closures] for free variables. (Apart from simplifying + the [Unbox_closures] output, this also prevents applying + [Unbox_closures] over and over.) *) + let set_of_closures = + let ppf_dump = Inline_and_simplify_aux.Env.ppf_dump env in + match Remove_free_vars_equal_to_args.run ~ppf_dump set_of_closures with + | None -> set_of_closures + | Some set_of_closures -> set_of_closures + in + (* Do [Unbox_closures] next to try to decide which things are + free variables and which things are specialised arguments before + unboxing them. *) + match + Unbox_closures.rewrite_set_of_closures ~env + ~duplicate_function ~set_of_closures + with + | Some (expr, benefit) -> + let r = R.add_benefit r benefit in + simplify env r expr ~pass_name:"Unbox_closures" + | None -> + match Unbox_free_vars_of_closures.run ~env ~set_of_closures with + | Some (expr, benefit) -> + let r = R.add_benefit r benefit in + simplify env r expr ~pass_name:"Unbox_free_vars_of_closures" + | None -> + (* CR-soon mshinwell: should maybe add one allocation for the stub *) + match + Unbox_specialised_args.rewrite_set_of_closures ~env + ~duplicate_function ~set_of_closures + with + | Some (expr, benefit) -> + let r = R.add_benefit r benefit in + simplify env r expr ~pass_name:"Unbox_specialised_args" + | None -> + match + Remove_unused_arguments. + separate_unused_arguments_in_set_of_closures + set_of_closures ~backend + with + | Some set_of_closures -> + let expr = + Flambda_utils.name_expr (Set_of_closures set_of_closures) + ~name:Internal_variable_names.remove_unused_arguments + in + simplify env r expr ~pass_name:"Remove_unused_arguments" + | None -> + Set_of_closures set_of_closures, r + end + | Project_closure project_closure -> + simplify_project_closure env r ~project_closure + | Project_var project_var -> simplify_project_var env r ~project_var + | Move_within_set_of_closures move_within_set_of_closures -> + simplify_move_within_set_of_closures env r ~move_within_set_of_closures + | Prim (prim, args, dbg) -> + let dbg = E.add_inlined_debuginfo env ~dbg in + simplify_free_variables_named env args ~f:(fun env args args_approxs -> + let tree = Flambda.Prim (prim, args, dbg) in + begin match prim, args, args_approxs with + (* CR-someday mshinwell: Optimise [Pfield_computed]. *) + | Pfield field_index, [arg], [arg_approx] -> + let projection : Projection.t = Field (field_index, arg) in + begin match E.find_projection env ~projection with + | Some var -> + simplify_free_variable_named env var ~f:(fun _env var var_approx -> + let r = R.map_benefit r (B.remove_projection projection) in + Expr (Var var), ret r var_approx) + | None -> + begin match A.get_field arg_approx ~field_index with + | Unreachable -> (Flambda.Expr Proved_unreachable, r) + | Ok approx -> + let tree, approx = + match arg_approx.symbol with + (* If the [Pfield] is projecting directly from a symbol, rewrite + the expression to [Read_symbol_field]. *) + | Some (symbol, None) -> + let approx = + A.augment_with_symbol_field approx symbol field_index + in + Flambda.Read_symbol_field (symbol, field_index), approx + | None | Some (_, Some _ ) -> + (* This [Pfield] is either not projecting from a symbol at all, + or it is the projection of a projection from a symbol. *) + let approx' = E.really_import_approx env approx in + tree, approx' + in + simplify_named_using_approx_and_env env r tree approx + end + end + | Pfield _, _, _ -> Misc.fatal_error "Pfield arity error" + | (Parraysetu kind | Parraysets kind), + [_block; _field; _value], + [block_approx; _field_approx; value_approx] -> + if A.warn_on_mutation block_approx then begin + Location.prerr_warning (Debuginfo.to_location dbg) + Warnings.Assignment_to_non_mutable_value + end; + let kind = + let check () = + match kind with + | Pfloatarray | Pgenarray -> () + | Paddrarray | Pintarray -> + (* CR pchambart: Do a proper warning here *) + Misc.fatal_errorf "Assignment of a float to a specialised \ + non-float array: %a" + Flambda.print_named tree + in + match A.descr block_approx, A.descr value_approx with + | (Value_float_array _, _) -> check (); Lambda.Pfloatarray + | (_, Value_float _) when Config.flat_float_array -> + check (); Lambda.Pfloatarray + (* CR pchambart: This should be accounted by the benefit *) + | _ -> + kind + in + let prim : Clambda_primitives.primitive = match prim with + | Parraysetu _ -> Parraysetu kind + | Parraysets _ -> Parraysets kind + | _ -> assert false + in + Prim (prim, args, dbg), ret r (A.value_unknown Other) + | Psetfield _, _block::_, block_approx::_ -> + if A.warn_on_mutation block_approx then begin + Location.prerr_warning (Debuginfo.to_location dbg) + Warnings.Assignment_to_non_mutable_value + end; + tree, ret r (A.value_unknown Other) + | (Psetfield _ | Parraysetu _ | Parraysets _), _, _ -> + Misc.fatal_error "Psetfield / Parraysetu / Parraysets arity error" + | (Psequand | Psequor), _, _ -> + Misc.fatal_error "Psequand and Psequor must be expanded (see handling \ + in closure_conversion.ml)" + | p, args, args_approxs -> + let expr, approx, benefit = + let module Backend = (val (E.backend env) : Backend_intf.S) in + Simplify_primitives.primitive p (args, args_approxs) tree dbg + ~size_int:Backend.size_int + in + let r = R.map_benefit r (B.(+) benefit) in + let approx = + match p with + | Popaque -> A.value_unknown Other + | _ -> approx + in + expr, ret r approx + end) + | Expr expr -> + let expr, r = simplify env r expr in + Expr expr, r + +and simplify env r (tree : Flambda.t) : Flambda.t * R.t = + match tree with + | Var var -> + let var = Freshening.apply_variable (E.freshening env) var in + (* If from the approximations we can simplify [var], then we will be + forced to insert [let]-expressions (done using [name_expr], in + [Simple_value_approx]) to bind a [named]. This has an important + consequence: it brings bindings of constants closer to their use + points. *) + simplify_using_approx_and_env env r (Var var) (E.find_exn env var) + | Apply apply -> + simplify_apply env r ~apply + | Let _ -> + let for_defining_expr (env, r) var defining_expr = + let defining_expr, r = simplify_named env r defining_expr in + let var, sb = Freshening.add_variable (E.freshening env) var in + let env = E.set_freshening env sb in + let env = E.add env var (R.approx r) in + (env, r), var, defining_expr + in + let for_last_body (env, r) body = + simplify env r body + in + let filter_defining_expr r var defining_expr free_vars_of_body = + if Variable.Set.mem var free_vars_of_body then + r, var, Some defining_expr + else if Effect_analysis.no_effects_named defining_expr then + let r = R.map_benefit r (B.remove_code_named defining_expr) in + r, var, None + else + r, var, Some defining_expr + in + Flambda.fold_lets_option tree + ~init:(env, r) + ~for_defining_expr + ~for_last_body + ~filter_defining_expr + | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> + (* CR-someday mshinwell: add the dead let elimination, as above. *) + simplify_free_variable env var ~f:(fun env var _var_approx -> + let mut_var, sb = + Freshening.add_mutable_variable (E.freshening env) mut_var + in + let env = E.set_freshening env sb in + let body, r = + simplify (E.add_mutable env mut_var (A.value_unknown Other)) r body + in + Flambda.Let_mutable + { var = mut_var; + initial_value = var; + body; + contents_kind }, + r) + | Let_rec (defs, body) -> + let defs, sb = Freshening.add_variables (E.freshening env) defs in + let env = E.set_freshening env sb in + let def_env = + List.fold_left (fun env_acc (id, _lam) -> + E.add env_acc id (A.value_unknown Other)) + env defs + in + let defs, body_env, r = + List.fold_right (fun (id, lam) (defs, env_acc, r) -> + let lam, r = simplify_named def_env r lam in + let defs = (id, lam) :: defs in + let env_acc = E.add env_acc id (R.approx r) in + defs, env_acc, r) + defs ([], env, r) + in + let body, r = simplify body_env r body in + Let_rec (defs, body), r + | Static_raise (i, args) -> + let i = Freshening.apply_static_exception (E.freshening env) i in + simplify_free_variables env args ~f:(fun _env args _args_approxs -> + let r = R.use_static_exception r i in + Static_raise (i, args), ret r A.value_bottom) + | Static_catch (i, vars, body, handler) -> + begin + match body with + | Let { var; defining_expr = def; body; _ } + when not (Flambda_utils.might_raise_static_exn def i) -> + simplify env r + (Flambda.create_let var def (Static_catch (i, vars, body, handler))) + | _ -> + let i, sb = Freshening.add_static_exception (E.freshening env) i in + let env = E.set_freshening env sb in + let body, r = simplify env r body in + (* CR-soon mshinwell: for robustness, R.used_static_exceptions should + maybe be removed. *) + if not (Static_exception.Set.mem i (R.used_static_exceptions r)) then + (* If the static exception is not used, we can drop the declaration *) + body, r + else begin + match (body : Flambda.t) with + | Static_raise (j, args) -> + assert (Static_exception.equal i j); + let handler = + List.fold_left2 (fun body var arg -> + Flambda.create_let var (Expr (Var arg)) body) + handler vars args + in + let r = R.exit_scope_catch r i in + simplify env r handler + | _ -> + let vars, sb = Freshening.add_variables' (E.freshening env) vars in + let approx = R.approx r in + let env = + List.fold_left (fun env id -> + E.add env id (A.value_unknown Other)) + (E.set_freshening env sb) vars + in + let env = E.inside_branch env in + let handler, r = simplify env r handler in + let r = R.exit_scope_catch r i in + Static_catch (i, vars, body, handler), + R.meet_approx r env approx + end + end + | Try_with (body, id, handler) -> + let body, r = simplify env r body in + let id, sb = Freshening.add_variable (E.freshening env) id in + let env = E.add (E.set_freshening env sb) id (A.value_unknown Other) in + let env = E.inside_branch env in + let handler, r = simplify env r handler in + Try_with (body, id, handler), ret r (A.value_unknown Other) + | If_then_else (arg, ifso, ifnot) -> + (* When arg is the constant false or true (or something considered + as true), we can drop the if and replace it by a sequence. + if arg is not effectful we can also drop it. *) + simplify_free_variable env arg ~f:(fun env arg arg_approx -> + begin match arg_approx.descr with + | Value_constptr 0 | Value_int 0 -> (* Constant [false]: keep [ifnot] *) + let ifnot, r = simplify env r ifnot in + ifnot, R.map_benefit r B.remove_branch + | Value_constptr _ | Value_int _ + | Value_block _ -> (* Constant [true]: keep [ifso] *) + let ifso, r = simplify env r ifso in + ifso, R.map_benefit r B.remove_branch + | _ -> + let env = E.inside_branch env in + let ifso, r = simplify env r ifso in + let ifso_approx = R.approx r in + let ifnot, r = simplify env r ifnot in + If_then_else (arg, ifso, ifnot), + R.meet_approx r env ifso_approx + end) + | While (cond, body) -> + let cond, r = simplify env r cond in + let body, r = simplify env r body in + While (cond, body), ret r (A.value_unknown Other) + | Send { kind; meth; obj; args; dbg; } -> + let dbg = E.add_inlined_debuginfo env ~dbg in + simplify_free_variable env meth ~f:(fun env meth _meth_approx -> + simplify_free_variable env obj ~f:(fun env obj _obj_approx -> + simplify_free_variables env args ~f:(fun _env args _args_approx -> + Send { kind; meth; obj; args; dbg; }, + ret r (A.value_unknown Other)))) + | For { bound_var; from_value; to_value; direction; body; } -> + simplify_free_variable env from_value ~f:(fun env from_value _approx -> + simplify_free_variable env to_value ~f:(fun env to_value _approx -> + let bound_var, sb = + Freshening.add_variable (E.freshening env) bound_var + in + let env = + E.add (E.set_freshening env sb) bound_var + (A.value_unknown Other) + in + let body, r = simplify env r body in + For { bound_var; from_value; to_value; direction; body; }, + ret r (A.value_unknown Other))) + | Assign { being_assigned; new_value; } -> + (* No need to use something like [simplify_free_variable]: the + approximation of [being_assigned] is always unknown. *) + let being_assigned = + Freshening.apply_mutable_variable (E.freshening env) being_assigned + in + simplify_free_variable env new_value ~f:(fun _env new_value _approx -> + Assign { being_assigned; new_value; }, ret r (A.value_unknown Other)) + | Switch (arg, sw) -> + (* When [arg] is known to be a variable whose approximation is that of a + block with a fixed tag or a fixed integer, we can eliminate the + [Switch]. (This should also make the [Let] that binds [arg] redundant, + meaning that it too can be eliminated.) *) + simplify_free_variable env arg ~f:(fun env arg arg_approx -> + let rec filter_branches filter branches compatible_branches = + match branches with + | [] -> Can_be_taken compatible_branches + | (c, lam) as branch :: branches -> + match filter arg_approx c with + | A.Cannot_be_taken -> + filter_branches filter branches compatible_branches + | A.Can_be_taken -> + filter_branches filter branches (branch :: compatible_branches) + | A.Must_be_taken -> + Must_be_taken lam + in + let filtered_consts = + filter_branches A.potentially_taken_const_switch_branch sw.consts [] + in + let filtered_blocks = + filter_branches A.potentially_taken_block_switch_branch sw.blocks [] + in + begin match filtered_consts, filtered_blocks with + | Must_be_taken _, Must_be_taken _ -> + assert false + | Must_be_taken branch, _ + | _, Must_be_taken branch -> + let lam, r = simplify env r branch in + lam, R.map_benefit r B.remove_branch + | Can_be_taken consts, Can_be_taken blocks -> + match consts, blocks, sw.failaction with + | [], [], None -> + (* If the switch is applied to a statically-known value that does not + match any case: + * if there is a default action take that case; + * otherwise this is something that is guaranteed not to + be reachable by the type checker. For example: + [type 'a t = Int : int -> int t | Float : float -> float t + match Int 1 with + | Int _ -> ... + | Float f as v -> + match v with <-- This match is unreachable + | Float f -> ...] + *) + Proved_unreachable, ret r A.value_bottom + | [_, branch], [], None + | [], [_, branch], None + | [], [], Some branch -> + let lam, r = simplify env r branch in + lam, R.map_benefit r B.remove_branch + | _ -> + let env = E.inside_branch env in + let f (i, v) (acc, r) = + let approx = R.approx r in + let lam, r = simplify env r v in + (i, lam)::acc, + R.meet_approx r env approx + in + let r = R.set_approx r A.value_bottom in + let consts, r = List.fold_right f consts ([], r) in + let blocks, r = List.fold_right f blocks ([], r) in + let failaction, r = + match sw.failaction with + | None -> None, r + | Some l -> + let approx = R.approx r in + let l, r = simplify env r l in + Some l, + R.meet_approx r env approx + in + let sw = { sw with failaction; consts; blocks; } in + Switch (arg, sw), r + end) + | String_switch (arg, sw, def) -> + simplify_free_variable env arg ~f:(fun env arg arg_approx -> + match A.check_approx_for_string arg_approx with + | None -> + let env = E.inside_branch env in + let sw, r = + List.fold_right (fun (str, lam) (sw, r) -> + let approx = R.approx r in + let lam, r = simplify env r lam in + (str, lam)::sw, + R.meet_approx r env approx) + sw + ([], r) + in + let def, r = + match def with + | None -> def, r + | Some def -> + let approx = R.approx r in + let def, r = simplify env r def in + Some def, + R.meet_approx r env approx + in + String_switch (arg, sw, def), ret r (A.value_unknown Other) + | Some arg_string -> + let branch = + match List.find (fun (str, _) -> String.equal str arg_string) sw with + | (_, branch) -> branch + | exception Not_found -> + match def with + | None -> + Flambda.Proved_unreachable + | Some def -> + def + in + let branch, r = simplify env r branch in + branch, R.map_benefit r B.remove_branch) + | Proved_unreachable -> tree, ret r A.value_bottom + +and simplify_list env r l = + match l with + | [] -> [], [], r + | h::t -> + let t', approxs, r = simplify_list env r t in + let h', r = simplify env r h in + let approxs = (R.approx r) :: approxs in + if t' == t && h' == h + then l, approxs, r + else h' :: t', approxs, r + +and duplicate_function ~env ~(set_of_closures : Flambda.set_of_closures) + ~fun_var ~new_fun_var = + let function_decl = + match Variable.Map.find fun_var set_of_closures.function_decls.funs with + | exception Not_found -> + Misc.fatal_errorf "duplicate_function: cannot find function %a" + Variable.print fun_var + | function_decl -> function_decl + in + let env = E.activate_freshening (E.set_never_inline env) in + let free_vars, specialised_args, function_decls, parameter_approximations, + _internal_value_set_of_closures, set_of_closures_env = + Inline_and_simplify_aux.prepare_to_simplify_set_of_closures ~env + ~set_of_closures ~function_decls:set_of_closures.function_decls + ~freshen:false ~only_for_function_decl:(Some function_decl) + in + let function_decl = + match Variable.Map.find fun_var function_decls.funs with + | exception Not_found -> + Misc.fatal_errorf "duplicate_function: cannot find function %a (2)" + Variable.print fun_var + | function_decl -> function_decl + in + let closure_env = + Inline_and_simplify_aux.prepare_to_simplify_closure ~function_decl + ~free_vars ~specialised_args ~parameter_approximations + ~set_of_closures_env + in + let body, _r = + E.enter_closure closure_env + ~closure_id:(Closure_id.wrap fun_var) + ~inline_inside:false + ~dbg:function_decl.dbg + ~f:(fun body_env -> + assert (E.inside_set_of_closures_declaration + function_decls.set_of_closures_origin body_env); + simplify body_env (R.create ()) function_decl.body) + in + let function_decl = + Flambda.create_function_declaration ~params:function_decl.params + ~body ~stub:function_decl.stub ~dbg:function_decl.dbg + ~inline:function_decl.inline ~specialise:function_decl.specialise + ~is_a_functor:function_decl.is_a_functor + ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var)) + in + function_decl, specialised_args + +let constant_defining_value_approx + env + (constant_defining_value:Flambda.constant_defining_value) = + match constant_defining_value with + | Allocated_const const -> + approx_for_allocated_const const + | Block (tag, fields) -> + let fields = + List.map + (function + | Flambda.Symbol sym -> begin + match E.find_symbol_opt env sym with + | Some approx -> approx + | None -> A.value_unresolved (Symbol sym) + end + | Flambda.Const cst -> simplify_const cst) + fields + in + A.value_block tag (Array.of_list fields) + | Set_of_closures { function_decls; free_vars; specialised_args } -> + (* At toplevel, there is no freshening currently happening (this + cannot be the body of a currently inlined function), so we can + keep the original set_of_closures in the approximation. *) + assert(Freshening.is_empty (E.freshening env)); + assert(Variable.Map.is_empty free_vars); + assert(Variable.Map.is_empty specialised_args); + let invariant_params = + lazy (Invariant_params.invariant_params_in_recursion function_decls + ~backend:(E.backend env)) + in + let recursive = + lazy (Find_recursive_functions.in_function_declarations function_decls + ~backend:(E.backend env)) + in + let value_set_of_closures = + let keep_body = + Inline_and_simplify_aux.keep_body_check + ~is_classic_mode:function_decls.is_classic_mode ~recursive + in + let function_decls = + A.function_declarations_approx ~keep_body function_decls + in + A.create_value_set_of_closures ~function_decls + ~bound_vars:Var_within_closure.Map.empty + ~invariant_params + ~recursive + ~specialised_args:Variable.Map.empty + ~free_vars:Variable.Map.empty + ~freshening:Freshening.Project_var.empty + ~direct_call_surrogates:Closure_id.Map.empty + in + A.value_set_of_closures value_set_of_closures + | Project_closure (set_of_closures_symbol, closure_id) -> begin + match E.find_symbol_opt env set_of_closures_symbol with + | None -> + A.value_unresolved (Symbol set_of_closures_symbol) + | Some set_of_closures_approx -> + let checked_approx = + A.check_approx_for_set_of_closures set_of_closures_approx + in + match checked_approx with + | Ok (_, value_set_of_closures) -> + let closure_id = + A.freshen_and_check_closure_id value_set_of_closures closure_id + in + A.value_closure value_set_of_closures closure_id + | Unresolved sym -> A.value_unresolved sym + | Unknown -> A.value_unknown Other + | Unknown_because_of_unresolved_value value -> + A.value_unknown (Unresolved_value value) + | Wrong -> + Misc.fatal_errorf "Wrong approximation for [Project_closure] \ + when being used as a [constant_defining_value]: %a" + Flambda.print_constant_defining_value constant_defining_value + end + +(* See documentation on [Let_rec_symbol] in flambda.mli. *) +let define_let_rec_symbol_approx orig_env defs = + (* First declare an empty version of the symbols *) + let init_env = + List.fold_left (fun building_env (symbol, _) -> + E.add_symbol building_env symbol (A.value_unresolved (Symbol symbol))) + orig_env defs + in + let rec loop times lookup_env = + if times <= 0 then + lookup_env + else + let env = + List.fold_left (fun building_env (symbol, constant_defining_value) -> + let approx = + constant_defining_value_approx lookup_env constant_defining_value + in + let approx = A.augment_with_symbol approx symbol in + E.add_symbol building_env symbol approx) + orig_env defs + in + loop (times-1) env + in + loop 2 init_env + +let simplify_constant_defining_value + env r symbol + (constant_defining_value:Flambda.constant_defining_value) = + let r, constant_defining_value, approx = + match constant_defining_value with + (* No simplifications are possible for [Allocated_const] or [Block]. *) + | Allocated_const const -> + r, constant_defining_value, approx_for_allocated_const const + | Block (tag, fields) -> + let fields = List.map + (function + | Flambda.Symbol sym -> E.find_symbol_exn env sym + | Flambda.Const cst -> simplify_const cst) + fields + in + r, constant_defining_value, A.value_block tag (Array.of_list fields) + | Set_of_closures set_of_closures -> + if Variable.Map.cardinal set_of_closures.free_vars <> 0 then begin + Misc.fatal_errorf "Set of closures bound by [Let_symbol] is not \ + closed: %a" + Flambda.print_set_of_closures set_of_closures + end; + let set_of_closures, r, _freshening = + simplify_set_of_closures env r set_of_closures + in + r, ((Set_of_closures set_of_closures) : Flambda.constant_defining_value), + R.approx r + | Project_closure (set_of_closures_symbol, closure_id) -> + (* No simplifications are necessary here. *) + let set_of_closures_approx = + E.find_symbol_exn env set_of_closures_symbol + in + let closure_approx = + match A.check_approx_for_set_of_closures set_of_closures_approx with + | Ok (_, value_set_of_closures) -> + let closure_id = + A.freshen_and_check_closure_id value_set_of_closures closure_id + in + A.value_closure value_set_of_closures closure_id + | Unresolved sym -> A.value_unresolved sym + | Unknown -> A.value_unknown Other + | Unknown_because_of_unresolved_value value -> + A.value_unknown (Unresolved_value value) + | Wrong -> + Misc.fatal_errorf "Wrong approximation for [Project_closure] \ + when being used as a [constant_defining_value]: %a" + Flambda.print_constant_defining_value constant_defining_value + in + r, constant_defining_value, closure_approx + in + let approx = A.augment_with_symbol approx symbol in + let r = ret r approx in + r, constant_defining_value, approx + +let rec simplify_program_body env r (program : Flambda.program_body) + : Flambda.program_body * R.t = + match program with + | Let_rec_symbol (defs, program) -> + let set_of_closures_defs, other_defs = + List.partition + (function + | (_, Flambda.Set_of_closures _) -> true + | _ -> false) + defs in + let process_defs ~lookup_env ~env r defs = + List.fold_left (fun (building_env, r, defs) (symbol, def) -> + let r, def, approx = + simplify_constant_defining_value lookup_env r symbol def + in + let approx = A.augment_with_symbol approx symbol in + let building_env = E.add_symbol building_env symbol approx in + (building_env, r, (symbol, def) :: defs)) + (env, r, []) defs + in + let env, r, set_of_closures_defs = + let lookup_env = define_let_rec_symbol_approx env defs in + process_defs ~lookup_env ~env r set_of_closures_defs + in + let env, r, other_defs = + let lookup_env = define_let_rec_symbol_approx env other_defs in + process_defs ~lookup_env ~env r other_defs + in + let program, r = simplify_program_body env r program in + Let_rec_symbol (set_of_closures_defs @ other_defs, program), r + | Let_symbol (symbol, constant_defining_value, program) -> + let r, constant_defining_value, approx = + simplify_constant_defining_value env r symbol constant_defining_value + in + let approx = A.augment_with_symbol approx symbol in + let env = E.add_symbol env symbol approx in + let program, r = simplify_program_body env r program in + Let_symbol (symbol, constant_defining_value, program), r + | Initialize_symbol (symbol, tag, fields, program) -> + let fields, approxs, r = simplify_list env r fields in + let approx = + A.augment_with_symbol (A.value_block tag (Array.of_list approxs)) symbol + in + let module Backend = (val (E.backend env) : Backend_intf.S) in + let env = E.add_symbol env symbol approx in + let program, r = simplify_program_body env r program in + Initialize_symbol (symbol, tag, fields, program), r + | Effect (expr, program) -> + let expr, r = simplify env r expr in + let program, r = simplify_program_body env r program in + Effect (expr, program), r + | End root -> End root, r + +let simplify_program env r (program : Flambda.program) = + let env, r = + Symbol.Set.fold (fun symbol (env, r) -> + let env, approx = + match E.find_symbol_exn env symbol with + | exception Not_found -> + let module Backend = (val (E.backend env) : Backend_intf.S) in + (* CR-someday mshinwell for mshinwell: Is there a reason we cannot + use [simplify_named_using_approx_and_env] here? *) + let approx = Backend.import_symbol symbol in + E.add_symbol env symbol approx, approx + | approx -> env, approx + in + env, ret r approx) + program.imported_symbols + (env, r) + in + let program_body, r = simplify_program_body env r program.program_body in + let program = { program with program_body; } in + program, r + +let add_predef_exns_to_environment ~env ~backend = + let module Backend = (val backend : Backend_intf.S) in + List.fold_left (fun env predef_exn -> + assert (Ident.is_predef predef_exn); + let symbol = Backend.symbol_for_global' predef_exn in + let name = Ident.name predef_exn in + let approx = + A.value_block Tag.object_tag + [| A.value_string (String.length name) (Some name); + A.value_unknown Other; + |] + in + E.add_symbol env symbol (A.augment_with_symbol approx symbol)) + env + Predef.all_predef_exns + +let run ~never_inline ~backend ~prefixname ~round ~ppf_dump program = + let r = R.create () in + let report = !Clflags.inlining_report in + if never_inline then Clflags.inlining_report := false; + let initial_env = + add_predef_exns_to_environment + ~env:(E.create ~never_inline ~backend ~round ~ppf_dump) + ~backend + in + let result, r = simplify_program initial_env r program in + let result = Flambda_utils.introduce_needed_import_symbols result in + if not (Static_exception.Set.is_empty (R.used_static_exceptions r)) + then begin + Misc.fatal_error (Format.asprintf "Remaining static exceptions: %a@.%a@." + Static_exception.Set.print (R.used_static_exceptions r) + Flambda.print_program result) + end; + assert (Static_exception.Set.is_empty (R.used_static_exceptions r)); + if !Clflags.inlining_report then begin + let output_prefix = Printf.sprintf "%s.%d" prefixname round in + Inlining_stats.save_then_forget_decisions ~output_prefix + end; + Clflags.inlining_report := report; + result diff --git a/middle_end/flambda/inline_and_simplify.mli b/middle_end/flambda/inline_and_simplify.mli new file mode 100644 index 00000000..9a8e6e8b --- /dev/null +++ b/middle_end/flambda/inline_and_simplify.mli @@ -0,0 +1,40 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Simplification of Flambda programs combined with function inlining: + for the most part a beta-reduction pass. + + Readers interested in the inlining strategy should read the + [Inlining_decision] module first. +*) +val run + : never_inline:bool + -> backend:(module Backend_intf.S) + -> prefixname:string + -> round:int + -> ppf_dump:Format.formatter + -> Flambda.program + -> Flambda.program + +val duplicate_function + : env:Inline_and_simplify_aux.Env.t + -> set_of_closures:Flambda.set_of_closures + -> fun_var:Variable.t + -> new_fun_var:Variable.t + -> Flambda.function_declaration + * Flambda.specialised_to Variable.Map.t (* new specialised arguments *) diff --git a/middle_end/flambda/inline_and_simplify_aux.ml b/middle_end/flambda/inline_and_simplify_aux.ml new file mode 100644 index 00000000..bb725e8c --- /dev/null +++ b/middle_end/flambda/inline_and_simplify_aux.ml @@ -0,0 +1,738 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module Env = struct + type scope = Current | Outer + + type t = { + backend : (module Backend_intf.S); + round : int; + ppf_dump : Format.formatter; + approx : (scope * Simple_value_approx.t) Variable.Map.t; + approx_mutable : Simple_value_approx.t Mutable_variable.Map.t; + approx_sym : Simple_value_approx.t Symbol.Map.t; + projections : Variable.t Projection.Map.t; + current_functions : Set_of_closures_origin.Set.t; + (* The functions currently being declared: used to avoid inlining + recursively *) + inlining_level : int; + (* Number of times "inline" has been called recursively *) + inside_branch : int; + freshening : Freshening.t; + never_inline : bool ; + never_inline_inside_closures : bool; + never_inline_outside_closures : bool; + unroll_counts : int Set_of_closures_origin.Map.t; + inlining_counts : int Closure_origin.Map.t; + actively_unrolling : int Set_of_closures_origin.Map.t; + closure_depth : int; + inlining_stats_closure_stack : Inlining_stats.Closure_stack.t; + inlined_debuginfo : Debuginfo.t; + } + + let create ~never_inline ~backend ~round ~ppf_dump = + { backend; + round; + ppf_dump; + approx = Variable.Map.empty; + approx_mutable = Mutable_variable.Map.empty; + approx_sym = Symbol.Map.empty; + projections = Projection.Map.empty; + current_functions = Set_of_closures_origin.Set.empty; + inlining_level = 0; + inside_branch = 0; + freshening = Freshening.empty; + never_inline; + never_inline_inside_closures = false; + never_inline_outside_closures = false; + unroll_counts = Set_of_closures_origin.Map.empty; + inlining_counts = Closure_origin.Map.empty; + actively_unrolling = Set_of_closures_origin.Map.empty; + closure_depth = 0; + inlining_stats_closure_stack = + Inlining_stats.Closure_stack.create (); + inlined_debuginfo = Debuginfo.none; + } + + let backend t = t.backend + let round t = t.round + let ppf_dump t = t.ppf_dump + + let local env = + { env with + approx = Variable.Map.empty; + projections = Projection.Map.empty; + freshening = Freshening.empty_preserving_activation_state env.freshening; + inlined_debuginfo = Debuginfo.none; + } + + let inlining_level_up env = + let max_level = + Clflags.Int_arg_helper.get ~key:(env.round) !Clflags.inline_max_depth + in + if (env.inlining_level + 1) > max_level then + Misc.fatal_error "Inlining level increased above maximum"; + { env with inlining_level = env.inlining_level + 1 } + + let print ppf t = + Format.fprintf ppf + "Environment maps: %a@.Projections: %a@.Freshening: %a@." + Variable.Set.print (Variable.Map.keys t.approx) + (Projection.Map.print Variable.print) t.projections + Freshening.print t.freshening + + let mem t var = Variable.Map.mem var t.approx + + let add_internal t var (approx : Simple_value_approx.t) ~scope = + let approx = + (* The semantics of this [match] are what preserve the property + described at the top of simple_value_approx.mli, namely that when a + [var] is mem on an approximation (amongst many possible [var]s), + it is the one with the outermost scope. *) + match approx.var with + | Some var when mem t var -> approx + | _ -> Simple_value_approx.augment_with_variable approx var + in + { t with approx = Variable.Map.add var (scope, approx) t.approx } + + let add t var approx = add_internal t var approx ~scope:Current + let add_outer_scope t var approx = add_internal t var approx ~scope:Outer + + let add_mutable t mut_var approx = + { t with approx_mutable = + Mutable_variable.Map.add mut_var approx t.approx_mutable; + } + + let really_import_approx t = + let module Backend = (val (t.backend) : Backend_intf.S) in + Backend.really_import_approx + + let really_import_approx_with_scope t (scope, approx) = + scope, really_import_approx t approx + + let find_symbol_exn t symbol = + really_import_approx t + (Symbol.Map.find symbol t.approx_sym) + + let find_symbol_opt t symbol = + try Some (really_import_approx t + (Symbol.Map.find symbol t.approx_sym)) + with Not_found -> None + + let find_symbol_fatal t symbol = + match find_symbol_exn t symbol with + | exception Not_found -> + Misc.fatal_errorf "Symbol %a is unbound. Maybe there is a missing \ + [Let_symbol], [Import_symbol] or similar?" + Symbol.print symbol + | approx -> approx + + let find_or_load_symbol t symbol = + match find_symbol_exn t symbol with + | exception Not_found -> + if Compilation_unit.equal + (Compilation_unit.get_current_exn ()) + (Symbol.compilation_unit symbol) + then + Misc.fatal_errorf "Symbol %a from the current compilation unit is \ + unbound. Maybe there is a missing [Let_symbol] or similar?" + Symbol.print symbol; + let module Backend = (val (t.backend) : Backend_intf.S) in + Backend.import_symbol symbol + | approx -> approx + + let add_projection t ~projection ~bound_to = + { t with + projections = + Projection.Map.add projection bound_to t.projections; + } + + let find_projection t ~projection = + match Projection.Map.find projection t.projections with + | exception Not_found -> None + | var -> Some var + + let does_not_bind t vars = + not (List.exists (mem t) vars) + + let does_not_freshen t vars = + Freshening.does_not_freshen t.freshening vars + + let add_symbol t symbol approx = + match find_symbol_exn t symbol with + | exception Not_found -> + { t with + approx_sym = Symbol.Map.add symbol approx t.approx_sym; + } + | _ -> + Misc.fatal_errorf "Attempt to redefine symbol %a (to %a) in environment \ + for [Inline_and_simplify]" + Symbol.print symbol + Simple_value_approx.print approx + + let redefine_symbol t symbol approx = + match find_symbol_exn t symbol with + | exception Not_found -> + assert false + | _ -> + { t with + approx_sym = Symbol.Map.add symbol approx t.approx_sym; + } + + let find_with_scope_exn t id = + try + really_import_approx_with_scope t + (Variable.Map.find id t.approx) + with Not_found -> + Misc.fatal_errorf "Env.find_with_scope_exn: Unbound variable \ + %a@.%s@. Environment: %a@." + Variable.print id + (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int)) + print t + + let find_exn t id = + snd (find_with_scope_exn t id) + + let find_mutable_exn t mut_var = + try Mutable_variable.Map.find mut_var t.approx_mutable + with Not_found -> + Misc.fatal_errorf "Env.find_mutable_exn: Unbound variable \ + %a@.%s@. Environment: %a@." + Mutable_variable.print mut_var + (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int)) + print t + + let find_list_exn t vars = + List.map (fun var -> find_exn t var) vars + + let find_opt t id = + try Some (really_import_approx t + (snd (Variable.Map.find id t.approx))) + with Not_found -> None + + let activate_freshening t = + { t with freshening = Freshening.activate t.freshening } + + let enter_set_of_closures_declaration t origin = + { t with + current_functions = + Set_of_closures_origin.Set.add origin t.current_functions; } + + let inside_set_of_closures_declaration origin t = + Set_of_closures_origin.Set.mem origin t.current_functions + + let at_toplevel t = + t.closure_depth = 0 + + let is_inside_branch env = env.inside_branch > 0 + + let branch_depth env = env.inside_branch + + let inside_branch t = + { t with inside_branch = t.inside_branch + 1 } + + let set_freshening t freshening = + { t with freshening; } + + let increase_closure_depth t = + let approx = + Variable.Map.map (fun (_scope, approx) -> Outer, approx) t.approx + in + { t with + approx; + closure_depth = t.closure_depth + 1; + } + + let set_never_inline t = + if t.never_inline then t + else { t with never_inline = true } + + let set_never_inline_inside_closures t = + if t.never_inline_inside_closures then t + else { t with never_inline_inside_closures = true } + + let unset_never_inline_inside_closures t = + if t.never_inline_inside_closures then + { t with never_inline_inside_closures = false } + else t + + let set_never_inline_outside_closures t = + if t.never_inline_outside_closures then t + else { t with never_inline_outside_closures = true } + + let unset_never_inline_outside_closures t = + if t.never_inline_outside_closures then + { t with never_inline_outside_closures = false } + else t + + let actively_unrolling t origin = + match Set_of_closures_origin.Map.find origin t.actively_unrolling with + | count -> Some count + | exception Not_found -> None + + let start_actively_unrolling t origin i = + let actively_unrolling = + Set_of_closures_origin.Map.add origin i t.actively_unrolling + in + { t with actively_unrolling } + + let continue_actively_unrolling t origin = + let unrolling = + try + Set_of_closures_origin.Map.find origin t.actively_unrolling + with Not_found -> + Misc.fatal_error "Unexpected actively unrolled function" + in + let actively_unrolling = + Set_of_closures_origin.Map.add origin (unrolling - 1) t.actively_unrolling + in + { t with actively_unrolling } + + let unrolling_allowed t origin = + let unroll_count = + try + Set_of_closures_origin.Map.find origin t.unroll_counts + with Not_found -> + Clflags.Int_arg_helper.get + ~key:t.round !Clflags.inline_max_unroll + in + unroll_count > 0 + + let inside_unrolled_function t origin = + let unroll_count = + try + Set_of_closures_origin.Map.find origin t.unroll_counts + with Not_found -> + Clflags.Int_arg_helper.get + ~key:t.round !Clflags.inline_max_unroll + in + let unroll_counts = + Set_of_closures_origin.Map.add + origin (unroll_count - 1) t.unroll_counts + in + { t with unroll_counts } + + let inlining_allowed t id = + let inlining_count = + try + Closure_origin.Map.find id t.inlining_counts + with Not_found -> + max 1 (Clflags.Int_arg_helper.get + ~key:t.round !Clflags.inline_max_unroll) + in + inlining_count > 0 + + let inside_inlined_function t id = + let inlining_count = + try + Closure_origin.Map.find id t.inlining_counts + with Not_found -> + max 1 (Clflags.Int_arg_helper.get + ~key:t.round !Clflags.inline_max_unroll) + in + let inlining_counts = + Closure_origin.Map.add id (inlining_count - 1) t.inlining_counts + in + { t with inlining_counts } + + let inlining_level t = t.inlining_level + let freshening t = t.freshening + let never_inline t = t.never_inline || t.never_inline_outside_closures + + let note_entering_closure t ~closure_id ~dbg = + if t.never_inline then t + else + { t with + inlining_stats_closure_stack = + Inlining_stats.Closure_stack.note_entering_closure + t.inlining_stats_closure_stack ~closure_id ~dbg; + } + + let note_entering_call t ~closure_id ~dbg = + if t.never_inline then t + else + { t with + inlining_stats_closure_stack = + Inlining_stats.Closure_stack.note_entering_call + t.inlining_stats_closure_stack ~closure_id ~dbg; + } + + let note_entering_inlined t = + if t.never_inline then t + else + { t with + inlining_stats_closure_stack = + Inlining_stats.Closure_stack.note_entering_inlined + t.inlining_stats_closure_stack; + } + + let note_entering_specialised t ~closure_ids = + if t.never_inline then t + else + { t with + inlining_stats_closure_stack = + Inlining_stats.Closure_stack.note_entering_specialised + t.inlining_stats_closure_stack ~closure_ids; + } + + let enter_closure t ~closure_id ~inline_inside ~dbg ~f = + let t = + if inline_inside && not t.never_inline_inside_closures then t + else set_never_inline t + in + let t = unset_never_inline_outside_closures t in + f (note_entering_closure t ~closure_id ~dbg) + + let record_decision t decision = + Inlining_stats.record_decision decision + ~closure_stack:t.inlining_stats_closure_stack + + let set_inline_debuginfo t ~dbg = + { t with inlined_debuginfo = dbg } + + let add_inlined_debuginfo t ~dbg = + Debuginfo.concat t.inlined_debuginfo dbg +end + +let initial_inlining_threshold ~round : Inlining_cost.Threshold.t = + let unscaled = + Clflags.Float_arg_helper.get ~key:round !Clflags.inline_threshold + in + (* CR-soon pchambart: Add a warning if this is too big + mshinwell: later *) + Can_inline_if_no_larger_than + (int_of_float + (unscaled *. float_of_int Inlining_cost.scale_inline_threshold_by)) + +let initial_inlining_toplevel_threshold ~round : Inlining_cost.Threshold.t = + let ordinary_threshold = + Clflags.Float_arg_helper.get ~key:round !Clflags.inline_threshold + in + let toplevel_threshold = + Clflags.Int_arg_helper.get ~key:round !Clflags.inline_toplevel_threshold + in + let unscaled = + (int_of_float ordinary_threshold) + toplevel_threshold + in + (* CR-soon pchambart: Add a warning if this is too big + mshinwell: later *) + Can_inline_if_no_larger_than + (unscaled * Inlining_cost.scale_inline_threshold_by) + +module Result = struct + type t = + { approx : Simple_value_approx.t; + used_static_exceptions : Static_exception.Set.t; + inlining_threshold : Inlining_cost.Threshold.t option; + benefit : Inlining_cost.Benefit.t; + num_direct_applications : int; + } + + let create () = + { approx = Simple_value_approx.value_unknown Other; + used_static_exceptions = Static_exception.Set.empty; + inlining_threshold = None; + benefit = Inlining_cost.Benefit.zero; + num_direct_applications = 0; + } + + let approx t = t.approx + let set_approx t approx = { t with approx } + + let meet_approx t env approx = + let really_import_approx = Env.really_import_approx env in + let meet = + Simple_value_approx.meet ~really_import_approx t.approx approx + in + set_approx t meet + + let use_static_exception t i = + { t with + used_static_exceptions = + Static_exception.Set.add i t.used_static_exceptions; + } + + let used_static_exceptions t = t.used_static_exceptions + + let exit_scope_catch t i = + { t with + used_static_exceptions = + Static_exception.Set.remove i t.used_static_exceptions; + } + + let map_benefit t f = + { t with benefit = f t.benefit } + + let add_benefit t b = + { t with benefit = Inlining_cost.Benefit.(+) t.benefit b } + + let benefit t = t.benefit + + let reset_benefit t = + { t with benefit = Inlining_cost.Benefit.zero; } + + let set_inlining_threshold t inlining_threshold = + { t with inlining_threshold } + + let add_inlining_threshold t j = + match t.inlining_threshold with + | None -> t + | Some i -> + let inlining_threshold = Some (Inlining_cost.Threshold.add i j) in + { t with inlining_threshold } + + let sub_inlining_threshold t j = + match t.inlining_threshold with + | None -> t + | Some i -> + let inlining_threshold = Some (Inlining_cost.Threshold.sub i j) in + { t with inlining_threshold } + + let inlining_threshold t = t.inlining_threshold + + let seen_direct_application t = + { t with num_direct_applications = t.num_direct_applications + 1; } + + let num_direct_applications t = + t.num_direct_applications +end + +module A = Simple_value_approx +module E = Env + +let keep_body_check ~is_classic_mode ~recursive = + if not is_classic_mode then begin + fun _ _ -> true + end else begin + let can_inline_non_rec_function (fun_decl : Flambda.function_declaration) = + (* In classic-inlining mode, the inlining decision is taken at + definition site (here). If the function is small enough + (below the -inline threshold) it will always be inlined. + + Closure gives a bonus of [8] to optional arguments. In classic + mode, however, we would inline functions with the "*opt*" argument + in all cases, as it is a stub. (This is ensured by + [middle_end/closure_conversion.ml]). + *) + let inlining_threshold = initial_inlining_threshold ~round:0 in + let bonus = Flambda_utils.function_arity fun_decl in + Inlining_cost.can_inline fun_decl.body inlining_threshold ~bonus + in + fun (var : Variable.t) (fun_decl : Flambda.function_declaration) -> + if fun_decl.stub then begin + true + end else if Variable.Set.mem var (Lazy.force recursive) then begin + false + end else begin + match fun_decl.inline with + | Default_inline -> can_inline_non_rec_function fun_decl + | Unroll factor -> factor > 0 + | Always_inline -> true + | Never_inline -> false + end + end + +let prepare_to_simplify_set_of_closures ~env + ~(set_of_closures : Flambda.set_of_closures) + ~function_decls ~freshen + ~(only_for_function_decl : Flambda.function_declaration option) = + let free_vars = + Variable.Map.map (fun (external_var : Flambda.specialised_to) -> + let var = + let var = + Freshening.apply_variable (E.freshening env) external_var.var + in + match + A.simplify_var_to_var_using_env (E.find_exn env var) + ~is_present_in_env:(fun var -> E.mem env var) + with + | None -> var + | Some var -> var + in + let approx = E.find_exn env var in + (* The projections are freshened below in one step, once we know + the closure freshening substitution. *) + let projection = external_var.projection in + ({ var; projection; } : Flambda.specialised_to), approx) + set_of_closures.free_vars + in + let specialised_args = + Variable.Map.filter_map set_of_closures.specialised_args + ~f:(fun param (spec_to : Flambda.specialised_to) -> + let keep = + match only_for_function_decl with + | None -> true + | Some function_decl -> + Variable.Set.mem param (Parameter.Set.vars function_decl.params) + in + if not keep then None + else + let external_var = spec_to.var in + let var = + Freshening.apply_variable (E.freshening env) external_var + in + let var = + match + A.simplify_var_to_var_using_env (E.find_exn env var) + ~is_present_in_env:(fun var -> E.mem env var) + with + | None -> var + | Some var -> var + in + let projection = spec_to.projection in + Some ({ var; projection; } : Flambda.specialised_to)) + in + let environment_before_cleaning = env in + (* [E.local] helps us to catch bugs whereby variables escape their scope. *) + let env = E.local env in + let free_vars, function_decls, sb, freshening = + Freshening.apply_function_decls_and_free_vars (E.freshening env) free_vars + function_decls ~only_freshen_parameters:(not freshen) + in + let env = E.set_freshening env sb in + let free_vars = + Freshening.freshen_projection_relation' free_vars + ~freshening:(E.freshening env) + ~closure_freshening:freshening + in + let specialised_args = + let specialised_args = + Variable.Map.map_keys (Freshening.apply_variable (E.freshening env)) + specialised_args + in + Freshening.freshen_projection_relation specialised_args + ~freshening:(E.freshening env) + ~closure_freshening:freshening + in + let parameter_approximations = + (* Approximations of parameters that are known to always hold the same + argument throughout the body of the function. *) + Variable.Map.map_keys (Freshening.apply_variable (E.freshening env)) + (Variable.Map.mapi (fun _id' (spec_to : Flambda.specialised_to) -> + E.find_exn environment_before_cleaning spec_to.var) + specialised_args) + in + let direct_call_surrogates = + Variable.Map.fold (fun existing surrogate surrogates -> + let existing = + Freshening.Project_var.apply_closure_id freshening + (Closure_id.wrap existing) + in + let surrogate = + Freshening.Project_var.apply_closure_id freshening + (Closure_id.wrap surrogate) + in + assert (not (Closure_id.Map.mem existing surrogates)); + Closure_id.Map.add existing surrogate surrogates) + set_of_closures.direct_call_surrogates + Closure_id.Map.empty + in + let env = + E.enter_set_of_closures_declaration env + function_decls.set_of_closures_origin + in + (* we use the previous closure for evaluating the functions *) + let internal_value_set_of_closures = + let bound_vars = + Variable.Map.fold (fun id (_, desc) map -> + Var_within_closure.Map.add (Var_within_closure.wrap id) desc map) + free_vars Var_within_closure.Map.empty + in + let free_vars = Variable.Map.map fst free_vars in + let invariant_params = lazy Variable.Map.empty in + let recursive = lazy (Variable.Map.keys function_decls.funs) in + let is_classic_mode = function_decls.is_classic_mode in + let keep_body = keep_body_check ~is_classic_mode ~recursive in + let function_decls = + A.function_declarations_approx ~keep_body function_decls + in + A.create_value_set_of_closures ~function_decls ~bound_vars + ~free_vars ~invariant_params ~recursive ~specialised_args + ~freshening ~direct_call_surrogates + in + (* Populate the environment with the approximation of each closure. + This part of the environment is shared between all of the closures in + the set of closures. *) + let set_of_closures_env = + Variable.Map.fold (fun closure _ env -> + let approx = + A.value_closure ~closure_var:closure internal_value_set_of_closures + (Closure_id.wrap closure) + in + E.add env closure approx + ) + function_decls.funs env + in + free_vars, specialised_args, function_decls, parameter_approximations, + internal_value_set_of_closures, set_of_closures_env + +(* This adds only the minimal set of approximations to the closures. + It is not strictly necessary to have this restriction, but it helps + to catch potential substitution bugs. *) +let populate_closure_approximations + ~(function_decl : Flambda.function_declaration) + ~(free_vars : (_ * A.t) Variable.Map.t) + ~(parameter_approximations : A.t Variable.Map.t) + ~set_of_closures_env = + (* Add approximations of free variables *) + let env = + Variable.Map.fold (fun id (_, desc) env -> + E.add_outer_scope env id desc) + free_vars set_of_closures_env + in + (* Add known approximations of function parameters *) + let env = + List.fold_left (fun env id -> + let approx = + try Variable.Map.find id parameter_approximations + with Not_found -> (A.value_unknown Other) + in + E.add env id approx) + env (Parameter.List.vars function_decl.params) + in + env + +let prepare_to_simplify_closure ~(function_decl : Flambda.function_declaration) + ~free_vars ~specialised_args ~parameter_approximations + ~set_of_closures_env = + let closure_env = + populate_closure_approximations ~function_decl ~free_vars + ~parameter_approximations ~set_of_closures_env + in + (* Add definitions of known projections to the environment. *) + let add_projections ~closure_env ~which_variables ~map = + Variable.Map.fold (fun inner_var spec_arg env -> + let (spec_arg : Flambda.specialised_to) = map spec_arg in + match spec_arg.projection with + | None -> env + | Some projection -> + let from = Projection.projecting_from projection in + if Variable.Set.mem from function_decl.free_variables then + E.add_projection env ~projection ~bound_to:inner_var + else + env) + which_variables + closure_env + in + let closure_env = + add_projections ~closure_env ~which_variables:specialised_args + ~map:(fun spec_to -> spec_to) + in + add_projections ~closure_env ~which_variables:free_vars + ~map:(fun (spec_to, _approx) -> spec_to) diff --git a/middle_end/flambda/inline_and_simplify_aux.mli b/middle_end/flambda/inline_and_simplify_aux.mli new file mode 100644 index 00000000..79d84a31 --- /dev/null +++ b/middle_end/flambda/inline_and_simplify_aux.mli @@ -0,0 +1,368 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Environments and result structures used during inlining and + simplification. (See inline_and_simplify.ml.) *) + +module Env : sig + (** Environments follow the lexical scopes of the program. *) + type t + + (** Create a new environment. If [never_inline] is true then the returned + environment will prevent [Inline_and_simplify] from inlining. The + [backend] parameter is used for passing information about the compiler + backend being used. + Newly-created environments have inactive [Freshening]s (see below) and do + not initially hold any approximation information. *) + val create + : never_inline:bool + -> backend:(module Backend_intf.S) + -> round:int + -> ppf_dump:Format.formatter + -> t + + (** Obtain the first-class module that gives information about the + compiler backend being used for compilation. *) + val backend : t -> (module Backend_intf.S) + + (** Obtain the really_import_approx function from the backend module. *) + val really_import_approx + : t + -> (Simple_value_approx.t -> Simple_value_approx.t) + + (** Which simplification round we are currently in. *) + val round : t -> int + + (** Where to print intermediate asts and similar debug information *) + val ppf_dump : t -> Format.formatter + + (** Add the approximation of a variable---that is to say, some knowledge + about the value(s) the variable may take on at runtime---to the + environment. *) + val add : t -> Variable.t -> Simple_value_approx.t -> t + + val add_outer_scope : t -> Variable.t -> Simple_value_approx.t -> t + + (** Like [add], but for mutable variables. *) + val add_mutable : t -> Mutable_variable.t -> Simple_value_approx.t -> t + + (** Find the approximation of a given variable, raising a fatal error if + the environment does not know about the variable. Use [find_opt] + instead if you need to catch the failure case. *) + val find_exn : t -> Variable.t -> Simple_value_approx.t + + (** Like [find_exn], but for mutable variables. *) + val find_mutable_exn : t -> Mutable_variable.t -> Simple_value_approx.t + + type scope = Current | Outer + + val find_with_scope_exn : t -> Variable.t -> scope * Simple_value_approx.t + + (** Like [find_exn], but intended for use where the "not present in + environment" case is to be handled by the caller. *) + val find_opt : t -> Variable.t -> Simple_value_approx.t option + + (** Like [find_exn], but for a list of variables. *) + val find_list_exn : t -> Variable.t list -> Simple_value_approx.t list + + val does_not_bind : t -> Variable.t list -> bool + + val does_not_freshen : t -> Variable.t list -> bool + + val add_symbol : t -> Symbol.t -> Simple_value_approx.t -> t + val redefine_symbol : t -> Symbol.t -> Simple_value_approx.t -> t + val find_symbol_exn : t -> Symbol.t -> Simple_value_approx.t + val find_symbol_opt : t -> Symbol.t -> Simple_value_approx.t option + val find_symbol_fatal : t -> Symbol.t -> Simple_value_approx.t + + (* Like [find_symbol_exn], but load the symbol approximation using + the backend if not available in the environment. *) + val find_or_load_symbol : t -> Symbol.t -> Simple_value_approx.t + + (** Note that the given [bound_to] holds the given [projection]. *) + val add_projection + : t + -> projection:Projection.t + -> bound_to:Variable.t + -> t + + (** Determine if the environment knows about a variable that is bound + to the given [projection]. *) + val find_projection + : t + -> projection:Projection.t + -> Variable.t option + + (** Whether the environment has an approximation for the given variable. *) + val mem : t -> Variable.t -> bool + + (** Return the freshening that should be applied to variables when + rewriting code (in [Inline_and_simplify], etc.) using the given + environment. *) + val freshening : t -> Freshening.t + + (** Set the freshening that should be used as per [freshening], above. *) + val set_freshening : t -> Freshening.t -> t + + (** Causes every bound variable in code rewritten during inlining and + simplification, using the given environment, to be freshened. This is + used when descending into subexpressions substituted into existing + expressions. *) + val activate_freshening : t -> t + + (** Erase all variable approximation information and freshening information + from the given environment. However, the freshening activation state + is preserved. This function is used when rewriting inside a function + declaration, to avoid (due to a compiler bug) accidental use of + variables from outer scopes that are not accessible. *) + val local : t -> t + + (** Determine whether the inliner is currently inside a function body from + the given set of closures. This is used to detect whether a given + function call refers to a function which exists somewhere on the current + inlining stack. *) + val inside_set_of_closures_declaration : Set_of_closures_origin.t -> t -> bool + + (** Not inside a closure declaration. + Toplevel code is the one evaluated when the compilation unit is + loaded *) + val at_toplevel : t -> bool + + val is_inside_branch : t -> bool + val branch_depth : t -> int + val inside_branch : t -> t + + val increase_closure_depth : t -> t + + (** Mark that call sites contained within code rewritten using the given + environment should never be replaced by inlined (or unrolled) versions + of the callee(s). *) + val set_never_inline : t -> t + + (** Equivalent to [set_never_inline] but only applies to code inside + a set of closures. *) + val set_never_inline_inside_closures : t -> t + + (** Unset the restriction from [set_never_inline_inside_closures] *) + val unset_never_inline_inside_closures : t -> t + + (** Equivalent to [set_never_inline] but does not apply to code inside + a set of closures. *) + val set_never_inline_outside_closures : t -> t + + (** Unset the restriction from [set_never_inline_outside_closures] *) + val unset_never_inline_outside_closures : t -> t + + (** Return whether [set_never_inline] is currently in effect on the given + environment. *) + val never_inline : t -> bool + + val inlining_level : t -> int + + (** Mark that this environment is used to rewrite code for inlining. This is + used by the inlining heuristics to decide whether to continue. + Unconditionally inlined does not take this into account. *) + val inlining_level_up : t -> t + + (** Whether we are actively unrolling a given function. *) + val actively_unrolling : t -> Set_of_closures_origin.t -> int option + + (** Start actively unrolling a given function [n] times. *) + val start_actively_unrolling : t -> Set_of_closures_origin.t -> int -> t + + (** Unroll a function currently actively being unrolled. *) + val continue_actively_unrolling : t -> Set_of_closures_origin.t -> t + + (** Whether it is permissible to unroll a call to a recursive function + in the given environment. *) + val unrolling_allowed : t -> Set_of_closures_origin.t -> bool + + (** Whether the given environment is currently being used to rewrite the + body of an unrolled recursive function. *) + val inside_unrolled_function : t -> Set_of_closures_origin.t -> t + + (** Whether it is permissible to inline a call to a function in the given + environment. *) + val inlining_allowed : t -> Closure_origin.t -> bool + + (** Whether the given environment is currently being used to rewrite the + body of an inlined function. *) + val inside_inlined_function : t -> Closure_origin.t -> t + + (** If collecting inlining statistics, record that the inliner is about to + descend into [closure_id]. This information enables us to produce a + stack of closures that form a kind of context around an inlining + decision point. *) + val note_entering_closure + : t + -> closure_id:Closure_id.t + -> dbg:Debuginfo.t + -> t + + (** If collecting inlining statistics, record that the inliner is about to + descend into a call to [closure_id]. This information enables us to + produce a stack of closures that form a kind of context around an + inlining decision point. *) + val note_entering_call + : t + -> closure_id:Closure_id.t + -> dbg:Debuginfo.t + -> t + + (** If collecting inlining statistics, record that the inliner is about to + descend into an inlined function call. This requires that the inliner + has already entered the call with [note_entering_call]. *) + val note_entering_inlined : t -> t + + (** If collecting inlining statistics, record that the inliner is about to + descend into a specialised function definition. This requires that the + inliner has already entered the call with [note_entering_call]. *) + val note_entering_specialised : t -> closure_ids:Closure_id.Set.t -> t + + (** Update a given environment to record that the inliner is about to + descend into [closure_id] and pass the resulting environment to [f]. + If [inline_inside] is [false] then the environment passed to [f] will be + marked as [never_inline] (see above). *) + val enter_closure + : t + -> closure_id:Closure_id.t + -> inline_inside:bool + -> dbg:Debuginfo.t + -> f:(t -> 'a) + -> 'a + + (** If collecting inlining statistics, record an inlining decision for the + call at the top of the closure stack stored inside the given + environment. *) + val record_decision + : t + -> Inlining_stats_types.Decision.t + -> unit + + (** Print a human-readable version of the given environment. *) + val print : Format.formatter -> t -> unit + + (** The environment stores the call-site being inlined to produce + precise location information. This function sets the current + call-site being inlined. *) + val set_inline_debuginfo : t -> dbg:Debuginfo.t -> t + + (** Appends the locations of inlined call-sites to the [~dbg] argument *) + val add_inlined_debuginfo : t -> dbg:Debuginfo.t -> Debuginfo.t +end + +module Result : sig + (** Result structures approximately follow the evaluation order of the + program. They are returned by the simplification algorithm acting on + an Flambda subexpression. *) + type t + + val create : unit -> t + + (** The approximation of the subexpression that has just been + simplified. *) + val approx : t -> Simple_value_approx.t + + (** Set the approximation of the subexpression that has just been + simplified. Typically used just before returning from a case of the + simplification algorithm. *) + val set_approx : t -> Simple_value_approx.t -> t + + (** Set the approximation of the subexpression to the meet of the + current return approximation and the provided one. Typically + used just before returning from a branch case of the + simplification algorithm. *) + val meet_approx : t -> Env.t -> Simple_value_approx.t -> t + + (** All static exceptions for which [use_staticfail] has been called on + the given result structure. *) + val used_static_exceptions : t -> Static_exception.Set.t + + (** Mark that the given static exception has been used. *) + val use_static_exception : t -> Static_exception.t -> t + + (** Mark that we are moving up out of the scope of a static-catch block + that catches the given static exception identifier. This has the effect + of removing the identifier from the [used_staticfail] set. *) + val exit_scope_catch : t -> Static_exception.t -> t + + (** The benefit to be gained by inlining the subexpression whose + simplification yielded the given result structure. *) + val benefit : t -> Inlining_cost.Benefit.t + + (** Apply a transformation to the inlining benefit stored within the + given result structure. *) + val map_benefit + : t + -> (Inlining_cost.Benefit.t -> Inlining_cost.Benefit.t) + -> t + + (** Add some benefit to the inlining benefit stored within the + given result structure. *) + val add_benefit : t -> Inlining_cost.Benefit.t -> t + + (** Set the benefit of inlining the subexpression corresponding to the + given result structure to zero. *) + val reset_benefit : t -> t + + val set_inlining_threshold : + t -> Inlining_cost.Threshold.t option -> t + val add_inlining_threshold : + t -> Inlining_cost.Threshold.t -> t + val sub_inlining_threshold : + t -> Inlining_cost.Threshold.t -> t + val inlining_threshold : t -> Inlining_cost.Threshold.t option + + val seen_direct_application : t -> t + val num_direct_applications : t -> int +end + +(** Command line argument -inline *) +val initial_inlining_threshold : round:int -> Inlining_cost.Threshold.t + +(** Command line argument -inline-toplevel *) +val initial_inlining_toplevel_threshold + : round:int -> Inlining_cost.Threshold.t + +val prepare_to_simplify_set_of_closures + : env:Env.t + -> set_of_closures:Flambda.set_of_closures + -> function_decls:Flambda.function_declarations + -> freshen:bool + -> only_for_function_decl:Flambda.function_declaration option + -> (Flambda.specialised_to * Simple_value_approx.t) Variable.Map.t (* fvs *) + * Flambda.specialised_to Variable.Map.t (* specialised arguments *) + * Flambda.function_declarations + * Simple_value_approx.t Variable.Map.t (* parameter approximations *) + * Simple_value_approx.value_set_of_closures + * Env.t + +val prepare_to_simplify_closure + : function_decl:Flambda.function_declaration + -> free_vars:(Flambda.specialised_to * Simple_value_approx.t) Variable.Map.t + -> specialised_args:Flambda.specialised_to Variable.Map.t + -> parameter_approximations:Simple_value_approx.t Variable.Map.t + -> set_of_closures_env:Env.t + -> Env.t + +val keep_body_check + : is_classic_mode:bool + -> recursive:Variable.Set.t Lazy.t + -> Variable.t + -> Flambda.function_declaration + -> bool diff --git a/middle_end/flambda/inlining_cost.ml b/middle_end/flambda/inlining_cost.ml new file mode 100644 index 00000000..33e870f9 --- /dev/null +++ b/middle_end/flambda/inlining_cost.ml @@ -0,0 +1,700 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +(* Simple approximation of the space cost of a primitive. *) + +let prim_size (prim : Clambda_primitives.primitive) args = + match prim with + | Pmakeblock _ -> 5 + List.length args + | Pfield _ -> 1 + | Psetfield (_, isptr, init) -> + begin match init with + | Root_initialization -> 1 (* never causes a write barrier hit *) + | Assignment | Heap_initialization -> + match isptr with + | Pointer -> 4 + | Immediate -> 1 + end + | Pfloatfield _ -> 1 + | Psetfloatfield _ -> 1 + | Pduprecord _ -> 10 + List.length args + | Pccall p -> (if p.Primitive.prim_alloc then 10 else 4) + List.length args + | Praise _ -> 4 + | Pstringlength -> 5 + | Pbyteslength -> 5 + | Pstringrefs -> 6 + | Pbytesrefs | Pbytessets -> 6 + | Pmakearray _ -> 5 + List.length args + | Parraylength Pgenarray -> 6 + | Parraylength _ -> 2 + | Parrayrefu Pgenarray -> 12 + | Parrayrefu _ -> 2 + | Parraysetu Pgenarray -> 16 + | Parraysetu _ -> 4 + | Parrayrefs Pgenarray -> 18 + | Parrayrefs _ -> 8 + | Parraysets Pgenarray -> 22 + | Parraysets _ -> 10 + | Pbigarrayref (_, ndims, _, _) -> 4 + ndims * 6 + | Pbigarrayset (_, ndims, _, _) -> 4 + ndims * 6 + | Psequand | Psequor -> + Misc.fatal_error "Psequand and Psequor are not allowed in Prim \ + expressions; translate out instead (cf. closure_conversion.ml)" + (* CR-soon mshinwell: This match must be made exhaustive. + mshinwell: Let's do this when we have the new size computation. *) + | _ -> 2 (* arithmetic and comparisons *) + +(* Simple approximation of the space cost of an Flambda expression. *) + +(* CR-soon mshinwell: Investigate revised size numbers. *) + +let direct_call_size = 4 +let project_size = 1 + +let lambda_smaller' lam ~than:threshold = + let size = ref 0 in + let rec lambda_size (lam : Flambda.t) = + if !size > threshold then raise Exit; + match lam with + | Var _ -> () + | Apply ({ func = _; args = _; kind = direct }) -> + let call_cost = + match direct with Indirect -> 6 | Direct _ -> direct_call_size + in + size := !size + call_cost + | Assign _ -> incr size + | Send _ -> size := !size + 8 + | Proved_unreachable -> () + | Let { defining_expr; body; _ } -> + lambda_named_size defining_expr; + lambda_size body + | Let_mutable { body } -> lambda_size body + | Let_rec (bindings, body) -> + List.iter (fun (_, lam) -> lambda_named_size lam) bindings; + lambda_size body + | Switch (_, sw) -> + let aux = function _::_::_ -> size := !size + 5 | _ -> () in + aux sw.consts; aux sw.blocks; + List.iter (fun (_, lam) -> lambda_size lam) sw.consts; + List.iter (fun (_, lam) -> lambda_size lam) sw.blocks; + Option.iter lambda_size sw.failaction + | String_switch (_, sw, def) -> + List.iter (fun (_, lam) -> + size := !size + 2; + lambda_size lam) + sw; + Misc.may lambda_size def + | Static_raise _ -> () + | Static_catch (_, _, body, handler) -> + incr size; lambda_size body; lambda_size handler + | Try_with (body, _, handler) -> + size := !size + 8; lambda_size body; lambda_size handler + | If_then_else (_, ifso, ifnot) -> + size := !size + 2; + lambda_size ifso; lambda_size ifnot + | While (cond, body) -> + size := !size + 2; lambda_size cond; lambda_size body + | For { body; _ } -> + size := !size + 4; lambda_size body + and lambda_named_size (named : Flambda.named) = + if !size > threshold then raise Exit; + match named with + | Symbol _ | Read_mutable _ -> () + | Const _ | Allocated_const _ -> incr size + | Read_symbol_field _ -> incr size + | Set_of_closures ({ function_decls = ffuns }) -> + Variable.Map.iter (fun _ (ffun : Flambda.function_declaration) -> + lambda_size ffun.body) + ffuns.funs + | Project_closure _ | Project_var _ -> + size := !size + project_size + | Move_within_set_of_closures _ -> + incr size + | Prim (prim, args, _) -> + size := !size + prim_size prim args + | Expr expr -> lambda_size expr + in + try + lambda_size lam; + if !size <= threshold then Some !size + else None + with Exit -> + None + +let lambda_size lam = + match lambda_smaller' lam ~than:max_int with + | Some size -> + size + | None -> + (* There is no way that an expression of size max_int could fit in + memory. *) + assert false + +module Threshold = struct + + type t = + | Never_inline + | Can_inline_if_no_larger_than of int + + let add t1 t2 = + match t1, t2 with + | Never_inline, t -> t + | t, Never_inline -> t + | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> + Can_inline_if_no_larger_than (i1 + i2) + + let sub t1 t2 = + match t1, t2 with + | Never_inline, _ -> Never_inline + | t, Never_inline -> t + | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> + if i1 > i2 then Can_inline_if_no_larger_than (i1 - i2) + else Never_inline + + let min t1 t2 = + match t1, t2 with + | Never_inline, _ -> Never_inline + | _, Never_inline -> Never_inline + | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> + Can_inline_if_no_larger_than (min i1 i2) + + let equal t1 t2 = + match t1, t2 with + | Never_inline, Never_inline -> true + | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> + i1 = i2 + | (Never_inline | Can_inline_if_no_larger_than _), _ -> + false + +end + +let can_try_inlining lam inlining_threshold ~number_of_arguments + ~size_from_approximation = + match inlining_threshold with + | Threshold.Never_inline -> Threshold.Never_inline + | Threshold.Can_inline_if_no_larger_than inlining_threshold -> + let bonus = + (* removing a call will reduce the size by at least the number + of arguments *) + number_of_arguments + in + let size = + let than = inlining_threshold + bonus in + match size_from_approximation with + | Some size -> if size <= than then Some size else None + | None -> lambda_smaller' lam ~than + in + match size with + | None -> Threshold.Never_inline + | Some size -> + Threshold.Can_inline_if_no_larger_than + (inlining_threshold - size + bonus) + +let lambda_smaller lam ~than = + match lambda_smaller' lam ~than with + | Some _ -> true + | None -> false + +let can_inline lam inlining_threshold ~bonus = + match inlining_threshold with + | Threshold.Never_inline -> false + | Threshold.Can_inline_if_no_larger_than inlining_threshold -> + lambda_smaller + lam + ~than:(inlining_threshold + bonus) + +let cost (flag : Clflags.Int_arg_helper.parsed) ~round = + Clflags.Int_arg_helper.get ~key:round flag + +let benefit_factor = 1 + +module Benefit = struct + type t = { + remove_call : int; + remove_alloc : int; + remove_prim : int; + remove_branch : int; + (* CR-someday pchambart: branch_benefit : t list; *) + direct_call_of_indirect : int; + requested_inline : int; + (* Benefit to compensate the size of functions marked for inlining *) + } + + let zero = { + remove_call = 0; + remove_alloc = 0; + remove_prim = 0; + remove_branch = 0; + direct_call_of_indirect = 0; + requested_inline = 0; + } + + let remove_call t = { t with remove_call = t.remove_call + 1; } + let remove_alloc t = { t with remove_alloc = t.remove_alloc + 1; } + let remove_prim t = { t with remove_prim = t.remove_prim + 1; } + let remove_prims t n = { t with remove_prim = t.remove_prim + n; } + let remove_branch t = { t with remove_branch = t.remove_branch + 1; } + let direct_call_of_indirect t = + { t with direct_call_of_indirect = t.direct_call_of_indirect + 1; } + let requested_inline t ~size_of = + let size = lambda_size size_of in + { t with requested_inline = t.requested_inline + size; } + + let remove_code_helper b (flam : Flambda.t) = + match flam with + | Assign _ -> b := remove_prim !b + | Switch _ | String_switch _ | Static_raise _ | Try_with _ + | If_then_else _ | While _ | For _ -> b := remove_branch !b + | Apply _ | Send _ -> b := remove_call !b + | Let _ | Let_mutable _ | Let_rec _ | Proved_unreachable | Var _ + | Static_catch _ -> () + + let remove_code_helper_named b (named : Flambda.named) = + match named with + | Set_of_closures _ + | Prim ((Pmakearray _ | Pmakeblock _ | Pduprecord _), _, _) -> + b := remove_alloc !b + (* CR-soon pchambart: should we consider that boxed integer and float + operations are allocations ? *) + | Prim _ | Project_closure _ | Project_var _ + | Move_within_set_of_closures _ + | Read_symbol_field _ -> b := remove_prim !b + | Symbol _ | Read_mutable _ | Allocated_const _ | Const _ | Expr _ -> () + + let remove_code lam b = + let b = ref b in + Flambda_iterators.iter_toplevel (remove_code_helper b) + (remove_code_helper_named b) lam; + !b + + let remove_code_named lam b = + let b = ref b in + Flambda_iterators.iter_named_toplevel (remove_code_helper b) + (remove_code_helper_named b) lam; + !b + + let remove_projection (_proj : Projection.t) b = + (* They are all primitives for the moment. The [Projection.t] argument + is here for future expansion. *) + remove_prim b + + let print ppf b = + Format.fprintf ppf "@[remove_call: %i@ remove_alloc: %i@ \ + remove_prim: %i@ remove_branch: %i@ \ + direct: %i@ requested: %i@]" + b.remove_call + b.remove_alloc + b.remove_prim + b.remove_branch + b.direct_call_of_indirect + b.requested_inline + + let evaluate t ~round : int = + benefit_factor * + (t.remove_call * (cost !Clflags.inline_call_cost ~round) + + t.remove_alloc * (cost !Clflags.inline_alloc_cost ~round) + + t.remove_prim * (cost !Clflags.inline_prim_cost ~round) + + t.remove_branch * (cost !Clflags.inline_branch_cost ~round) + + (t.direct_call_of_indirect + * (cost !Clflags.inline_indirect_cost ~round))) + + t.requested_inline + + let (+) t1 t2 = { + remove_call = t1.remove_call + t2.remove_call; + remove_alloc = t1.remove_alloc + t2.remove_alloc; + remove_prim = t1.remove_prim + t2.remove_prim; + remove_branch = t1.remove_branch + t2.remove_branch; + direct_call_of_indirect = + t1.direct_call_of_indirect + t2.direct_call_of_indirect; + requested_inline = t1.requested_inline + t2.requested_inline; + } + + let (-) t1 t2 = { + remove_call = t1.remove_call - t2.remove_call; + remove_alloc = t1.remove_alloc - t2.remove_alloc; + remove_prim = t1.remove_prim - t2.remove_prim; + remove_branch = t1.remove_branch - t2.remove_branch; + direct_call_of_indirect = + t1.direct_call_of_indirect - t2.direct_call_of_indirect; + requested_inline = t1.requested_inline - t2.requested_inline; + } + + let max ~round t1 t2 = + let c1 = evaluate ~round t1 in + let c2 = evaluate ~round t2 in + if c1 > c2 then t1 else t2 + + let add_code lam b = + b - (remove_code lam zero) + + let add_code_named lam b = + b - (remove_code_named lam zero) + + let add_projection proj b = + b - (remove_projection proj zero) + + (* Print out a benefit as a table *) + + let benefit_table = + [ "Calls", (fun b -> b.remove_call); + "Allocs", (fun b -> b.remove_alloc); + "Prims", (fun b -> b.remove_prim); + "Branches", (fun b -> b.remove_branch); + "Indirect calls", (fun b -> b.direct_call_of_indirect); + ] + + let benefits_table = + lazy begin + List.map + (fun (header, accessor) -> (header, accessor, String.length header)) + benefit_table + end + + let table_line = + lazy begin + let benefits_table = Lazy.force benefits_table in + let dashes = + List.map (fun (_, _, n) -> String.make n '-') benefits_table + in + "|-" ^ String.concat "-+-" dashes ^ "-|" + end + + let table_headers = + lazy begin + let benefits_table = Lazy.force benefits_table in + let headers = List.map (fun (head, _, _) -> head) benefits_table in + "| " ^ String.concat " | " headers ^ " |" + end + + let print_table_values ppf b = + let rec loop ppf = function + | [] -> Format.fprintf ppf "|" + | (_, accessor, width) :: rest -> + Format.fprintf ppf "| %*d %a" width (accessor b) loop rest + in + loop ppf (Lazy.force benefits_table) + + let print_table ppf b = + let table_line = Lazy.force table_line in + let table_headers = Lazy.force table_headers in + Format.fprintf ppf + "@[@[%s@]@;@[%s@]@;@[%s@]@;@[%a@]@;@[%s@]@]" + table_line table_headers table_line + print_table_values b + table_line +end + +module Whether_sufficient_benefit = struct + type t = { + round : int; + benefit : Benefit.t; + toplevel : bool; + branch_depth : int; + lifting : bool; + original_size : int; + new_size : int; + evaluated_benefit : int; + estimate : bool; + } + + let create ~original ~toplevel ~branch_depth lam ~benefit ~lifting ~round = + let evaluated_benefit = Benefit.evaluate benefit ~round in + { round; benefit; toplevel; branch_depth; lifting; + original_size = lambda_size original; + new_size = lambda_size lam; + evaluated_benefit; + estimate = false; + } + + let create_estimate ~original_size ~toplevel ~branch_depth ~new_size + ~benefit ~lifting ~round = + let evaluated_benefit = Benefit.evaluate benefit ~round in + { round; benefit; toplevel; branch_depth; lifting; original_size; + new_size; evaluated_benefit; estimate = true; + } + + let is_nan f = + match Float.classify_float f with + | FP_nan -> true + | FP_normal | FP_subnormal | FP_zero | FP_infinite -> false + + let correct_branch_factor f = + (not (is_nan f)) + && (Float.compare f 0. >= 0) + + let estimated_benefit t = + if t.toplevel && t.lifting && t.branch_depth = 0 then begin + let lifting_benefit = + Clflags.Int_arg_helper.get ~key:t.round !Clflags.inline_lifting_benefit + in + float (t.evaluated_benefit + lifting_benefit) + end else begin + (* The estimated benefit is the evaluated benefit times an + estimation of the probability that the branch does actually matter + for performance (i.e. is hot). The probability is very roughly + estimated by considering that under every branch the + sub-expressions have the same [1 / (1 + factor)] probability + [p] of being hot. Hence the probability for the current + call to be hot is [p ^ number of nested branches]. + The probability is expressed as [1 / (1 + factor)] rather + than letting the user directly provide [p], since for every + positive value of [factor] [p] is in [0, 1]. *) + let branch_taken_estimated_probability = + let inline_branch_factor = + let factor = + Clflags.Float_arg_helper.get ~key:t.round + !Clflags.inline_branch_factor + in + if is_nan factor then + Clflags.default_inline_branch_factor + else if Float.compare factor 0. < 0 then + 0. + else + factor + in + assert (correct_branch_factor inline_branch_factor); + 1. /. (1. +. inline_branch_factor) + in + let call_estimated_probability = + branch_taken_estimated_probability ** float t.branch_depth + in + float t.evaluated_benefit *. call_estimated_probability + end + + let evaluate t = + Float.compare + (float t.new_size -. estimated_benefit t) + (float t.original_size) <= 0 + + let to_string t = + let lifting = t.toplevel && t.lifting && t.branch_depth = 0 in + let evaluated_benefit = + if lifting then + let lifting_benefit = + Clflags.Int_arg_helper.get ~key:t.round + !Clflags.inline_lifting_benefit + in + t.evaluated_benefit + lifting_benefit + else t.evaluated_benefit + in + let estimate = if t.estimate then "<" else "=" in + Printf.sprintf "{benefit%s{call=%d,alloc=%d,prim=%i,branch=%i,\ + indirect=%i,req=%i,\ + lifting=%B}, orig_size=%d,new_size=%d,eval_size=%d,\ + eval_benefit%s%d,\ + branch_depth=%d}=%s" + estimate + t.benefit.remove_call + t.benefit.remove_alloc + t.benefit.remove_prim + t.benefit.remove_branch + t.benefit.direct_call_of_indirect + t.benefit.requested_inline + lifting + t.original_size + t.new_size + (t.original_size - t.new_size) + estimate + evaluated_benefit + t.branch_depth + (if evaluate t then "yes" else "no") + + let print_description ~subfunctions ppf t = + let pr_intro ppf = + let estimate = if t.estimate then " at most" else "" in + Format.pp_print_text ppf + "Specialisation of the function body"; + if subfunctions then + Format.pp_print_text ppf + ", including speculative inlining of other functions,"; + Format.pp_print_text ppf " removed"; + Format.pp_print_text ppf estimate; + Format.pp_print_text ppf " the following operations:" + in + let lifting = t.toplevel && t.lifting && t.branch_depth = 0 in + let requested = t.benefit.requested_inline in + let pr_requested ppf = + if requested > 0 then begin + Format.pp_open_box ppf 0; + Format.pp_print_text ppf + "and inlined user-annotated functions worth "; + Format.fprintf ppf "%d." requested; + Format.pp_close_box ppf (); + Format.pp_print_cut ppf (); + Format.pp_print_cut ppf () + end + in + let pr_lifting ppf = + if lifting then begin + Format.pp_open_box ppf 0; + Format.pp_print_text ppf + "Inlining the function would also \ + lift some definitions to toplevel."; + Format.pp_close_box ppf (); + Format.pp_print_cut ppf (); + Format.pp_print_cut ppf () + end + in + let total_benefit = + if lifting then + let lifting_benefit = + Clflags.Int_arg_helper.get ~key:t.round + !Clflags.inline_lifting_benefit + in + t.evaluated_benefit + lifting_benefit + else t.evaluated_benefit + in + let expected_benefit = estimated_benefit t in + let size_change = t.new_size - t.original_size in + let result = if evaluate t then "less" else "greater" in + let pr_conclusion ppf = + Format.pp_print_text ppf "This gives a total benefit of "; + Format.pp_print_int ppf total_benefit; + Format.pp_print_text ppf ". At a branch depth of "; + Format.pp_print_int ppf t.branch_depth; + Format.pp_print_text ppf " this produces an expected benefit of "; + Format.fprintf ppf "%.1f" expected_benefit; + Format.pp_print_text ppf ". The new code has size "; + Format.pp_print_int ppf t.new_size; + Format.pp_print_text ppf ", giving a change in code size of "; + Format.pp_print_int ppf size_change; + Format.pp_print_text ppf ". The change in code size is "; + Format.pp_print_text ppf result; + Format.pp_print_text ppf " than the expected benefit." + in + Format.fprintf ppf "%t@,@[@[@;%a@]@;@;%t%t@]%t" + pr_intro Benefit.print_table t.benefit pr_requested pr_lifting + pr_conclusion +end + +let scale_inline_threshold_by = 8 + +let default_toplevel_multiplier = 8 + + (* CR-soon mshinwell for mshinwell: hastily-written comment, to review *) + (* We may in [Inlining_decision] need to measure the size of functions + that are below the inlining threshold. We also need to measure with + regard to benefit (see [Inlining_decision.inline_non_recursive). The + intuition for having a cached size in the second case is as follows. + If a function's body exceeds some maximum size and its argument + approximations are unknown (meaning that we cannot materially simplify + it further), we can infer without examining the function's body that + it cannot be inlined. The aim is to speed up [Inlining_decision]. + + The "original size" is [Inlining_cost.direct_call_size]. The "new size" is + the size of the function's body plus [Inlining_cost.project_size] for each + free variable and mutually recursive function accessed through the closure. + + To be inlined we need: + + body_size + + (closure_accesses * project_size) <= direct_call_size + - (evaluated_benefit * call_prob) + + i.e.: + + body_size <= direct_call_size + + (evaluated_benefit * call_prob) + - (closure_accesses * project_size) + + In this case we would be removing a single call and a projection for each + free variable that can be accessed directly (i.e. not via the closure + or the internal variable). + + evaluated_benefit = + benefit_factor + * (inline_call_cost + + ((free_variables - indirect_accesses) * inline_prim_cost)) + + (For [inline_call_cost] and [inline_prim_cost], we use the maximum these + might be across any round.) + + Substituting: + + body_size <= direct_call_size + + (benefit_factor + * (inline_call_cost + + ((free_variables - indirect_accesses) + * inline_prim_cost))) + * call_prob + - (closure_accesses * project_size) + + Rearranging: + + body_size <= direct_call_size + + (inline_call_cost * benefit_factor * call_prob) + + (free_variables * inline_prim_cost + * benefit_factor * call_prob) + - (indirect_accesses * inline_prim_cost + * benefit_factor * call_prob) + - (closure_accesses * project_size) + + The upper bound for the right-hand side is when call_prob = 1.0, + indirect_accesses = 0 and closure_accesses = 0, giving: + + direct_call_size + + (inline_call_cost * benefit_factor) + + (free_variables * inline_prim_cost * benefit_factor) + + So we should measure all functions at or below this size, but also record + the size discovered, so we can later re-check (without examining the body) + when we know [call_prob], [indirect_accesses] and [closure_accesses]. + + This number is split into parts dependent and independent of the + number of free variables: + + base = direct_call_size + (inline_call_cost * benefit_factor) + + multiplier = inline_prim_cost * benefit_factor + + body_size <= base + free_variables * multiplier + + *) +let maximum_interesting_size_of_function_body_base = + lazy begin + let max_cost = ref 0 in + for round = 0 to (Clflags.rounds ()) - 1 do + let max_size = + let inline_call_cost = cost !Clflags.inline_call_cost ~round in + direct_call_size + (inline_call_cost * benefit_factor) + in + max_cost := max !max_cost max_size + done; + !max_cost + end + +let maximum_interesting_size_of_function_body_multiplier = + lazy begin + let max_cost = ref 0 in + for round = 0 to (Clflags.rounds ()) - 1 do + let max_size = + let inline_prim_cost = cost !Clflags.inline_prim_cost ~round in + inline_prim_cost * benefit_factor + in + max_cost := max !max_cost max_size + done; + !max_cost + end + +let maximum_interesting_size_of_function_body num_free_variables = + let base = Lazy.force maximum_interesting_size_of_function_body_base in + let multiplier = + Lazy.force maximum_interesting_size_of_function_body_multiplier + in + base + (num_free_variables * multiplier) diff --git a/middle_end/flambda/inlining_cost.mli b/middle_end/flambda/inlining_cost.mli new file mode 100644 index 00000000..345f67ab --- /dev/null +++ b/middle_end/flambda/inlining_cost.mli @@ -0,0 +1,142 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Measurement of the cost (including cost in space) of Flambda terms + in the context of inlining. *) + +module Threshold : sig + + (** The maximum size, in some abstract measure of space cost, that an + Flambda expression may be in order to be inlined. *) + type t = + | Never_inline + | Can_inline_if_no_larger_than of int + + val add : t -> t -> t + val sub : t -> t -> t + val min : t -> t -> t + val equal : t -> t -> bool + +end + +(* Determine whether the given Flambda expression has a sufficiently low space + cost so as to fit under the given [inlining_threshold]. The [bonus] is + added to the threshold before evaluation. *) +val can_inline + : Flambda.t + -> Threshold.t + -> bonus:int + -> bool + +(* CR-soon mshinwell for pchambart: I think the name of this function might be + misleading. It should probably reflect the functionality it provides, + not the use to which it is put in another module. *) +(* As for [can_inline], but returns the decision as an inlining threshold. + If [Never_inline] is returned, the expression was too large for the + input [inlining_threshold]. Otherwise, [Can_inline_if_no_larger_than] is + returned, with the constructor argument being the measured estimated size + of the expression. *) +val can_try_inlining + : Flambda.t + -> Threshold.t + -> number_of_arguments:int + -> size_from_approximation:int option + -> Threshold.t + +module Benefit : sig + (* A model of the benefit we gain by removing a particular combination + of operations. Such removals are typically performed by inlining (for + example, [remove_call]) and simplification (for example, [remove_alloc]) + passes. *) + + type t + + val zero : t + val (+) : t -> t -> t + val max : round:int -> t -> t -> t + + val remove_call : t -> t + (* CR-soon mshinwell: [remove_alloc] should take the size of the block + (to account for removal of initializing writes). *) + val remove_alloc : t -> t + val remove_prim : t -> t + val remove_prims : t -> int -> t + val remove_branch : t -> t + val direct_call_of_indirect : t -> t + val requested_inline : t -> size_of:Flambda.t -> t + + val remove_code : Flambda.t -> t -> t + val remove_code_named : Flambda.named -> t -> t + val remove_projection : Projection.t -> t -> t + + val add_code : Flambda.t -> t -> t + val add_code_named : Flambda.named -> t -> t + val add_projection : Projection.t -> t -> t + + val print : Format.formatter -> t -> unit +end + +module Whether_sufficient_benefit : sig + (* Evaluation of the benefit of removing certain operations against an + inlining threshold. *) + + type t + + val create + : original:Flambda.t + -> toplevel:bool + -> branch_depth:int + -> Flambda.t + -> benefit:Benefit.t + -> lifting:bool + -> round:int + -> t + + val create_estimate + : original_size:int + -> toplevel:bool + -> branch_depth: int + -> new_size:int + -> benefit:Benefit.t + -> lifting:bool + -> round:int + -> t + + val evaluate : t -> bool + + val to_string : t -> string + + val print_description : subfunctions:bool -> Format.formatter -> t -> unit +end + +val scale_inline_threshold_by : int + +val default_toplevel_multiplier : int + +val direct_call_size : int + +(** If a function body exceeds this size, we can make a fast decision not + to inline it (see [Inlining_decision]). *) +val maximum_interesting_size_of_function_body : int -> int + +(** Measure the given expression to determine whether its size is at or + below the given threshold. [None] is returned if it is too big; otherwise + [Some] is returned with the measured size. *) +val lambda_smaller' : Flambda.expr -> than:int -> int option + +val lambda_size : Flambda.expr -> int diff --git a/middle_end/flambda/inlining_decision.ml b/middle_end/flambda/inlining_decision.ml new file mode 100644 index 00000000..ca462a56 --- /dev/null +++ b/middle_end/flambda/inlining_decision.ml @@ -0,0 +1,741 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module A = Simple_value_approx +module E = Inline_and_simplify_aux.Env +module R = Inline_and_simplify_aux.Result +module W = Inlining_cost.Whether_sufficient_benefit +module T = Inlining_cost.Threshold +module S = Inlining_stats_types +module D = S.Decision + +let get_function_body (function_decl : A.function_declaration) = + match function_decl.function_body with + | None -> assert false + | Some function_body -> function_body + +type ('a, 'b) inlining_result = + | Changed of (Flambda.t * R.t) * 'a + | Original of 'b + +type 'b good_idea = + | Try_it + | Don't_try_it of 'b + +let inline env r ~lhs_of_application + ~closure_id_being_applied + ~(function_decl : A.function_declaration) + ~(function_body : A.function_body) + ~value_set_of_closures ~only_use_of_function ~original ~recursive + ~(args : Variable.t list) ~size_from_approximation ~dbg ~simplify + ~(inline_requested : Lambda.inline_attribute) + ~(specialise_requested : Lambda.specialise_attribute) + ~fun_vars ~set_of_closures_origin + ~self_call ~fun_cost ~inlining_threshold = + let toplevel = E.at_toplevel env in + let branch_depth = E.branch_depth env in + let unrolling, always_inline, never_inline, env = + let unrolling = E.actively_unrolling env set_of_closures_origin in + match unrolling with + | Some count -> + if count > 0 then + let env = E.continue_actively_unrolling env set_of_closures_origin in + true, true, false, env + else false, false, true, env + | None -> begin + let inline_annotation = + (* Merge call site annotation and function annotation. + The call site annotation takes precedence *) + match (inline_requested : Lambda.inline_attribute) with + | Always_inline | Never_inline | Unroll _ -> inline_requested + | Default_inline -> function_body.inline + in + match inline_annotation with + | Always_inline -> false, true, false, env + | Never_inline -> false, false, true, env + | Default_inline -> false, false, false, env + | Unroll count -> + if count > 0 then + let env = + E.start_actively_unrolling + env set_of_closures_origin (count - 1) + in + true, true, false, env + else false, false, true, env + end + in + let remaining_inlining_threshold : Inlining_cost.Threshold.t = + if always_inline then inlining_threshold + else Lazy.force fun_cost + in + let try_inlining = + if unrolling then + Try_it + else if self_call then + Don't_try_it S.Not_inlined.Self_call + else if not (E.inlining_allowed env function_decl.closure_origin) then + Don't_try_it S.Not_inlined.Unrolling_depth_exceeded + else if only_use_of_function || always_inline then + Try_it + else if never_inline then + Don't_try_it S.Not_inlined.Annotation + else if not (E.unrolling_allowed env set_of_closures_origin) + && (Lazy.force recursive) then + Don't_try_it S.Not_inlined.Unrolling_depth_exceeded + else if T.equal remaining_inlining_threshold T.Never_inline then + let threshold = + match inlining_threshold with + | T.Never_inline -> assert false + | T.Can_inline_if_no_larger_than threshold -> threshold + in + Don't_try_it (S.Not_inlined.Above_threshold threshold) + else if not (toplevel && branch_depth = 0) + && A.all_not_useful (E.find_list_exn env args) then + (* When all of the arguments to the function being inlined are unknown, + then we cannot materially simplify the function. As such, we know + what the benefit of inlining it would be: just removing the call. + In this case we may be able to prove the function cannot be inlined + without traversing its body. + Note that if the function is sufficiently small, we still have to call + [simplify], because the body needs freshening before substitution. + *) + (* CR-someday mshinwell: (from GPR#8): pchambart writes: + + We may need to think a bit about that. I can't see a lot of + meaningful examples right now, but there are some cases where some + optimization can happen even if we don't know anything about the + shape of the arguments. + + For instance + + let f x y = x + + let g x = + let y = (x,x) in + f x y + let f x y = + if x = y then ... else ... + + let g x = f x x + *) + match size_from_approximation with + | Some body_size -> + let wsb = + let benefit = Inlining_cost.Benefit.zero in + let benefit = Inlining_cost.Benefit.remove_call benefit in + let benefit = + Variable.Set.fold (fun v acc -> + try + let t = + Var_within_closure.Map.find (Var_within_closure.wrap v) + value_set_of_closures.A.bound_vars + in + match t.A.var with + | Some v -> + if (E.mem env v) then Inlining_cost.Benefit.remove_prim acc + else acc + | None -> acc + with Not_found -> acc) + function_body.free_variables benefit + in + W.create_estimate + ~original_size:Inlining_cost.direct_call_size + ~new_size:body_size + ~toplevel:(E.at_toplevel env) + ~branch_depth:(E.branch_depth env) + ~lifting:function_body.A.is_a_functor + ~round:(E.round env) + ~benefit + in + if (not (W.evaluate wsb)) then begin + Don't_try_it + (S.Not_inlined.Without_subfunctions wsb) + end else Try_it + | None -> + (* The function is definitely too large to inline given that we don't + have any approximations for its arguments. Further, the body + should already have been simplified (inside its declaration), so + we also expect no gain from the code below that permits inlining + inside the body. *) + Don't_try_it S.Not_inlined.No_useful_approximations + else begin + (* There are useful approximations, so we should simplify. *) + Try_it + end + in + match try_inlining with + | Don't_try_it decision -> Original decision + | Try_it -> + let r = + R.set_inlining_threshold r (Some remaining_inlining_threshold) + in + let body, r_inlined = + (* First we construct the code that would result from copying the body of + the function, without doing any further inlining upon it, to the call + site. *) + Inlining_transforms.inline_by_copying_function_body ~env + ~r:(R.reset_benefit r) ~lhs_of_application + ~closure_id_being_applied ~specialise_requested ~inline_requested + ~function_decl ~function_body ~fun_vars ~args ~dbg ~simplify + in + let num_direct_applications_seen = + (R.num_direct_applications r_inlined) - (R.num_direct_applications r) + in + assert (num_direct_applications_seen >= 0); + let keep_inlined_version decision = + (* Inlining the body of the function was sufficiently beneficial that we + will keep it, replacing the call site. We continue by allowing + further inlining within the inlined copy of the body. *) + let r_inlined = + (* The meaning of requesting inlining is that the user ensure + that the function has a benefit of at least its size. It is not + added to the benefit exposed by the inlining because the user should + have taken that into account before annotating the function. *) + if always_inline then + R.map_benefit r_inlined + (Inlining_cost.Benefit.max ~round:(E.round env) + Inlining_cost.Benefit.(requested_inline ~size_of:body zero)) + else r_inlined + in + let r = + R.map_benefit r_inlined (Inlining_cost.Benefit.(+) (R.benefit r)) + in + let env = E.note_entering_inlined env in + let env = + (* We decrement the unrolling count even if the function is not + recursive to avoid having to check whether or not it is recursive *) + E.inside_unrolled_function env set_of_closures_origin + in + let env = E.inside_inlined_function env function_decl.closure_origin in + let env = + if E.inlining_level env = 0 + (* If the function was considered for inlining without considering + its sub-functions, and it is not below another inlining choice, + then we are certain that this code will be kept. *) + then env + else E.inlining_level_up env + in + Changed ((simplify env r body), decision) + in + if always_inline then + keep_inlined_version S.Inlined.Annotation + else if only_use_of_function then + keep_inlined_version S.Inlined.Decl_local_to_application + else begin + let wsb = + W.create ~original body + ~toplevel:(E.at_toplevel env) + ~branch_depth:(E.branch_depth env) + ~lifting:function_body.is_a_functor + ~round:(E.round env) + ~benefit:(R.benefit r_inlined) + in + if W.evaluate wsb then + keep_inlined_version (S.Inlined.Without_subfunctions wsb) + else if num_direct_applications_seen < 1 then begin + (* Inlining the body of the function did not appear sufficiently + beneficial; however, it may become so if we inline within the body + first. We try that next, unless it is known that there were + no direct applications in the simplified body computed above, meaning + no opportunities for inlining. *) + Original (S.Not_inlined.Without_subfunctions wsb) + end else begin + let env = E.inlining_level_up env in + let env = E.note_entering_inlined env in + let env = + (* We decrement the unrolling count even if the function is recursive + to avoid having to check whether or not it is recursive *) + E.inside_unrolled_function env set_of_closures_origin + in + let body, r_inlined = simplify env r_inlined body in + let wsb_with_subfunctions = + W.create ~original body + ~toplevel:(E.at_toplevel env) + ~branch_depth:(E.branch_depth env) + ~lifting:function_body.is_a_functor + ~round:(E.round env) + ~benefit:(R.benefit r_inlined) + in + if W.evaluate wsb_with_subfunctions then begin + let res = + (body, R.map_benefit r_inlined + (Inlining_cost.Benefit.(+) (R.benefit r))) + in + let decision = + S.Inlined.With_subfunctions (wsb, wsb_with_subfunctions) + in + Changed (res, decision) + end + else begin + (* r_inlined contains an approximation that may be invalid for the + untransformed expression: it may reference functions that only + exists if the body of the function is in fact inlined. + If the function approximation contained an approximation that + does not depend on the actual values of its arguments, it + could be returned instead of [A.value_unknown]. *) + let decision = + S.Not_inlined.With_subfunctions (wsb, wsb_with_subfunctions) + in + Original decision + end + end + end + +let specialise env r ~lhs_of_application + ~(function_decls : A.function_declarations) + ~(function_decl : A.function_declaration) + ~closure_id_being_applied + ~(value_set_of_closures : A.value_set_of_closures) + ~args ~args_approxs ~dbg ~simplify ~original ~recursive ~self_call + ~inlining_threshold ~fun_cost + ~inline_requested ~specialise_requested = + let invariant_params = value_set_of_closures.invariant_params in + let free_vars = value_set_of_closures.free_vars in + let has_no_useful_approxes = + lazy + (List.for_all2 + (fun id approx -> + not ((A.useful approx) + && Variable.Map.mem id (Lazy.force invariant_params))) + (Parameter.List.vars function_decl.params) args_approxs) + in + let always_specialise, never_specialise = + (* Merge call site annotation and function annotation. + The call site annotation takes precedence *) + match (specialise_requested : Lambda.specialise_attribute) with + | Always_specialise -> true, false + | Never_specialise -> false, true + | Default_specialise -> begin + match function_decl.function_body with + | None -> false, true + | Some { specialise } -> + match (specialise : Lambda.specialise_attribute) with + | Always_specialise -> true, false + | Never_specialise -> false, true + | Default_specialise -> false, false + end + in + let remaining_inlining_threshold : Inlining_cost.Threshold.t = + if always_specialise then inlining_threshold + else Lazy.force fun_cost + in + let try_specialising = + (* Try specialising if the function: + - is recursive; and + - is closed (it and all other members of the set of closures on which + it depends); and + - has useful approximations for some invariant parameters. *) + if function_decls.is_classic_mode then + Don't_try_it S.Not_specialised.Classic_mode + else if self_call then + Don't_try_it S.Not_specialised.Self_call + else if always_specialise && not (Lazy.force has_no_useful_approxes) then + Try_it + else if never_specialise then + Don't_try_it S.Not_specialised.Annotation + else if T.equal remaining_inlining_threshold T.Never_inline then + let threshold = + match inlining_threshold with + | T.Never_inline -> assert false + | T.Can_inline_if_no_larger_than threshold -> threshold + in + Don't_try_it (S.Not_specialised.Above_threshold threshold) + else if not (Variable.Map.is_empty free_vars) then + Don't_try_it S.Not_specialised.Not_closed + else if not (Lazy.force recursive) then + Don't_try_it S.Not_specialised.Not_recursive + else if Variable.Map.is_empty (Lazy.force invariant_params) then + Don't_try_it S.Not_specialised.No_invariant_parameters + else if Lazy.force has_no_useful_approxes then + Don't_try_it S.Not_specialised.No_useful_approximations + else Try_it + in + match try_specialising with + | Don't_try_it decision -> Original decision + | Try_it -> begin + let r = + R.set_inlining_threshold r (Some remaining_inlining_threshold) + in + let copied_function_declaration = + Inlining_transforms.inline_by_copying_function_declaration ~env + ~r:(R.reset_benefit r) ~lhs_of_application + ~function_decls ~closure_id_being_applied ~function_decl + ~args ~args_approxs + ~invariant_params:invariant_params + ~specialised_args:value_set_of_closures.specialised_args + ~free_vars:value_set_of_closures.free_vars + ~direct_call_surrogates:value_set_of_closures.direct_call_surrogates + ~dbg ~simplify ~inline_requested + in + match copied_function_declaration with + | Some (expr, r_inlined) -> + let wsb = + W.create ~original expr + ~toplevel:false + ~branch_depth:(E.branch_depth env) + ~lifting:false + ~round:(E.round env) + ~benefit:(R.benefit r_inlined) + in + let env = + (* CR-someday lwhite: could avoid calculating this if stats is turned + off *) + let closure_ids = + Closure_id.Set.of_list ( + List.map Closure_id.wrap + (Variable.Set.elements (Variable.Map.keys function_decls.funs))) + in + E.note_entering_specialised env ~closure_ids + in + if always_specialise || W.evaluate wsb then begin + let r_inlined = + if always_specialise then + R.map_benefit r_inlined + (Inlining_cost.Benefit.max ~round:(E.round env) + Inlining_cost.Benefit.(requested_inline ~size_of:expr zero)) + else r_inlined + in + let r = + R.map_benefit r_inlined (Inlining_cost.Benefit.(+) (R.benefit r)) + in + let closure_env = + let env = + if E.inlining_level env = 0 + (* If the function was considered for specialising without + considering its sub-functions, and it is not below another + inlining choice, then we are certain that this code will + be kept. *) + then env + else E.inlining_level_up env + in + E.set_never_inline_outside_closures env + in + let application_env = E.set_never_inline_inside_closures env in + let expr, r = simplify closure_env r expr in + let res = simplify application_env r expr in + let decision = + if always_specialise then S.Specialised.Annotation + else S.Specialised.Without_subfunctions wsb + in + Changed (res, decision) + end else begin + let closure_env = + let env = E.inlining_level_up env in + E.set_never_inline_outside_closures env + in + let expr, r_inlined = simplify closure_env r_inlined expr in + let wsb_with_subfunctions = + W.create ~original expr + ~toplevel:false + ~branch_depth:(E.branch_depth env) + ~lifting:false + ~round:(E.round env) + ~benefit:(R.benefit r_inlined) + in + if W.evaluate wsb_with_subfunctions then begin + let r = + R.map_benefit r_inlined + (Inlining_cost.Benefit.(+) (R.benefit r)) + in + let application_env = E.set_never_inline_inside_closures env in + let res = simplify application_env r expr in + let decision = + S.Specialised.With_subfunctions (wsb, wsb_with_subfunctions) + in + Changed (res, decision) + end else begin + let decision = + S.Not_specialised.Not_beneficial (wsb, wsb_with_subfunctions) + in + Original decision + end + end + | None -> + let decision = S.Not_specialised.No_useful_approximations in + Original decision + end + +let for_call_site ~env ~r ~(function_decls : A.function_declarations) + ~lhs_of_application ~closure_id_being_applied + ~(function_decl : A.function_declaration) + ~(value_set_of_closures : A.value_set_of_closures) + ~args ~args_approxs ~dbg ~simplify ~inline_requested + ~specialise_requested = + if List.length args <> List.length args_approxs then begin + Misc.fatal_error "Inlining_decision.for_call_site: inconsistent lengths \ + of [args] and [args_approxs]" + end; + (* Remove unroll attributes from functions we are already actively + unrolling, otherwise they'll be unrolled again next round. *) + let inline_requested : Lambda.inline_attribute = + match (inline_requested : Lambda.inline_attribute) with + | Unroll _ -> begin + let unrolling = + E.actively_unrolling env function_decls.set_of_closures_origin + in + match unrolling with + | Some _ -> Default_inline + | None -> inline_requested + end + | Always_inline | Default_inline | Never_inline -> + inline_requested + in + let original = + Flambda.Apply { + func = lhs_of_application; + args; + kind = Direct closure_id_being_applied; + dbg; + inline = inline_requested; + specialise = specialise_requested; + } + in + let original_r = + R.set_approx (R.seen_direct_application r) (A.value_unknown Other) + in + match function_decl.function_body with + | None -> original, original_r + | Some { stub; _ } -> + if stub then begin + let fun_vars = Variable.Map.keys function_decls.funs in + let function_body = get_function_body function_decl in + let body, r = + Inlining_transforms.inline_by_copying_function_body ~env + ~r ~fun_vars ~lhs_of_application + ~closure_id_being_applied ~specialise_requested ~inline_requested + ~function_decl ~function_body ~args ~dbg ~simplify + in + simplify env r body + end else if E.never_inline env then + (* This case only occurs when examining the body of a stub function + but not in the context of inlining said function. As such, there + is nothing to do here (and no decision to report). *) + original, original_r + else if function_decls.is_classic_mode then begin + let env = + E.note_entering_call env + ~closure_id:closure_id_being_applied ~dbg:dbg + in + let simpl = + match function_decl.function_body with + | None -> Original S.Not_inlined.Classic_mode + | Some function_body -> + let self_call = + E.inside_set_of_closures_declaration + function_decls.set_of_closures_origin env + in + let try_inlining = + if self_call then + Don't_try_it S.Not_inlined.Self_call + else + if not (E.inlining_allowed env function_decl.closure_origin) then + Don't_try_it S.Not_inlined.Unrolling_depth_exceeded + else + Try_it + in + match try_inlining with + | Don't_try_it decision -> Original decision + | Try_it -> + let fun_vars = Variable.Map.keys function_decls.funs in + let body, r = + Inlining_transforms.inline_by_copying_function_body ~env + ~r ~function_body ~lhs_of_application + ~closure_id_being_applied ~specialise_requested + ~inline_requested ~function_decl ~fun_vars ~args ~dbg ~simplify + in + let env = E.note_entering_inlined env in + let env = + (* We decrement the unrolling count even if the function is not + recursive to avoid having to check whether or not it is + recursive *) + E.inside_unrolled_function env + function_decls.set_of_closures_origin + in + let env = + E.inside_inlined_function env function_decl.closure_origin + in + Changed ((simplify env r body), S.Inlined.Classic_mode) + in + let res, decision = + match simpl with + | Original decision -> + let decision = + S.Decision.Unchanged (S.Not_specialised.Classic_mode, decision) + in + (original, original_r), decision + | Changed ((expr, r), decision) -> + let max_inlining_threshold = + if E.at_toplevel env then + Inline_and_simplify_aux.initial_inlining_toplevel_threshold + ~round:(E.round env) + else + Inline_and_simplify_aux.initial_inlining_threshold + ~round:(E.round env) + in + let raw_inlining_threshold = R.inlining_threshold r in + let unthrottled_inlining_threshold = + match raw_inlining_threshold with + | None -> max_inlining_threshold + | Some inlining_threshold -> inlining_threshold + in + let inlining_threshold = + T.min unthrottled_inlining_threshold max_inlining_threshold + in + let inlining_threshold_diff = + T.sub unthrottled_inlining_threshold inlining_threshold + in + let res = + if E.inlining_level env = 0 + then expr, R.set_inlining_threshold r raw_inlining_threshold + else expr, R.add_inlining_threshold r inlining_threshold_diff + in + res, S.Decision.Inlined (S.Not_specialised.Classic_mode, decision) + in + E.record_decision env decision; + res + end else begin + let function_body = get_function_body function_decl in + let env = E.unset_never_inline_inside_closures env in + let env = + E.note_entering_call env + ~closure_id:closure_id_being_applied ~dbg:dbg + in + let max_level = + Clflags.Int_arg_helper.get ~key:(E.round env) !Clflags.inline_max_depth + in + let raw_inlining_threshold = R.inlining_threshold r in + let max_inlining_threshold = + if E.at_toplevel env then + Inline_and_simplify_aux.initial_inlining_toplevel_threshold + ~round:(E.round env) + else + Inline_and_simplify_aux.initial_inlining_threshold + ~round:(E.round env) + in + let unthrottled_inlining_threshold = + match raw_inlining_threshold with + | None -> max_inlining_threshold + | Some inlining_threshold -> inlining_threshold + in + let inlining_threshold = + T.min unthrottled_inlining_threshold max_inlining_threshold + in + let inlining_threshold_diff = + T.sub unthrottled_inlining_threshold inlining_threshold + in + let inlining_prevented = + match inlining_threshold with + | Never_inline -> true + | Can_inline_if_no_larger_than _ -> false + in + let simpl = + if inlining_prevented then + Original (D.Prevented Function_prevented_from_inlining) + else if E.inlining_level env >= max_level then + Original (D.Prevented Level_exceeded) + else begin + let self_call = + E.inside_set_of_closures_declaration + function_decls.set_of_closures_origin env + in + let fun_cost = + lazy + (Inlining_cost.can_try_inlining function_body.body + inlining_threshold + ~number_of_arguments:(List.length function_decl.params) + (* CR-someday mshinwell: for the moment, this is None, since + the Inlining_cost code isn't checking sizes up to the max + inlining threshold---this seems to take too long. *) + ~size_from_approximation:None) + in + let recursive = + lazy + (let fun_var = Closure_id.unwrap closure_id_being_applied in + Variable.Set.mem fun_var + (Lazy.force value_set_of_closures.recursive)) + in + let specialise_result = + specialise env r + ~function_decls ~function_decl + ~lhs_of_application ~recursive ~closure_id_being_applied + ~value_set_of_closures ~args ~args_approxs ~dbg ~simplify + ~original ~inline_requested ~specialise_requested ~fun_cost + ~self_call ~inlining_threshold + in + match specialise_result with + | Changed (res, spec_reason) -> + Changed (res, D.Specialised spec_reason) + | Original spec_reason -> + let only_use_of_function = false in + (* If we didn't specialise then try inlining *) + let size_from_approximation = + let fun_var = Closure_id.unwrap closure_id_being_applied in + match + Variable.Map.find fun_var + (Lazy.force value_set_of_closures.size) + with + | size -> size + | exception Not_found -> + Misc.fatal_errorf "Approximation does not give a size for the \ + function having fun_var %a. \ + value_set_of_closures: %a" + Variable.print fun_var + A.print_value_set_of_closures value_set_of_closures + in + let fun_vars = Variable.Map.keys function_decls.funs in + let set_of_closures_origin = + function_decls.set_of_closures_origin + in + let inline_result = + inline env r ~lhs_of_application + ~closure_id_being_applied ~function_decl ~value_set_of_closures + ~only_use_of_function ~original ~recursive + ~inline_requested ~specialise_requested + ~fun_vars ~set_of_closures_origin ~args + ~size_from_approximation ~dbg ~simplify ~fun_cost ~self_call + ~inlining_threshold ~function_body + in + match inline_result with + | Changed (res, inl_reason) -> + Changed (res, D.Inlined (spec_reason, inl_reason)) + | Original inl_reason -> + Original (D.Unchanged (spec_reason, inl_reason)) + end + in + let res, decision = + match simpl with + | Original decision -> (original, original_r), decision + | Changed ((expr, r), decision) -> + let res = + if E.inlining_level env = 0 + then expr, R.set_inlining_threshold r raw_inlining_threshold + else expr, R.add_inlining_threshold r inlining_threshold_diff + in + res, decision + in + E.record_decision env decision; + res + end + +(* We do not inline inside stubs, which are always inlined at their call site. + Inlining inside the declaration of a stub could result in more code than + expected being inlined (e.g. the body of a function that was transformed + by adding the stub). *) +let should_inline_inside_declaration (decl : Flambda.function_declaration) = + not decl.stub diff --git a/middle_end/flambda/inlining_decision.mli b/middle_end/flambda/inlining_decision.mli new file mode 100644 index 00000000..3694e303 --- /dev/null +++ b/middle_end/flambda/inlining_decision.mli @@ -0,0 +1,43 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** See the Flambda manual chapter for an explanation in prose of the + inlining decision procedure. *) + +(** Try to inline a full application of a known function, guided by various + heuristics. *) +val for_call_site + : env:Inline_and_simplify_aux.Env.t + -> r:Inline_and_simplify_aux.Result.t + -> function_decls:Simple_value_approx.function_declarations + -> lhs_of_application:Variable.t + -> closure_id_being_applied:Closure_id.t + -> function_decl:Simple_value_approx.function_declaration + -> value_set_of_closures:Simple_value_approx.value_set_of_closures + -> args:Variable.t list + -> args_approxs:Simple_value_approx.t list + -> dbg:Debuginfo.t + -> simplify:Inlining_decision_intf.simplify + -> inline_requested:Lambda.inline_attribute + -> specialise_requested:Lambda.specialise_attribute + -> Flambda.t * Inline_and_simplify_aux.Result.t + +(** When a function declaration is encountered by [for_call_site], the body + may be subject to inlining immediately, thus changing the declaration. + This function must return [true] for that to be able to happen. *) +val should_inline_inside_declaration : Flambda.function_declaration -> bool diff --git a/middle_end/flambda/inlining_decision_intf.mli b/middle_end/flambda/inlining_decision_intf.mli new file mode 100644 index 00000000..15a08031 --- /dev/null +++ b/middle_end/flambda/inlining_decision_intf.mli @@ -0,0 +1,49 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(* CR-someday mshinwell: name of this source file could now be improved *) + +type 'a by_copying_function_body = + env:Inline_and_simplify_aux.Env.t + -> r:Inline_and_simplify_aux.Result.t + -> clos:Flambda.function_declarations + -> lfunc:Flambda.t + -> fun_id:Closure_id.t + -> func:Flambda.function_declaration + -> args:Flambda.t list + -> Flambda.t * Inline_and_simplify_aux.Result.t + +type 'a by_copying_function_declaration = + env:Inline_and_simplify_aux.Env.t + -> r:Inline_and_simplify_aux.Result.t + -> funct:Flambda.t + -> clos:Flambda.function_declarations + -> fun_id:Closure_id.t + -> func:Flambda.function_declaration + -> args_with_approxs: + (Flambda.t list) * (Simple_value_approx.t list) + -> invariant_params:Variable.Set.t + -> specialised_args:Variable.Set.t + -> dbg:Debuginfo.t + -> (Flambda.t * Inline_and_simplify_aux.Result.t) option + +type simplify = + Inline_and_simplify_aux.Env.t + -> Inline_and_simplify_aux.Result.t + -> Flambda.t + -> Flambda.t * Inline_and_simplify_aux.Result.t diff --git a/middle_end/flambda/inlining_stats.ml b/middle_end/flambda/inlining_stats.ml new file mode 100644 index 00000000..6809d4cb --- /dev/null +++ b/middle_end/flambda/inlining_stats.ml @@ -0,0 +1,252 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module Closure_stack = struct + type t = node list + + and node = + | Closure of Closure_id.t * Debuginfo.t + | Call of Closure_id.t * Debuginfo.t + | Inlined + | Specialised of Closure_id.Set.t + + let create () = [] + + let note_entering_closure t ~closure_id ~dbg = + if not !Clflags.inlining_report then t + else + match t with + | [] | (Closure _ | Inlined | Specialised _) :: _-> + (Closure (closure_id, dbg)) :: t + | (Call _) :: _ -> + Misc.fatal_errorf "note_entering_closure: unexpected Call node" + + (* CR-someday lwhite: since calls do not have a unique id it is possible + some calls will end up sharing nodes. *) + let note_entering_call t ~closure_id ~dbg = + if not !Clflags.inlining_report then t + else + match t with + | [] | (Closure _ | Inlined | Specialised _) :: _ -> + (Call (closure_id, dbg)) :: t + | (Call _) :: _ -> + Misc.fatal_errorf "note_entering_call: unexpected Call node" + + let note_entering_inlined t = + if not !Clflags.inlining_report then t + else + match t with + | [] | (Closure _ | Inlined | Specialised _) :: _-> + Misc.fatal_errorf "note_entering_inlined: missing Call node" + | (Call _) :: _ -> Inlined :: t + + let note_entering_specialised t ~closure_ids = + if not !Clflags.inlining_report then t + else + match t with + | [] | (Closure _ | Inlined | Specialised _) :: _ -> + Misc.fatal_errorf "note_entering_specialised: missing Call node" + | (Call _) :: _ -> Specialised closure_ids :: t + +end + +let log + : (Closure_stack.t * Inlining_stats_types.Decision.t) list ref + = ref [] + +let record_decision decision ~closure_stack = + if !Clflags.inlining_report then begin + match closure_stack with + | [] + | Closure_stack.Closure _ :: _ + | Closure_stack.Inlined :: _ + | Closure_stack.Specialised _ :: _ -> + Misc.fatal_errorf "record_decision: missing Call node" + | Closure_stack.Call _ :: _ -> + log := (closure_stack, decision) :: !log + end + +module Inlining_report = struct + + module Place = struct + type kind = + | Closure + | Call + + type t = Debuginfo.t * Closure_id.t * kind + + let compare ((d1, cl1, k1) : t) ((d2, cl2, k2) : t) = + let c = Debuginfo.compare d1 d2 in + if c <> 0 then c else + let c = Closure_id.compare cl1 cl2 in + if c <> 0 then c else + match k1, k2 with + | Closure, Closure -> 0 + | Call, Call -> 0 + | Closure, Call -> 1 + | Call, Closure -> -1 + end + + module Place_map = Map.Make(Place) + + type t = node Place_map.t + + and node = + | Closure of t + | Call of call + + and call = + { decision: Inlining_stats_types.Decision.t option; + inlined: t option; + specialised: t option; } + + let empty_call = + { decision = None; + inlined = None; + specialised = None; } + + (* Prevented or unchanged decisions may be overridden by a later look at the + same call. Other decisions may also be "overridden" because calls are not + uniquely identified. *) + let add_call_decision call (decision : Inlining_stats_types.Decision.t) = + match call.decision, decision with + | None, _ -> { call with decision = Some decision } + | Some _, Prevented _ -> call + | Some (Prevented _), _ -> { call with decision = Some decision } + | Some (Specialised _), _ -> call + | Some _, Specialised _ -> { call with decision = Some decision } + | Some (Inlined _), _ -> call + | Some _, Inlined _ -> { call with decision = Some decision } + | Some Unchanged _, Unchanged _ -> call + + let add_decision t (stack, decision) = + let rec loop t : Closure_stack.t -> _ = function + | Closure(cl, dbg) :: rest -> + let key : Place.t = (dbg, cl, Closure) in + let v = + try + match Place_map.find key t with + | Closure v -> v + | Call _ -> assert false + with Not_found -> Place_map.empty + in + let v = loop v rest in + Place_map.add key (Closure v) t + | Call(cl, dbg) :: rest -> + let key : Place.t = (dbg, cl, Call) in + let v = + try + match Place_map.find key t with + | Call v -> v + | Closure _ -> assert false + with Not_found -> empty_call + in + let v = + match rest with + | [] -> add_call_decision v decision + | Inlined :: rest -> + let inlined = + match v.inlined with + | None -> Place_map.empty + | Some inlined -> inlined + in + let inlined = loop inlined rest in + { v with inlined = Some inlined } + | Specialised _ :: rest -> + let specialised = + match v.specialised with + | None -> Place_map.empty + | Some specialised -> specialised + in + let specialised = loop specialised rest in + { v with specialised = Some specialised } + | Call _ :: _ -> assert false + | Closure _ :: _ -> assert false + in + Place_map.add key (Call v) t + | [] -> assert false + | Inlined :: _ -> assert false + | Specialised _ :: _ -> assert false + in + loop t (List.rev stack) + + let build log = + List.fold_left add_decision Place_map.empty log + + let print_stars ppf n = + let s = String.make n '*' in + Format.fprintf ppf "%s" s + + let rec print ~depth ppf t = + Place_map.iter (fun (dbg, cl, _) v -> + match v with + | Closure t -> + Format.fprintf ppf "@[%a Definition of %a%s@]@." + print_stars (depth + 1) + Closure_id.print cl + (Debuginfo.to_string dbg); + print ppf ~depth:(depth + 1) t; + if depth = 0 then Format.pp_print_newline ppf () + | Call c -> + match c.decision with + | None -> + Misc.fatal_error "Inlining_report.print: missing call decision" + | Some decision -> + Format.pp_open_vbox ppf (depth + 2); + Format.fprintf ppf "@[%a Application of %a%s@]@;@;@[%a@]" + print_stars (depth + 1) + Closure_id.print cl + (Debuginfo.to_string dbg) + Inlining_stats_types.Decision.summary decision; + Format.pp_close_box ppf (); + Format.pp_print_newline ppf (); + Format.pp_print_newline ppf (); + Inlining_stats_types.Decision.calculation ~depth:(depth + 1) + ppf decision; + begin + match c.specialised with + | None -> () + | Some specialised -> + print ppf ~depth:(depth + 1) specialised + end; + begin + match c.inlined with + | None -> () + | Some inlined -> + print ppf ~depth:(depth + 1) inlined + end; + if depth = 0 then Format.pp_print_newline ppf ()) + t + + let print ppf t = print ~depth:0 ppf t + +end + +let really_save_then_forget_decisions ~output_prefix = + let report = Inlining_report.build !log in + let out_channel = open_out (output_prefix ^ ".inlining.org") in + let ppf = Format.formatter_of_out_channel out_channel in + Inlining_report.print ppf report; + close_out out_channel; + log := [] + +let save_then_forget_decisions ~output_prefix = + if !Clflags.inlining_report then begin + really_save_then_forget_decisions ~output_prefix + end diff --git a/middle_end/flambda/inlining_stats.mli b/middle_end/flambda/inlining_stats.mli new file mode 100644 index 00000000..f1e84fdc --- /dev/null +++ b/middle_end/flambda/inlining_stats.mli @@ -0,0 +1,46 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +module Closure_stack : sig + type t + + val create : unit -> t + + val note_entering_closure + : t + -> closure_id:Closure_id.t + -> dbg:Debuginfo.t + -> t + + val note_entering_call + : t + -> closure_id:Closure_id.t + -> dbg:Debuginfo.t + -> t + + val note_entering_inlined : t -> t + val note_entering_specialised : t -> closure_ids:Closure_id.Set.t -> t + +end + +val record_decision + : Inlining_stats_types.Decision.t + -> closure_stack:Closure_stack.t + -> unit + +val save_then_forget_decisions : output_prefix:string -> unit diff --git a/middle_end/flambda/inlining_stats_types.ml b/middle_end/flambda/inlining_stats_types.ml new file mode 100644 index 00000000..7aef0796 --- /dev/null +++ b/middle_end/flambda/inlining_stats_types.ml @@ -0,0 +1,290 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module Wsb = Inlining_cost.Whether_sufficient_benefit + +let print_stars ppf n = + let s = String.make n '*' in + Format.fprintf ppf "%s" s + +let print_calculation ~depth ~title ~subfunctions ppf wsb = + Format.pp_open_vbox ppf (depth + 2); + Format.fprintf ppf "@[%a %s@]@;@;@[%a@]" + print_stars (depth + 1) + title + (Wsb.print_description ~subfunctions) wsb; + Format.pp_close_box ppf (); + Format.pp_print_newline ppf (); + Format.pp_print_newline ppf () + +module Inlined = struct + + type t = + | Classic_mode + | Annotation + | Decl_local_to_application + | Without_subfunctions of Wsb.t + | With_subfunctions of Wsb.t * Wsb.t + + let summary ppf = function + | Classic_mode -> + Format.pp_print_text ppf + "This function was inlined because it was small enough \ + to be inlined in `-Oclassic'" + | Annotation -> + Format.pp_print_text ppf + "This function was inlined because of an annotation." + | Decl_local_to_application -> + Format.pp_print_text ppf + "This function was inlined because it was local to this application." + | Without_subfunctions _ -> + Format.pp_print_text ppf + "This function was inlined because \ + the expected benefit outweighed the change in code size." + | With_subfunctions _ -> + Format.pp_print_text ppf + "This function was inlined because \ + the expected benefit outweighed the change in code size." + + let calculation ~depth ppf = function + | Classic_mode -> () + | Annotation -> () + | Decl_local_to_application -> () + | Without_subfunctions wsb -> + print_calculation + ~depth ~title:"Inlining benefit calculation" + ~subfunctions:false ppf wsb + | With_subfunctions(_, wsb) -> + print_calculation + ~depth ~title:"Inlining benefit calculation" + ~subfunctions:true ppf wsb + +end + +module Not_inlined = struct + type t = + | Classic_mode + | Above_threshold of int + | Annotation + | No_useful_approximations + | Unrolling_depth_exceeded + | Self_call + | Without_subfunctions of Wsb.t + | With_subfunctions of Wsb.t * Wsb.t + + + let summary ppf = function + | Classic_mode -> + Format.pp_print_text ppf + "This function was not inlined because it was too \ + large to be inlined in `-Oclassic'." + | Above_threshold size -> + Format.pp_print_text ppf + "This function was not inlined because \ + it was larger than the current size threshold"; + Format.fprintf ppf "(%i)" size + | Annotation -> + Format.pp_print_text ppf + "This function was not inlined because \ + of an annotation." + | No_useful_approximations -> + Format.pp_print_text ppf + "This function was not inlined because \ + there was no useful information about any of its parameters, \ + and it was not particularly small." + | Unrolling_depth_exceeded -> + Format.pp_print_text ppf + "This function was not inlined because \ + its unrolling depth was exceeded." + | Self_call -> + Format.pp_print_text ppf + "This function was not inlined because \ + it was a self call." + | Without_subfunctions _ -> + Format.pp_print_text ppf + "This function was not inlined because \ + the expected benefit did not outweigh the change in code size." + | With_subfunctions _ -> + Format.pp_print_text ppf + "This function was not inlined because \ + the expected benefit did not outweigh the change in code size." + + let calculation ~depth ppf = function + | Classic_mode + | Above_threshold _ + | Annotation + | No_useful_approximations + | Unrolling_depth_exceeded + | Self_call -> () + | Without_subfunctions wsb -> + print_calculation + ~depth ~title:"Inlining benefit calculation" + ~subfunctions:false ppf wsb + | With_subfunctions(_, wsb) -> + print_calculation + ~depth ~title:"Inlining benefit calculation" + ~subfunctions:true ppf wsb + +end + +module Specialised = struct + type t = + | Annotation + | Without_subfunctions of Wsb.t + | With_subfunctions of Wsb.t * Wsb.t + + let summary ppf = function + | Annotation -> + Format.pp_print_text ppf + "This function was specialised because of an annotation." + | Without_subfunctions _ -> + Format.pp_print_text ppf + "This function was specialised because the expected benefit \ + outweighed the change in code size." + | With_subfunctions _ -> + Format.pp_print_text ppf + "This function was specialised because the expected benefit \ + outweighed the change in code size." + + + let calculation ~depth ppf = function + | Annotation -> () + | Without_subfunctions wsb -> + print_calculation + ~depth ~title:"Specialising benefit calculation" + ~subfunctions:false ppf wsb + | With_subfunctions(_, wsb) -> + print_calculation + ~depth ~title:"Specialising benefit calculation" + ~subfunctions:true ppf wsb +end + +module Not_specialised = struct + type t = + | Classic_mode + | Above_threshold of int + | Annotation + | Not_recursive + | Not_closed + | No_invariant_parameters + | No_useful_approximations + | Self_call + | Not_beneficial of Wsb.t * Wsb.t + + let summary ppf = function + | Classic_mode -> + Format.pp_print_text ppf + "This function was not specialised because it was \ + compiled with `-Oclassic'." + | Above_threshold size -> + Format.pp_print_text ppf + "This function was not specialised because \ + it was larger than the current size threshold"; + Format.fprintf ppf "(%i)" size + | Annotation -> + Format.pp_print_text ppf + "This function was not specialised because \ + of an annotation." + | Not_recursive -> + Format.pp_print_text ppf + "This function was not specialised because \ + it is not recursive." + | Not_closed -> + Format.pp_print_text ppf + "This function was not specialised because \ + it is not closed." + | No_invariant_parameters -> + Format.pp_print_text ppf + "This function was not specialised because \ + it has no invariant parameters." + | No_useful_approximations -> + Format.pp_print_text ppf + "This function was not specialised because \ + there was no useful information about any of its invariant \ + parameters." + | Self_call -> + Format.pp_print_text ppf + "This function was not specialised because \ + it was a self call." + | Not_beneficial _ -> + Format.pp_print_text ppf + "This function was not specialised because \ + the expected benefit did not outweigh the change in code size." + + let calculation ~depth ppf = function + | Classic_mode + | Above_threshold _ + | Annotation + | Not_recursive + | Not_closed + | No_invariant_parameters + | No_useful_approximations + | Self_call -> () + | Not_beneficial(_, wsb) -> + print_calculation + ~depth ~title:"Specialising benefit calculation" + ~subfunctions:true ppf wsb + +end + +module Prevented = struct + type t = + | Function_prevented_from_inlining + | Level_exceeded + + let summary ppf = function + | Function_prevented_from_inlining -> + Format.pp_print_text ppf + "This function was prevented from inlining or specialising." + | Level_exceeded -> + Format.pp_print_text ppf + "This function was prevented from inlining or specialising \ + because the inlining depth was exceeded." +end + +module Decision = struct + type t = + | Prevented of Prevented.t + | Specialised of Specialised.t + | Inlined of Not_specialised.t * Inlined.t + | Unchanged of Not_specialised.t * Not_inlined.t + + let summary ppf = function + | Prevented p -> + Prevented.summary ppf p + | Specialised s -> + Specialised.summary ppf s + | Inlined (s, i) -> + Format.fprintf ppf "@[@[%a@]@;@;@[%a@]@]" + Not_specialised.summary s Inlined.summary i + | Unchanged (s, i) -> + Format.fprintf ppf "@[@[%a@]@;@;@[%a@]@]" + Not_specialised.summary s Not_inlined.summary i + + let calculation ~depth ppf = function + | Prevented _ -> () + | Specialised s -> + Specialised.calculation ~depth ppf s + | Inlined (s, i) -> + Not_specialised.calculation ~depth ppf s; + Inlined.calculation ~depth ppf i + | Unchanged (s, i) -> + Not_specialised.calculation ~depth ppf s; + Not_inlined.calculation ~depth ppf i +end diff --git a/middle_end/flambda/inlining_stats_types.mli b/middle_end/flambda/inlining_stats_types.mli new file mode 100644 index 00000000..9d476c89 --- /dev/null +++ b/middle_end/flambda/inlining_stats_types.mli @@ -0,0 +1,89 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(* Types used for producing statistics about inlining. *) + +module Inlined : sig + type t = + | Classic_mode + | Annotation + | Decl_local_to_application + | Without_subfunctions of + Inlining_cost.Whether_sufficient_benefit.t + | With_subfunctions of + Inlining_cost.Whether_sufficient_benefit.t + * Inlining_cost.Whether_sufficient_benefit.t +end + +module Not_inlined : sig + type t = + | Classic_mode + | Above_threshold of int + | Annotation + | No_useful_approximations + | Unrolling_depth_exceeded + | Self_call + | Without_subfunctions of + Inlining_cost.Whether_sufficient_benefit.t + | With_subfunctions of + Inlining_cost.Whether_sufficient_benefit.t + * Inlining_cost.Whether_sufficient_benefit.t +end + +module Specialised : sig + type t = + | Annotation + | Without_subfunctions of + Inlining_cost.Whether_sufficient_benefit.t + | With_subfunctions of + Inlining_cost.Whether_sufficient_benefit.t + * Inlining_cost.Whether_sufficient_benefit.t +end + +module Not_specialised : sig + type t = + | Classic_mode + | Above_threshold of int + | Annotation + | Not_recursive + | Not_closed + | No_invariant_parameters + | No_useful_approximations + | Self_call + | Not_beneficial of + Inlining_cost.Whether_sufficient_benefit.t + * Inlining_cost.Whether_sufficient_benefit.t +end + +module Prevented : sig + type t = + | Function_prevented_from_inlining + | Level_exceeded +end + +module Decision : sig + + type t = + | Prevented of Prevented.t + | Specialised of Specialised.t + | Inlined of Not_specialised.t * Inlined.t + | Unchanged of Not_specialised.t * Not_inlined.t + + val summary : Format.formatter -> t -> unit + val calculation : depth:int -> Format.formatter -> t -> unit +end diff --git a/middle_end/flambda/inlining_transforms.ml b/middle_end/flambda/inlining_transforms.ml new file mode 100644 index 00000000..c46a6cbe --- /dev/null +++ b/middle_end/flambda/inlining_transforms.ml @@ -0,0 +1,668 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module B = Inlining_cost.Benefit +module E = Inline_and_simplify_aux.Env +module R = Inline_and_simplify_aux.Result +module A = Simple_value_approx + +let new_var name = + Variable.create name + ~current_compilation_unit:(Compilation_unit.get_current_exn ()) + +(** Fold over all variables bound by the given closure, which is bound to the + variable [lhs_of_application], and corresponds to the given + [function_decls]. Each variable bound by the closure is passed to the + user-specified function as an [Flambda.named] value that projects the + variable from its closure. *) +let fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied + ~lhs_of_application ~bound_variables ~init ~f = + Variable.Set.fold (fun var acc -> + let expr : Flambda.named = + Project_var { + closure = lhs_of_application; + closure_id = closure_id_being_applied; + var = Var_within_closure.wrap var; + } + in + f ~acc ~var ~expr) + bound_variables + init + +let set_inline_attribute_on_all_apply body inline specialise = + Flambda_iterators.map_toplevel_expr (function + | Apply apply -> Apply { apply with inline; specialise } + | expr -> expr) + body + +(** Assign fresh names for a function's parameters and rewrite the body to + use these new names. *) +let copy_of_function's_body_with_freshened_params env + ~(function_decl : A.function_declaration) + ~(function_body : A.function_body) = + let params = function_decl.params in + let param_vars = Parameter.List.vars params in + (* We cannot avoid the substitution in the case where we are inlining + inside the function itself. This can happen in two ways: either + (a) we are inlining the function itself directly inside its declaration; + or (b) we are inlining the function into an already-inlined copy. + For (a) we cannot short-cut the substitution by freshening since the + original [params] may still be referenced; for (b) we cannot do it + either since the freshening may already be renaming the parameters for + the first inlining of the function. *) + if E.does_not_bind env param_vars + && E.does_not_freshen env param_vars + then + params, function_body.body + else + let freshened_params = List.map (fun p -> Parameter.rename p) params in + let subst = + Variable.Map.of_list + (List.combine param_vars (Parameter.List.vars freshened_params)) + in + let body = Flambda_utils.toplevel_substitution subst function_body.body in + freshened_params, body + +(* CR-soon mshinwell: Add a note somewhere to explain why "bound by the closure" + does not include the function identifiers for other functions in the same + set of closures. + mshinwell: The terminology may be used inconsistently. *) + +(** Inline a function by copying its body into a context where it becomes + closed. That is to say, we bind the free variables of the body + (= "variables bound by the closure"), and any function identifiers + introduced by the corresponding set of closures. *) +let inline_by_copying_function_body ~env ~r + ~lhs_of_application + ~(inline_requested : Lambda.inline_attribute) + ~(specialise_requested : Lambda.specialise_attribute) + ~closure_id_being_applied + ~(function_decl : A.function_declaration) + ~(function_body : A.function_body) + ~fun_vars + ~args ~dbg ~simplify = + assert (E.mem env lhs_of_application); + assert (List.for_all (E.mem env) args); + let r = + if function_body.stub then r + else R.map_benefit r B.remove_call + in + let freshened_params, body = + copy_of_function's_body_with_freshened_params env + ~function_decl ~function_body + in + let body = + let default_inline = + Lambda.equal_inline_attribute inline_requested Default_inline + in + let default_specialise = + Lambda.equal_specialise_attribute specialise_requested Default_specialise + in + if function_body.stub + && ((not default_inline) || (not default_specialise)) then + (* When the function inlined function is a stub, the annotation + is reported to the function applications inside the stub. + This allows reporting the annotation to the application the + original programmer really intended: the stub is not visible + in the source. *) + set_inline_attribute_on_all_apply body + inline_requested specialise_requested + else + body + in + let bindings_for_params_to_args = + (* Bind the function's parameters to the arguments from the call site. *) + let args = List.map (fun arg -> Flambda.Expr (Var arg)) args in + Flambda_utils.bind ~body + ~bindings:(List.combine (Parameter.List.vars freshened_params) args) + in + (* Add bindings for the variables bound by the closure. *) + let bindings_for_vars_bound_by_closure_and_params_to_args = + let bound_variables = + let params = Parameter.Set.vars function_decl.params in + Variable.Set.diff + (Variable.Set.diff function_body.free_variables params) + fun_vars + in + fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied + ~lhs_of_application ~bound_variables ~init:bindings_for_params_to_args + ~f:(fun ~acc:body ~var ~expr -> Flambda.create_let var expr body) + in + (* Add bindings for variables corresponding to the functions introduced by + the whole set of closures. Each such variable will be bound to a closure; + each such closure is in turn produced by moving from the closure being + applied to another closure in the same set. + *) + let expr = + Variable.Set.fold (fun another_closure_in_the_same_set expr -> + let used = + Variable.Set.mem another_closure_in_the_same_set + function_body.free_variables + in + if used then + Flambda.create_let another_closure_in_the_same_set + (Move_within_set_of_closures { + closure = lhs_of_application; + start_from = closure_id_being_applied; + move_to = Closure_id.wrap another_closure_in_the_same_set; + }) + expr + else expr) + fun_vars + bindings_for_vars_bound_by_closure_and_params_to_args + in + let env = E.set_never_inline env in + let env = E.activate_freshening env in + let env = E.set_inline_debuginfo ~dbg env in + simplify env r expr + +type state = { + old_inside_to_new_inside : Variable.t Variable.Map.t; + (* Map from old inner vars to new inner vars *) + old_outside_to_new_outside : Variable.t Variable.Map.t; + (* Map from old outer vars to new outer vars *) + old_params_to_new_outside : Variable.t Variable.Map.t; + (* Map from old parameters to new outer vars. These are params + that should be specialised if they are copied to the new set of + closures. *) + old_fun_var_to_new_fun_var : Variable.t Variable.Map.t; + (* Map from old fun vars to new fun vars. These are the functions + that will be copied into the new set of closures *) + let_bindings : (Variable.t * Flambda.named) list; + (* Let bindings that will surround the definition of the new set + of closures *) + to_copy : Variable.t list; + (* List of functions that still need to be copied to the new set + of closures *) + new_funs : Flambda.function_declaration Variable.Map.t; + (* The function declarations for the new set of closures *) + new_free_vars_with_old_projections : Flambda.specialised_to Variable.Map.t; + (* The free variables for the new set of closures, but the projection + fields still point to old free variables. *) + new_specialised_args_with_old_projections : + Flambda.specialised_to Variable.Map.t; + (* The specialised parameters for the new set of closures, but the + projection fields still point to old specialised parameters. *) +} + +let empty_state = + { to_copy = []; + old_inside_to_new_inside = Variable.Map.empty; + old_outside_to_new_outside = Variable.Map.empty; + old_params_to_new_outside = Variable.Map.empty; + old_fun_var_to_new_fun_var = Variable.Map.empty; + let_bindings = []; + new_funs = Variable.Map.empty; + new_free_vars_with_old_projections = Variable.Map.empty; + new_specialised_args_with_old_projections = Variable.Map.empty; } + +(* Add let bindings for the free vars in the set_of_closures and + add them to [old_outside_to_new_outside] *) +let bind_free_vars ~lhs_of_application ~closure_id_being_applied + ~state ~free_vars = + Variable.Map.fold + (fun free_var (spec : Flambda.specialised_to) state -> + let var_clos = new_var Internal_variable_names.from_closure in + let expr : Flambda.named = + Project_var { + closure = lhs_of_application; + closure_id = closure_id_being_applied; + var = Var_within_closure.wrap free_var; + } + in + let let_bindings = (var_clos, expr) :: state.let_bindings in + let old_outside_to_new_outside = + Variable.Map.add spec.var var_clos state.old_outside_to_new_outside + in + { state with let_bindings; old_outside_to_new_outside }) + free_vars state + +(* For arguments of specialised parameters: + - Add them to [old_outside_to_new_outside] + - Add them and their invariant aliases to [old_params_to_new_outside] + For other arguments that are also worth specialising: + - Add them and their invariant aliases to [old_params_to_new_outside] *) +let register_arguments ~specialised_args ~invariant_params + ~state ~params ~args ~args_approxs = + let rec loop ~state ~params ~args ~args_approxs = + match params, args, args_approxs with + | [], [], [] -> state + | param :: params, arg :: args, arg_approx :: args_approxs -> begin + let param = Parameter.var param in + let worth_specialising, old_outside_to_new_outside = + match Variable.Map.find_opt param specialised_args with + | Some (spec : Flambda.specialised_to) -> + let old_outside_to_new_outside = + Variable.Map.add spec.var arg state.old_outside_to_new_outside + in + true, old_outside_to_new_outside + | None -> + let worth_specialising = + A.useful arg_approx + && Variable.Map.mem param (Lazy.force invariant_params) + in + worth_specialising, state.old_outside_to_new_outside + in + let old_params_to_new_outside = + if worth_specialising then begin + let old_params_to_new_outside = + Variable.Map.add param arg state.old_params_to_new_outside + in + match Variable.Map.find_opt param (Lazy.force invariant_params) with + | Some set -> + Variable.Set.fold + (fun elem acc -> Variable.Map.add elem arg acc) + set old_params_to_new_outside + | None -> + old_params_to_new_outside + end else begin + state.old_params_to_new_outside + end + in + let state = + { state with old_outside_to_new_outside; old_params_to_new_outside } + in + loop ~state ~params ~args ~args_approxs + end + | _, _, _ -> assert false + in + loop ~state ~params ~args ~args_approxs + +(* Add an old parameter to [old_inside_to_new_inside]. If it appears in + [old_params_to_new_outside] then also add it to the new specialised args. *) +let add_param ~specialised_args ~state ~param = + let param = Parameter.var param in + let new_param = Variable.rename param in + let old_inside_to_new_inside = + Variable.Map.add param new_param state.old_inside_to_new_inside + in + let new_specialised_args_with_old_projections = + match Variable.Map.find_opt param specialised_args with + | Some (spec : Flambda.specialised_to) -> + let new_outside_var = + Variable.Map.find spec.var state.old_outside_to_new_outside + in + let new_spec : Flambda.specialised_to = + { spec with var = new_outside_var } + in + Variable.Map.add new_param new_spec + state.new_specialised_args_with_old_projections + | None -> begin + match Variable.Map.find_opt param state.old_params_to_new_outside with + | None -> state.new_specialised_args_with_old_projections + | Some new_outside_var -> + let new_spec : Flambda.specialised_to = + { var = new_outside_var; projection = None } + in + Variable.Map.add new_param new_spec + state.new_specialised_args_with_old_projections + end + in + let state = + { state with old_inside_to_new_inside; + new_specialised_args_with_old_projections } + in + state, Parameter.wrap new_param + +(* Add a let binding for an old fun_var, add it to the new free variables, and + add it to [old_inside_to_new_inside] *) +let add_fun_var ~lhs_of_application ~closure_id_being_applied ~state ~fun_var = + if Variable.Map.mem fun_var state.old_inside_to_new_inside then state + else begin + let inside_var = Variable.rename fun_var in + let outside_var = Variable.create Internal_variable_names.closure in + let expr = + Flambda.Move_within_set_of_closures + { closure = lhs_of_application; + start_from = closure_id_being_applied; + move_to = Closure_id.wrap fun_var; } + in + let let_bindings = (outside_var, expr) :: state.let_bindings in + let spec : Flambda.specialised_to = + { var = outside_var; projection = None; } + in + let new_free_vars_with_old_projections = + Variable.Map.add inside_var spec state.new_free_vars_with_old_projections + in + let old_inside_to_new_inside = + Variable.Map.add fun_var inside_var state.old_inside_to_new_inside + in + { state with + old_inside_to_new_inside; let_bindings; + new_free_vars_with_old_projections } + end + +(* Add an old free_var to the new free variables and add it to + [old_inside_to_new_inside]. *) +let add_free_var ~free_vars ~state ~free_var = + if Variable.Map.mem free_var state.old_inside_to_new_inside then state + else begin + let spec : Flambda.specialised_to = Variable.Map.find free_var free_vars in + let outside_var = spec.var in + let new_outside_var = + Variable.Map.find outside_var state.old_outside_to_new_outside + in + let new_spec : Flambda.specialised_to = + { spec with var = new_outside_var } + in + let new_inside_var = Variable.rename free_var in + let new_free_vars_with_old_projections = + Variable.Map.add new_inside_var new_spec + state.new_free_vars_with_old_projections + in + let old_inside_to_new_inside = + Variable.Map.add free_var new_inside_var state.old_inside_to_new_inside + in + { state with old_inside_to_new_inside; new_free_vars_with_old_projections } + end + +(* Add a function to the new set of closures iff: + 1) All it's specialised parameters are available in + [old_outside_to_new_outside] + 2) At least one more parameter will become specialised *) +let add_function ~specialised_args ~state ~fun_var ~function_decl = + match function_decl.A.function_body with + | None -> None + | Some _ -> begin + let rec loop worth_specialising = function + | [] -> worth_specialising + | param :: params -> begin + let param = Parameter.var param in + match Variable.Map.find_opt param specialised_args with + | Some (spec : Flambda.specialised_to) -> + Variable.Map.mem spec.var state.old_outside_to_new_outside + && loop worth_specialising params + | None -> + let worth_specialising = + worth_specialising + || Variable.Map.mem param state.old_params_to_new_outside + in + loop worth_specialising params + end + in + let worth_specialising = loop false function_decl.A.params in + if not worth_specialising then None + else begin + let new_fun_var = Variable.rename fun_var in + let old_fun_var_to_new_fun_var = + Variable.Map.add fun_var new_fun_var state.old_fun_var_to_new_fun_var + in + let to_copy = fun_var :: state.to_copy in + let state = { state with old_fun_var_to_new_fun_var; to_copy } in + Some (state, new_fun_var) + end + end + +(* Lookup a function in the new set of closures, trying to add it if + necessary. *) +let lookup_function ~specialised_args ~state ~fun_var ~function_decl = + match Variable.Map.find_opt fun_var state.old_fun_var_to_new_fun_var with + | Some new_fun_var -> Some (state, new_fun_var) + | None -> add_function ~specialised_args ~state ~fun_var ~function_decl + +(* A direct call to a function in the new set of closures can be specialised + if all the function's newly specialised parameters are passed arguments + that are specialised to the same outside variable *) +let specialisable_call ~specialised_args ~state ~args ~params = + List.for_all2 + (fun arg param -> + let param = Parameter.var param in + if Variable.Map.mem param specialised_args then true + else begin + let old_params_to_new_outside = state.old_params_to_new_outside in + match Variable.Map.find_opt param old_params_to_new_outside with + | None -> true + | Some outside_var -> begin + match Variable.Map.find_opt arg old_params_to_new_outside with + | Some outside_var' -> + Variable.equal outside_var outside_var' + | None -> false + end + end) + args params + +(* Rewrite a call iff: + 1) It is to a function in the old set of closures that can be specialised + 2) All the newly specialised parameters of that function are passed values + known to be equal to their new specialisation. *) +let rec rewrite_direct_call ~specialised_args ~funs ~direct_call_surrogates + ~state ~closure_id ~(apply : Flambda.apply) = + match Closure_id.Map.find_opt closure_id direct_call_surrogates with + | Some closure_id -> + rewrite_direct_call ~specialised_args ~funs ~direct_call_surrogates + ~state ~closure_id ~apply + | None -> begin + let fun_var = Closure_id.unwrap closure_id in + match Variable.Map.find_opt fun_var funs with + | None -> None + | Some function_decl -> begin + match + lookup_function ~specialised_args ~state ~fun_var ~function_decl + with + | None -> None + | Some (state, new_fun_var) -> begin + let args = apply.args in + let params = function_decl.A.params in + let specialisable = + specialisable_call ~specialised_args ~state ~args ~params + in + if not specialisable then None + else begin + let kind = Flambda.Direct (Closure_id.wrap new_fun_var) in + let apply = { apply with func = new_fun_var; kind } in + Some (state, Flambda.Apply apply) + end + end + end + end + +(* Rewrite the body a function declaration for use in the new set of + closures. *) +let rewrite_function ~lhs_of_application ~closure_id_being_applied + ~direct_call_surrogates ~specialised_args ~free_vars ~funs + ~state fun_var = + let function_decl : A.function_declaration = + Variable.Map.find fun_var funs + in + let function_body = + match function_decl.function_body with + | None -> assert false + | Some function_body -> function_body + in + let new_fun_var = + Variable.Map.find fun_var state.old_fun_var_to_new_fun_var + in + let state, params = + List.fold_right + (fun param (state, params) -> + let state, param = add_param ~specialised_args ~state ~param in + (state, param :: params)) + function_decl.params (state, []) + in + let state = + Variable.Set.fold + (fun var state -> + if Variable.Map.mem var funs then + add_fun_var ~lhs_of_application ~closure_id_being_applied + ~state ~fun_var:var + else if Variable.Map.mem var free_vars then + add_free_var ~free_vars ~state ~free_var:var + else + state) + function_body.free_variables state + in + let state_ref = ref state in + let body = + Flambda_iterators.map_toplevel_expr + (fun (expr : Flambda.t) -> + match expr with + | Apply ({ kind = Direct closure_id } as apply) -> begin + match + rewrite_direct_call ~specialised_args ~funs + ~direct_call_surrogates ~state:!state_ref ~closure_id ~apply + with + | None -> expr + | Some (state, expr) -> + state_ref := state; + expr + end + | _ -> expr) + function_body.body + in + let body = + Flambda_utils.toplevel_substitution state.old_inside_to_new_inside body + in + let new_function_decl = + Flambda.create_function_declaration + ~params ~body + ~stub:function_body.stub + ~dbg:function_body.dbg + ~inline:function_body.inline + ~specialise:function_body.specialise + ~is_a_functor:function_body.is_a_functor + ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var)) + in + let new_funs = + Variable.Map.add new_fun_var new_function_decl state.new_funs + in + let state = { !state_ref with new_funs } in + state + +let update_projections ~state projections = + let old_to_new = state.old_inside_to_new_inside in + Variable.Map.map + (fun (spec_to : Flambda.specialised_to) -> + let projection : Projection.t option = + match spec_to.projection with + | None -> None + | Some (Project_var proj) -> begin + match Variable.Map.find_opt proj.closure old_to_new with + | None -> None + | Some closure -> + let proj = { proj with closure } in + Some (Projection.Project_var proj) + end + | Some (Project_closure proj) -> begin + match Variable.Map.find_opt proj.set_of_closures old_to_new with + | None -> None + | Some set_of_closures -> + let proj = { proj with set_of_closures } in + Some (Projection.Project_closure proj) + end + | Some (Move_within_set_of_closures proj) -> begin + match Variable.Map.find_opt proj.closure old_to_new with + | None -> None + | Some closure -> + let proj = { proj with closure } in + Some (Projection.Move_within_set_of_closures proj) + end + | Some (Field (index, var)) -> begin + match Variable.Map.find_opt var old_to_new with + | None -> None + | Some var -> Some (Projection.Field(index, var)) + end + in + { spec_to with projection }) + projections + +let inline_by_copying_function_declaration + ~(env : Inline_and_simplify_aux.Env.t) + ~(r : Inline_and_simplify_aux.Result.t) + ~(function_decls : A.function_declarations) + ~(lhs_of_application : Variable.t) + ~(inline_requested : Lambda.inline_attribute) + ~(closure_id_being_applied : Closure_id.t) + ~(function_decl : A.function_declaration) + ~(args : Variable.t list) + ~(args_approxs : A.t list) + ~(invariant_params : Variable.Set.t Variable.Map.t lazy_t) + ~(specialised_args : Flambda.specialised_to Variable.Map.t) + ~(free_vars : Flambda.specialised_to Variable.Map.t) + ~(direct_call_surrogates : Closure_id.t Closure_id.Map.t) + ~(dbg : Debuginfo.t) + ~(simplify : Inlining_decision_intf.simplify) = + let state = empty_state in + let state = + bind_free_vars ~lhs_of_application ~closure_id_being_applied + ~state ~free_vars + in + let params = function_decl.params in + let state = + register_arguments ~specialised_args ~invariant_params + ~state ~params ~args ~args_approxs + in + let fun_var = Closure_id.unwrap closure_id_being_applied in + match add_function ~specialised_args ~state ~fun_var ~function_decl with + | None -> None + | Some (state, new_fun_var) -> begin + let funs = function_decls.funs in + let rec loop state = + match state.to_copy with + | [] -> state + | next :: rest -> + let state = { state with to_copy = rest } in + let state = + rewrite_function ~lhs_of_application ~closure_id_being_applied + ~direct_call_surrogates ~specialised_args ~free_vars ~funs + ~state next + in + loop state + in + let state = loop state in + let closure_id = Closure_id.wrap new_fun_var in + let function_decls = + Flambda.create_function_declarations_with_origin + ~funs:state.new_funs + ~set_of_closures_origin:function_decls.set_of_closures_origin + ~is_classic_mode:function_decls.is_classic_mode + in + let free_vars = + update_projections ~state + state.new_free_vars_with_old_projections + in + let specialised_args = + update_projections ~state + state.new_specialised_args_with_old_projections + in + let direct_call_surrogates = Variable.Map.empty in + let set_of_closures = + Flambda.create_set_of_closures ~function_decls + ~free_vars ~specialised_args ~direct_call_surrogates + in + let closure_var = new_var Internal_variable_names.dup_func in + let set_of_closures_var = + new_var Internal_variable_names.dup_set_of_closures + in + let project : Flambda.project_closure = + {set_of_closures = set_of_closures_var; closure_id} + in + let apply : Flambda.apply = + { func = closure_var; args; kind = Direct closure_id; dbg; + inline = inline_requested; specialise = Default_specialise; } + in + let body = + Flambda.create_let + set_of_closures_var (Set_of_closures set_of_closures) + (Flambda.create_let closure_var (Project_closure project) + (Apply apply)) + in + let expr = Flambda_utils.bind ~body ~bindings:state.let_bindings in + let env = E.activate_freshening (E.set_never_inline env) in + Some (simplify env r expr) + end diff --git a/middle_end/flambda/inlining_transforms.mli b/middle_end/flambda/inlining_transforms.mli new file mode 100644 index 00000000..e31d1b08 --- /dev/null +++ b/middle_end/flambda/inlining_transforms.mli @@ -0,0 +1,105 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Source code transformations used during inlining. *) + +(** Inline a function by substituting its body (which may be subject to + further transformation) at a call site. The function's declaration is + not copied. + + This transformation is used when: + - inlining a call to a non-recursive function; + - inlining a call, within a recursive or mutually-recursive function, to + the same or another function being defined simultaneously ("unrolling"). + The maximum depth of unrolling is bounded (see [E.unrolling_allowed]). + + In both cases, the body of the function is copied, within a sequence of + [let]s that bind the function parameters, the variables "bound by the + closure" (see flambda.mli), and any function identifiers introduced by the + set of closures. These stages are delimited below by comments. + + As an example, suppose we are inlining the following function: + + let f x = x + y + ... + let p = f, f in + (fst p) 42 + + The call site [ (fst p) 42] will be transformed to: + + let clos_id = fst p in (* must eventually yield a closure *) + let y = in + let x' = 42 in + let x = x' in + x + y + + When unrolling a recursive function we rename the arguments to the + recursive call in order to avoid clashes with existing bindings. For + example, suppose we are inlining the following call to [f], which lies + within its own declaration: + + let rec f x y = + f (fst x) (y + snd x) + + This will be transformed to: + + let rec f x y = + let clos_id = f in (* not used this time, since [f] has no free vars *) + let x' = fst x in + let y' = y + snd x in + f (fst x') (y' + snd x') (* body of [f] with parameters freshened *) +*) +val inline_by_copying_function_body + : env:Inline_and_simplify_aux.Env.t + -> r:Inline_and_simplify_aux.Result.t + -> lhs_of_application:Variable.t + -> inline_requested:Lambda.inline_attribute + -> specialise_requested:Lambda.specialise_attribute + -> closure_id_being_applied:Closure_id.t + -> function_decl:Simple_value_approx.function_declaration + -> function_body:Simple_value_approx.function_body + -> fun_vars:Variable.Set.t + -> args:Variable.t list + -> dbg:Debuginfo.t + -> simplify:Inlining_decision_intf.simplify + -> Flambda.t * Inline_and_simplify_aux.Result.t + +(** Inlining of recursive function(s) yields a copy of the functions' + definitions (not just their bodies, unlike the non-recursive case) and + a direct application of the new body. + Note: the function really does need to be recursive (but possibly only via + some mutual recursion) to end up in here; a simultaneous binding [that is + non-recursive] is not sufficient. +*) +val inline_by_copying_function_declaration + : env:Inline_and_simplify_aux.Env.t + -> r:Inline_and_simplify_aux.Result.t + -> function_decls:Simple_value_approx.function_declarations + -> lhs_of_application:Variable.t + -> inline_requested:Lambda.inline_attribute + -> closure_id_being_applied:Closure_id.t + -> function_decl:Simple_value_approx.function_declaration + -> args:Variable.t list + -> args_approxs:Simple_value_approx.t list + -> invariant_params:Variable.Set.t Variable.Map.t lazy_t + -> specialised_args:Flambda.specialised_to Variable.Map.t + -> free_vars:Flambda.specialised_to Variable.Map.t + -> direct_call_surrogates:Closure_id.t Closure_id.Map.t + -> dbg:Debuginfo.t + -> simplify:Inlining_decision_intf.simplify + -> (Flambda.t * Inline_and_simplify_aux.Result.t) option diff --git a/middle_end/flambda/invariant_params.ml b/middle_end/flambda/invariant_params.ml new file mode 100644 index 00000000..a43cfdac --- /dev/null +++ b/middle_end/flambda/invariant_params.ml @@ -0,0 +1,420 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +(* CR-someday pchambart to pchambart: in fact partial application doesn't + work because there are no 'known' partial application left: they are + converted to applications new partial function declaration. + That can be improved (and many other cases) by keeping track of aliases in + closure of functions. *) + +(* These analyses are computed in two steps: + * accumulate the atomic <- relations + * compute the least-fixed point + + The <- relation is represented by the type + + t Variable.Pair.Map.t + + if [Variable.Pair.Map.find (f, x) relation = Top] then (f, x) <- Top + is in the relation. + + if [Variable.Pair.Map.find (f, x) relation = Implication s] and + [Variable.Pair.Set.mem (g, y) s] then (f, x) <- (g, y) is in the + relation. +*) + +type t = + | Top + | Implication of Variable.Pair.Set.t + +let _print ppf = function + | Top -> Format.fprintf ppf "Top" + | Implication args -> + Format.fprintf ppf "Implication: @[%a@]" + Variable.Pair.Set.print args + +let top relation p = + Variable.Pair.Map.add p Top relation + +let implies relation from to_ = + match Variable.Pair.Map.find to_ relation with + | Top -> relation + | Implication set -> + Variable.Pair.Map.add to_ + (Implication (Variable.Pair.Set.add from set)) + relation + | exception Not_found -> + Variable.Pair.Map.add to_ + (Implication (Variable.Pair.Set.singleton from)) + relation + +let transitive_closure state = + let union s1 s2 = + match s1, s2 with + | Top, _ | _, Top -> Top + | Implication s1, Implication s2 -> + Implication (Variable.Pair.Set.union s1 s2) + in + let equal s1 s2 = + match s1, s2 with + | Top, Implication _ | Implication _, Top -> false + | Top, Top -> true + | Implication s1, Implication s2 -> Variable.Pair.Set.equal s1 s2 + in + let update arg state = + let original_set = + try Variable.Pair.Map.find arg state with + | Not_found -> Implication Variable.Pair.Set.empty + in + match original_set with + | Top -> state + | Implication arguments -> + let set = + Variable.Pair.Set.fold + (fun orig acc-> + let set = + try Variable.Pair.Map.find orig state with + | Not_found -> Implication Variable.Pair.Set.empty in + union set acc) + arguments original_set + in + Variable.Pair.Map.add arg set state + in + let once state = + Variable.Pair.Map.fold (fun arg _ state -> update arg state) state state + in + let rec fp state = + let state' = once state in + if Variable.Pair.Map.equal equal state state' + then state + else fp state' + in + fp state + +(* CR-soon pchambart: to move to Flambda_utils and document + mshinwell: I think this calculation is basically the same as + [Flambda_utils.fun_vars_referenced_in_decls], so we should try + to share code. However let's defer until after 4.03. (And note CR + below.) +*) +(* Finds variables that represent the functions. + In a construction like: + let f x = + let g = Symbol f_closure in + .. + the variable g is bound to the symbol f_closure which + is the current closure. + The result of [function_variable_alias] will contain + the association [g -> f] +*) +let function_variable_alias + (function_decls : Flambda.function_declarations) + ~backend = + let fun_vars = Variable.Map.keys function_decls.funs in + let symbols_to_fun_vars = + let module Backend = (val backend : Backend_intf.S) in + Variable.Set.fold (fun fun_var symbols_to_fun_vars -> + let closure_id = Closure_id.wrap fun_var in + let symbol = Backend.closure_symbol closure_id in + Symbol.Map.add symbol fun_var symbols_to_fun_vars) + fun_vars + Symbol.Map.empty + in + let fun_var_bindings = ref Variable.Map.empty in + Variable.Map.iter (fun _ ( function_decl : Flambda.function_declaration ) -> + Flambda_iterators.iter_all_toplevel_immutable_let_and_let_rec_bindings + ~f:(fun var named -> + (* CR-soon mshinwell: consider having the body passed to this + function and using fv calculation instead of used_variables. + Need to be careful of "let rec" *) + match named with + | Symbol sym -> + begin match Symbol.Map.find sym symbols_to_fun_vars with + | exception Not_found -> () + | fun_var -> + fun_var_bindings := + Variable.Map.add var fun_var !fun_var_bindings + end + | _ -> ()) + function_decl.body) + function_decls.funs; + !fun_var_bindings + +let analyse_functions ~backend ~param_to_param + ~anything_to_param ~param_to_anywhere + (decls : Flambda.function_declarations) = + let function_variable_alias = function_variable_alias ~backend decls in + let param_indexes_by_fun_vars = + Variable.Map.map (fun (decl : Flambda.function_declaration) -> + Array.of_list (Parameter.List.vars decl.params)) + decls.funs + in + let find_callee_arg ~callee ~callee_pos = + match Variable.Map.find callee param_indexes_by_fun_vars with + | exception Not_found -> None (* not a recursive call *) + | arr -> + (* Ignore overapplied parameters: they are applied to a different + function. *) + if callee_pos < Array.length arr then Some arr.(callee_pos) + else None + in + let escaping_functions = Variable.Tbl.create 13 in + let escaping_function fun_var = + let fun_var = + match Variable.Map.find fun_var function_variable_alias with + | exception Not_found -> fun_var + | fun_var -> fun_var + in + if Variable.Map.mem fun_var decls.funs + then Variable.Tbl.add escaping_functions fun_var (); + in + let used_variables = Variable.Tbl.create 42 in + let used_variable var = Variable.Tbl.add used_variables var () in + let relation = ref Variable.Pair.Map.empty in + (* If the called closure is in the current set of closures, record the + relation (callee, callee_arg) <- (caller, caller_arg) *) + let check_argument ~caller ~callee ~callee_pos ~caller_arg = + escaping_function caller_arg; + match find_callee_arg ~callee ~callee_pos with + | None -> used_variable caller_arg (* not a recursive call *) + | Some callee_arg -> + match Variable.Map.find caller decls.funs with + | exception Not_found -> + assert false + | { params } -> + let new_relation = + (* We only track dataflow for parameters of functions, not + arbitrary variables. *) + if List.exists + (fun param -> Variable.equal (Parameter.var param) caller_arg) + params + then + param_to_param ~caller ~caller_arg ~callee ~callee_arg !relation + else begin + used_variable caller_arg; + anything_to_param ~callee ~callee_arg !relation + end + in + relation := new_relation + in + let arity ~callee = + match Variable.Map.find callee decls.funs with + | exception Not_found -> 0 + | func -> Flambda_utils.function_arity func + in + let check_expr ~caller (expr : Flambda.t) = + match expr with + | Apply { func; args } -> + used_variable func; + let callee = + match Variable.Map.find func function_variable_alias with + | exception Not_found -> func + | callee -> callee + in + let num_args = List.length args in + for callee_pos = num_args to (arity ~callee) - 1 do + (* If a function is partially applied, consider all missing + arguments as "anything". *) + match find_callee_arg ~callee ~callee_pos with + | None -> () + | Some callee_arg -> + relation := anything_to_param ~callee ~callee_arg !relation + done; + List.iteri (fun callee_pos caller_arg -> + check_argument ~caller ~callee ~callee_pos ~caller_arg) + args + | _ -> () + in + Variable.Map.iter (fun caller (decl : Flambda.function_declaration) -> + Flambda_iterators.iter (check_expr ~caller) + (fun (_ : Flambda.named) -> ()) + decl.body; + Variable.Set.iter + (fun var -> escaping_function var; used_variable var) + (* CR-soon mshinwell: we should avoid recomputing this, cache in + [function_declaration]. See also comment on + [only_via_symbols] in [Flambda_utils]. *) + (Flambda.free_variables ~ignore_uses_as_callee:() + ~ignore_uses_as_argument:() decl.body)) + decls.funs; + Variable.Map.iter + (fun func_var ({ params } : Flambda.function_declaration) -> + List.iter + (fun (param : Parameter.t) -> + if Variable.Tbl.mem used_variables (Parameter.var param) then + relation := + param_to_anywhere ~caller:func_var + ~caller_arg:(Parameter.var param) !relation; + if Variable.Tbl.mem escaping_functions func_var then + relation := + anything_to_param ~callee:func_var + ~callee_arg:(Parameter.var param) !relation) + params) + decls.funs; + transitive_closure !relation + + +(* A parameter [x] of the function [f] is considered as unchanging if + during an 'external' (call from outside the set of closures) call of + [f], every recursive call of [f] all the instances of [x] are aliased + to the original one. This function computes an underapproximation of + that set by computing the flow of parameters between the different + functions of the set of closures. + + We record [(f, x) <- (g, y)] when the function g calls f and + the y parameter of g is used as argument for the x parameter of f. For + instance in + + let rec f x = ... + and g y = f x + + We record [(f, x) <- Top] when some unknown values can flow to the + [y] parameter. + + let rec f x = f 1 + + We record also [(f, x) <- Top] if [f] could escape. This is over + approximated by considering that a function escape when its variable is used + for something else than an application: + + let rec f x = (f, f) + + [x] is not unchanging if either + (f, x) <- Top + or (f, x) <- (f, y) with x != y + + Notice that having (f, x) <- (g, a) and (f, x) <- (g, b) does not make + x not unchanging. This is because (g, a) and (g, b) represent necessarily + different values only if g is the externaly called function. If some + value where created during the execution of the function that could + flow to (g, a), then (g, a) <- Top, so (f, x) <- Top. + + *) + +let invariant_params_in_recursion (decls : Flambda.function_declarations) + ~backend = + let param_to_param ~caller ~caller_arg ~callee ~callee_arg relation = + implies relation (caller, caller_arg) (callee, callee_arg) + in + let anything_to_param ~callee ~callee_arg relation = + top relation (callee, callee_arg) + in + let param_to_anywhere ~caller:_ ~caller_arg:_ relation = relation in + let relation = + analyse_functions ~backend ~param_to_param + ~anything_to_param ~param_to_anywhere + decls + in + let not_unchanging = + Variable.Pair.Map.fold (fun (func, var) set not_unchanging -> + match set with + | Top -> Variable.Set.add var not_unchanging + | Implication set -> + if Variable.Pair.Set.exists (fun (func', var') -> + Variable.equal func func' && not (Variable.equal var var')) + set + then Variable.Set.add var not_unchanging + else not_unchanging) + relation Variable.Set.empty + in + let params = Variable.Map.fold (fun _ + ({ params } : Flambda.function_declaration) set -> + Variable.Set.union (Parameter.Set.vars params) set) + decls.funs Variable.Set.empty + in + let unchanging = Variable.Set.diff params not_unchanging in + let aliased_to = + Variable.Pair.Map.fold (fun (_, var) set aliases -> + match set with + | Implication set + when Variable.Set.mem var unchanging -> + Variable.Pair.Set.fold (fun (_, caller_args) aliases -> + if Variable.Set.mem caller_args unchanging then + let alias_set = + match Variable.Map.find caller_args aliases with + | exception Not_found -> + Variable.Set.singleton var + | alias_set -> + Variable.Set.add var alias_set + in + Variable.Map.add caller_args alias_set aliases + else + aliases) + set aliases + | Top | Implication _ -> aliases) + relation Variable.Map.empty + in + (* We complete the set of aliases such that there does not miss any + unchanging param *) + Variable.Map.of_set (fun var -> + match Variable.Map.find var aliased_to with + | exception Not_found -> Variable.Set.empty + | set -> set) + unchanging + +let invariant_param_sources decls ~backend = + let param_to_param ~caller ~caller_arg ~callee ~callee_arg relation = + implies relation (caller, caller_arg) (callee, callee_arg) + in + let anything_to_param ~callee:_ ~callee_arg:_ relation = relation in + let param_to_anywhere ~caller:_ ~caller_arg:_ relation = relation in + let relation = + analyse_functions ~backend ~param_to_param + ~anything_to_param ~param_to_anywhere + decls + in + Variable.Pair.Map.fold (fun (_, var) set relation -> + match set with + | Top -> relation + | Implication set -> Variable.Map.add var set relation) + relation Variable.Map.empty + +let pass_name = "unused-arguments" +let () = Clflags.all_passes := pass_name :: !Clflags.all_passes + +let unused_arguments (decls : Flambda.function_declarations) ~backend = + let dump = Clflags.dumped_pass pass_name in + let param_to_param ~caller ~caller_arg ~callee ~callee_arg relation = + implies relation (callee, callee_arg) (caller, caller_arg) + in + let anything_to_param ~callee:_ ~callee_arg:_ relation = relation in + let param_to_anywhere ~caller ~caller_arg relation = + top relation (caller, caller_arg) + in + let relation = + analyse_functions ~backend ~param_to_param + ~anything_to_param ~param_to_anywhere + decls + in + let arguments = + Variable.Map.fold + (fun fun_var decl acc -> + List.fold_left + (fun acc param -> + match Variable.Pair.Map.find (fun_var, param) relation with + | exception Not_found -> Variable.Set.add param acc + | Implication _ -> Variable.Set.add param acc + | Top -> acc) + acc (Parameter.List.vars decl.Flambda.params)) + decls.funs Variable.Set.empty + in + if dump then begin + Format.printf "Unused arguments: %a@." Variable.Set.print arguments + end; + arguments diff --git a/middle_end/flambda/invariant_params.mli b/middle_end/flambda/invariant_params.mli new file mode 100644 index 00000000..c6851420 --- /dev/null +++ b/middle_end/flambda/invariant_params.mli @@ -0,0 +1,57 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(* [invariant_params_in_recursion] calculates the set of parameters whose + values are known not to change during the execution of a recursive + function. As such, occurrences of the parameters may always be replaced + by the corresponding values. + + For example, [x] would be in [invariant_params] for both of the following + functions: + + let rec f x y = (f x y) + (f x (y+1)) + + let rec f x l = List.iter (f x) l + + For invariant parameters it also computes the set of parameters of functions + in the set of closures that are always aliased to it. For example in the set + of closures: + + let rec f x y = (f x y) + (f x (y+1)) + g x + and g z = z + 1 + + The map of aliases is + + x -> { x; z } +*) +val invariant_params_in_recursion + : Flambda.function_declarations + -> backend:(module Backend_intf.S) + -> Variable.Set.t Variable.Map.t + +val invariant_param_sources + : Flambda.function_declarations + -> backend:(module Backend_intf.S) + -> Variable.Pair.Set.t Variable.Map.t + +(* CR-soon mshinwell: think about whether this function should + be in this file. Should it be called "unused_parameters"? *) +val unused_arguments + : Flambda.function_declarations + -> backend:(module Backend_intf.S) + -> Variable.Set.t diff --git a/middle_end/flambda/lift_code.ml b/middle_end/flambda/lift_code.ml new file mode 100644 index 00000000..02292c46 --- /dev/null +++ b/middle_end/flambda/lift_code.ml @@ -0,0 +1,163 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type lifter = Flambda.program -> Flambda.program + +let rebuild_let + (defs : (Variable.t * Flambda.named Flambda.With_free_variables.t) list) + (body : Flambda.t) = + let module W = Flambda.With_free_variables in + List.fold_left (fun body (var, def) -> + W.create_let_reusing_defining_expr var def body) + body defs + +let rec extract_lets + (acc:(Variable.t * Flambda.named Flambda.With_free_variables.t) list) + (let_expr:Flambda.let_expr) : + (Variable.t * Flambda.named Flambda.With_free_variables.t) list * + Flambda.t Flambda.With_free_variables.t = + let module W = Flambda.With_free_variables in + match let_expr with + | { var = v1; defining_expr = Expr (Let let2); _ } -> + let acc, body2 = extract_lets acc let2 in + let acc = (v1, W.expr body2) :: acc in + let body = W.of_body_of_let let_expr in + extract acc body + | { var = v; _ } -> + let acc = (v, W.of_defining_expr_of_let let_expr) :: acc in + let body = W.of_body_of_let let_expr in + extract acc body + +and extract acc (expr : Flambda.t Flambda.With_free_variables.t) = + let module W = Flambda.With_free_variables in + match W.contents expr with + | Let let_expr -> + extract_lets acc let_expr + | _ -> + acc, expr + +let rec lift_lets_expr (expr:Flambda.t) ~toplevel : Flambda.t = + let module W = Flambda.With_free_variables in + match expr with + | Let let_expr -> + let defs, body = extract_lets [] let_expr in + let rev_defs = + List.rev_map (lift_lets_named_with_free_variables ~toplevel) defs + in + let body = lift_lets_expr (W.contents body) ~toplevel in + rebuild_let (List.rev rev_defs) body + | e -> + Flambda_iterators.map_subexpressions + (lift_lets_expr ~toplevel) + (lift_lets_named ~toplevel) + e + +and lift_lets_named_with_free_variables + ((var, named):Variable.t * Flambda.named Flambda.With_free_variables.t) + ~toplevel : Variable.t * Flambda.named Flambda.With_free_variables.t = + let module W = Flambda.With_free_variables in + match W.contents named with + | Expr e -> + var, W.expr (W.of_expr (lift_lets_expr e ~toplevel)) + | Set_of_closures set when not toplevel -> + var, + W.of_named + (Set_of_closures + (Flambda_iterators.map_function_bodies + ~f:(lift_lets_expr ~toplevel) set)) + | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field (_, _) | Project_closure _ | Move_within_set_of_closures _ + | Project_var _ | Prim _ | Set_of_closures _ -> + var, named + +and lift_lets_named _var (named:Flambda.named) ~toplevel : Flambda.named = + let module W = Flambda.With_free_variables in + match named with + | Expr e -> + Expr (lift_lets_expr e ~toplevel) + | Set_of_closures set when not toplevel -> + Set_of_closures + (Flambda_iterators.map_function_bodies ~f:(lift_lets_expr ~toplevel) set) + | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field (_, _) | Project_closure _ | Move_within_set_of_closures _ + | Project_var _ | Prim _ | Set_of_closures _ -> + named + +module Sort_lets = Strongly_connected_components.Make (Variable) + +let rebuild_let_rec (defs:(Variable.t * Flambda.named) list) body = + let map = Variable.Map.of_list defs in + let graph = + Variable.Map.map + (fun named -> + Variable.Set.filter (fun v -> Variable.Map.mem v map) + (Flambda.free_variables_named named)) + map + in + let components = + Sort_lets.connected_components_sorted_from_roots_to_leaf graph + in + Array.fold_left (fun body (component:Sort_lets.component) -> + match component with + | No_loop v -> + let def = Variable.Map.find v map in + Flambda.create_let v def body + | Has_loop l -> + Flambda.Let_rec + (List.map (fun v -> v, Variable.Map.find v map) l, + body)) + body components + +let lift_let_rec program = + Flambda_iterators.map_exprs_at_toplevel_of_program program + ~f:(Flambda_iterators.map_expr + (fun expr -> match expr with + | Let_rec (defs, body) -> + rebuild_let_rec defs body + | expr -> expr)) + +let lift_lets program = + let program = lift_let_rec program in + Flambda_iterators.map_exprs_at_toplevel_of_program program + ~f:(lift_lets_expr ~toplevel:false) + +let lifting_helper exprs ~evaluation_order ~create_body ~name = + let vars, lets = + (* [vars] corresponds elementwise to [exprs]; the order is unchanged. *) + List.fold_right (fun (flam : Flambda.t) (vars, lets) -> + match flam with + | Var v -> + (* Note that [v] is (statically) always an immutable variable. *) + v::vars, lets + | expr -> + let v = + Variable.create name ~current_compilation_unit: + (Compilation_unit.get_current_exn ()) + in + v::vars, (v, expr)::lets) + exprs ([], []) + in + let lets = + match evaluation_order with + | `Right_to_left -> lets + | `Left_to_right -> List.rev lets + in + List.fold_left (fun body (v, expr) -> + Flambda.create_let v (Expr expr) body) + (create_body vars) lets diff --git a/middle_end/flambda/lift_code.mli b/middle_end/flambda/lift_code.mli new file mode 100644 index 00000000..92ecda01 --- /dev/null +++ b/middle_end/flambda/lift_code.mli @@ -0,0 +1,43 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +type lifter = Flambda.program -> Flambda.program + +(** Lift [let] bindings to attempt to increase the length of scopes, as an + aid to further optimizations. For example: + let c = let b = in b, b in fst c + would be transformed to: + let b = in let c = b, b in fst c + which is then clearly just: + +*) +val lift_lets : lifter + +val lift_lets_expr : Flambda.t -> toplevel:bool -> Flambda.t + +(* CR-someday mshinwell: Rename to [bind]? Also see Flambda_utils.bind. *) +(* [create_body] always receives the variables corresponding to [evaluate] + in the same order. However [evaluation_order] specifies in which order + the (possibly complex) expressions bound to those variables are + evaluated. *) +val lifting_helper + : Flambda.t list + -> evaluation_order:[ `Left_to_right | `Right_to_left ] + -> create_body:(Variable.t list -> Flambda.t) + -> name:Internal_variable_names.t + -> Flambda.t diff --git a/middle_end/flambda/lift_constants.ml b/middle_end/flambda/lift_constants.ml new file mode 100644 index 00000000..dd60de9c --- /dev/null +++ b/middle_end/flambda/lift_constants.ml @@ -0,0 +1,1019 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +(* CR-someday mshinwell: move to Flambda_utils *) +let rec tail_variable : Flambda.t -> Variable.t option = function + | Var v -> Some v + | Let_rec (_, e) + | Let_mutable { body = e } + | Let { body = e; _ } -> tail_variable e + | _ -> None + +let closure_symbol ~(backend : (module Backend_intf.S)) closure_id = + let module Backend = (val backend) in + Backend.closure_symbol closure_id + +(** Traverse the given expression assigning symbols to [let]- and [let rec]- + bound constant variables. At the same time collect the definitions of + such variables. *) +let assign_symbols_and_collect_constant_definitions + ~(backend : (module Backend_intf.S)) + ~(program : Flambda.program) + ~(inconstants : Inconstant_idents.result) = + let var_to_symbol_tbl = Variable.Tbl.create 42 in + let var_to_definition_tbl = Variable.Tbl.create 42 in + let module AA = Alias_analysis in + let assign_symbol var (named : Flambda.named) = + if not (Inconstant_idents.variable var inconstants) then begin + let assign_symbol () = + let symbol = Symbol.of_variable (Variable.rename var) in + Variable.Tbl.add var_to_symbol_tbl var symbol + in + let assign_existing_symbol = Variable.Tbl.add var_to_symbol_tbl var in + let record_definition = Variable.Tbl.add var_to_definition_tbl var in + match named with + | Symbol symbol -> + assign_existing_symbol symbol; + record_definition (AA.Symbol symbol) + | Const const -> record_definition (AA.Const const) + | Allocated_const const -> + assign_symbol (); + record_definition (AA.Allocated_const (Normal const)) + | Read_mutable _ -> + (* [Inconstant_idents] always marks these expressions as + inconstant, so we should never get here. *) + assert false + | Prim (Pmakeblock (tag, _, _value_kind), fields, _) -> + assign_symbol (); + record_definition (AA.Block (Tag.create_exn tag, fields)) + | Read_symbol_field (symbol, field) -> + record_definition (AA.Symbol_field (symbol, field)) + | Set_of_closures ( + { function_decls = { funs; set_of_closures_id; _ }; + _ } as set) -> + assert (not (Inconstant_idents.closure set_of_closures_id + inconstants)); + assign_symbol (); + record_definition (AA.Set_of_closures set); + Variable.Map.iter (fun fun_var _ -> + let closure_id = Closure_id.wrap fun_var in + let closure_symbol = closure_symbol ~backend closure_id in + Variable.Tbl.add var_to_symbol_tbl fun_var closure_symbol; + let project_closure = + Alias_analysis.Project_closure + { set_of_closures = var; closure_id } + in + Variable.Tbl.add var_to_definition_tbl fun_var + project_closure) + funs + | Move_within_set_of_closures ({ closure = _; start_from = _; move_to; } + as move) -> + assign_existing_symbol (closure_symbol ~backend move_to); + record_definition (AA.Move_within_set_of_closures move) + | Project_closure ({ closure_id } as project_closure) -> + assign_existing_symbol (closure_symbol ~backend closure_id); + record_definition (AA.Project_closure project_closure) + | Prim (Pfield index, [block], _) -> + record_definition (AA.Field (block, index)) + | Prim (Pfield _, _, _) -> + Misc.fatal_errorf "[Pfield] with the wrong number of arguments" + Flambda.print_named named + | Prim (Pmakearray (Pfloatarray as kind, mutability), args, _) -> + assign_symbol (); + record_definition (AA.Allocated_const (Array (kind, mutability, args))) + | Prim (Pduparray (kind, mutability), [arg], _) -> + assign_symbol (); + record_definition (AA.Allocated_const ( + Duplicate_array (kind, mutability, arg))) + | Prim _ -> + Misc.fatal_errorf "Primitive not expected to be constant: @.%a@." + Flambda.print_named named + | Project_var project_var -> + record_definition (AA.Project_var project_var) + | Expr e -> + match tail_variable e with + | None -> assert false (* See [Inconstant_idents]. *) + | Some v -> record_definition (AA.Variable v) + end + in + let assign_symbol_program expr = + Flambda_iterators.iter_all_immutable_let_and_let_rec_bindings expr + ~f:assign_symbol + in + Flambda_iterators.iter_exprs_at_toplevel_of_program program + ~f:assign_symbol_program; + let let_symbol_to_definition_tbl = Symbol.Tbl.create 42 in + let initialize_symbol_to_definition_tbl = Symbol.Tbl.create 42 in + let rec collect_let_and_initialize_symbols (program : Flambda.program_body) = + match program with + | Let_symbol (symbol, decl, program) -> + Symbol.Tbl.add let_symbol_to_definition_tbl symbol decl; + collect_let_and_initialize_symbols program + | Let_rec_symbol (decls, program) -> + List.iter (fun (symbol, decl) -> + Symbol.Tbl.add let_symbol_to_definition_tbl symbol decl) + decls; + collect_let_and_initialize_symbols program + | Effect (_, program) -> collect_let_and_initialize_symbols program + | Initialize_symbol (symbol,_tag,fields,program) -> + collect_let_and_initialize_symbols program; + let fields = List.map tail_variable fields in + Symbol.Tbl.add initialize_symbol_to_definition_tbl symbol fields + | End _ -> () + in + collect_let_and_initialize_symbols program.program_body; + let record_set_of_closure_equalities + (set_of_closures : Flambda.set_of_closures) = + Variable.Map.iter (fun arg (var : Flambda.specialised_to) -> + if not (Inconstant_idents.variable arg inconstants) then + Variable.Tbl.add var_to_definition_tbl arg (AA.Variable var.var)) + set_of_closures.free_vars; + Variable.Map.iter (fun arg (spec_to : Flambda.specialised_to) -> + if not (Inconstant_idents.variable arg inconstants) then + Variable.Tbl.add var_to_definition_tbl arg + (AA.Variable spec_to.var)) + set_of_closures.specialised_args + in + Flambda_iterators.iter_on_set_of_closures_of_program program + ~f:(fun ~constant set_of_closures -> + record_set_of_closure_equalities set_of_closures; + if constant then begin + Variable.Map.iter (fun fun_var _ -> + let closure_id = Closure_id.wrap fun_var in + let closure_symbol = closure_symbol ~backend closure_id in + Variable.Tbl.add var_to_definition_tbl fun_var + (AA.Symbol closure_symbol); + Variable.Tbl.add var_to_symbol_tbl fun_var closure_symbol) + set_of_closures.Flambda.function_decls.funs + end); + var_to_symbol_tbl, var_to_definition_tbl, + let_symbol_to_definition_tbl, initialize_symbol_to_definition_tbl + +let variable_field_definition + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl : + Alias_analysis.constant_defining_value Variable.Tbl.t) + (var : Variable.t) : Flambda.constant_defining_value_block_field = + try + Symbol (Variable.Tbl.find var_to_symbol_tbl var) + with Not_found -> + match Variable.Tbl.find var_to_definition_tbl var with + | Const c -> Const c + | const_defining_value -> + Misc.fatal_errorf "Unexpected pattern for a constant: %a: %a" + Variable.print var + Alias_analysis.print_constant_defining_value const_defining_value + | exception Not_found -> + Misc.fatal_errorf "No associated symbol for the constant %a" + Variable.print var + +let resolve_variable + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl : + Alias_analysis.constant_defining_value Variable.Tbl.t) + (var : Variable.t) : Flambda.constant_defining_value_block_field = + match Variable.Map.find var aliases with + | exception Not_found -> + variable_field_definition var_to_symbol_tbl var_to_definition_tbl var + | Symbol s -> Symbol s + | Variable aliased_variable -> + variable_field_definition var_to_symbol_tbl var_to_definition_tbl + aliased_variable + +let translate_set_of_closures + (inconstants : Inconstant_idents.result) + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl: + Alias_analysis.constant_defining_value Variable.Tbl.t) + (set_of_closures : Flambda.set_of_closures) = + let f var (named : Flambda.named) : Flambda.named = + if Inconstant_idents.variable var inconstants then + named + else + let resolved = + resolve_variable + aliases + var_to_symbol_tbl + var_to_definition_tbl + var + in + match resolved with + | Symbol s -> Symbol s + | Const c -> Const c + in + Flambda_iterators.map_function_bodies set_of_closures + ~f:(Flambda_iterators.map_all_immutable_let_and_let_rec_bindings ~f) + +let translate_constant_set_of_closures + (inconstants : Inconstant_idents.result) + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl: + Alias_analysis.constant_defining_value Variable.Tbl.t) + (constant_defining_values : Flambda.constant_defining_value Symbol.Map.t) = + Symbol.Map.map (fun (const : Flambda.constant_defining_value) -> + match const with + | Flambda.Allocated_const _ + | Flambda.Block _ + | Flambda.Project_closure _ -> + const + | Flambda.Set_of_closures set_of_closures -> + let set_of_closures = + translate_set_of_closures + (inconstants : Inconstant_idents.result) + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl: + Alias_analysis.constant_defining_value Variable.Tbl.t) + (set_of_closures : Flambda.set_of_closures) + in + Flambda.Set_of_closures set_of_closures) + constant_defining_values + +let find_original_set_of_closure + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl: + Alias_analysis.constant_defining_value Variable.Tbl.t) + project_closure_map + var = + let rec loop var = + match Variable.Map.find var aliases with + | Variable var -> + begin match Variable.Tbl.find var_to_definition_tbl var with + | Project_closure { set_of_closures = var } + | Move_within_set_of_closures { closure = var } -> + loop var + | Set_of_closures _ -> begin + match Variable.Tbl.find var_to_symbol_tbl var with + | s -> + s + | exception Not_found -> + Format.eprintf "var: %a@." Variable.print var; + assert false + end + | _ -> assert false + end + | Symbol s -> + match Symbol.Map.find s project_closure_map with + | exception Not_found -> + Misc.fatal_errorf "find_original_set_of_closure: cannot find \ + symbol %a in the project-closure map" + Symbol.print s + | s -> s + in + loop var + +let translate_definition_and_resolve_alias inconstants + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl : + Alias_analysis.constant_defining_value Variable.Tbl.t) + (symbol_definition_map : Flambda.constant_defining_value Symbol.Map.t) + (project_closure_map : Symbol.t Symbol.Map.t) + (definition : Alias_analysis.constant_defining_value) + ~(backend : (module Backend_intf.S)) + : Flambda.constant_defining_value option = + let resolve_float_array_involving_variables + ~(mutability : Asttypes.mutable_flag) ~vars = + (* Resolve an [Allocated_const] of the form: + [Array (Pfloatarray, _, _)] + (which references its contents via variables; it does not contain + manifest floats). *) + let find_float_var_definition var = + match Variable.Tbl.find var_to_definition_tbl var with + | Allocated_const (Normal (Float f)) -> f + | const_defining_value -> + Misc.fatal_errorf "Bad definition for float array member %a: %a" + Variable.print var + Alias_analysis.print_constant_defining_value + const_defining_value + in + let find_float_symbol_definition sym = + match Symbol.Map.find sym symbol_definition_map with + | Allocated_const (Float f) -> f + | const_defining_value -> + Misc.fatal_errorf "Bad definition for float array member %a: %a" + Symbol.print sym + Flambda.print_constant_defining_value + const_defining_value + in + let floats = + List.map (fun var -> + match Variable.Map.find var aliases with + | exception Not_found -> find_float_var_definition var + | Variable var -> find_float_var_definition var + | Symbol sym -> find_float_symbol_definition sym) + vars + in + let const : Allocated_const.t = + match mutability with + | Immutable -> Immutable_float_array floats + | Mutable -> Float_array floats + in + Some (Flambda.Allocated_const const) + in + match definition with + | Block (tag, fields) -> + Some (Flambda.Block (tag, + List.map (resolve_variable aliases var_to_symbol_tbl + var_to_definition_tbl) + fields)) + | Allocated_const (Normal const) -> Some (Flambda.Allocated_const const) + | Allocated_const (Duplicate_array (Pfloatarray, mutability, var)) -> + (* CR-someday mshinwell: This next section could do with cleanup. + What happens is: + - Duplicate contains a variable, which is resolved to + a float array thing full of variables; + - We send that value back through this function again so the + individual members of that array are resolved from variables to + floats. + - Then we can build the Flambda.name term containing the + Allocated_const (full of floats). + We should maybe factor out the code from the + Allocated_const (Array (...)) case below so this function doesn't have + to be recursive. *) + let (constant_defining_value : Alias_analysis.constant_defining_value) = + match Variable.Map.find var aliases with + | exception Not_found -> + Variable.Tbl.find var_to_definition_tbl var + | Variable var -> + Variable.Tbl.find var_to_definition_tbl var + | Symbol sym -> + match Symbol.Map.find sym symbol_definition_map with + | Allocated_const ((Immutable_float_array _) as const) -> + Alias_analysis.Allocated_const (Normal const) + | (Allocated_const _ | Block _ | Set_of_closures _ + | Project_closure _) as wrong -> + Misc.fatal_errorf + "Lift_constants.translate_definition_and_resolve_alias: \ + Duplicate Pfloatarray %a with symbol %a mapping to \ + wrong constant defining value %a" + Variable.print var + Alias_analysis.print_constant_defining_value definition + Flambda.print_constant_defining_value wrong + | exception Not_found -> + let module Backend = (val backend) in + match (Backend.import_symbol sym).descr with + | Value_unresolved _ -> + Misc.fatal_errorf + "Lift_constants.translate_definition_and_resolve_alias: \ + Duplicate Pfloatarray %a with unknown symbol: %a" + Variable.print var + Alias_analysis.print_constant_defining_value definition + | Value_float_array value_float_array -> + let contents = + Simple_value_approx.float_array_as_constant value_float_array + in + begin match contents with + | None -> + Misc.fatal_errorf + "Lift_constants.translate_definition_and_resolve_alias: \ + Duplicate Pfloatarray %a with not completely known float \ + array from symbol: %a" + Variable.print var + Alias_analysis.print_constant_defining_value definition + | Some l -> + Alias_analysis.Allocated_const (Normal (Immutable_float_array l)) + end + | wrong -> + (* CR-someday mshinwell: we might hit this if we ever duplicate + a mutable array across compilation units (e.g. "snapshotting" + an array). We do not currently generate such code. *) + Misc.fatal_errorf + "Lift_constants.translate_definition_and_resolve_alias: \ + Duplicate Pfloatarray %a with symbol %a that does not \ + have an export description of an immutable array" + Variable.print var + Alias_analysis.print_constant_defining_value definition + Simple_value_approx.print_descr wrong + in + begin match constant_defining_value with + | Allocated_const (Normal (Float_array _)) -> + (* This example from pchambart illustrates why we do not allow + the duplication of mutable arrays: + + {| + let_symbol a = Allocated_const (Immutable_float_array [|0.|]) + initialize_symbol b = Duparray(Mutable, a) + effect b.(0) <- 1. + initialize_symbol c = Duparray(Mutable, b) + |} + + This will be converted to: + {| + let_symbol a = Allocated_const (Immutable_float_array [|0.|]) + let_symbol b = Allocated_const (Float_array [|0.|]) + effect b.(0) <- 1. + let_symbol c = Allocated_const (Float_array [|0.|]) + |} + + We can't encounter that currently, but it's scary. + *) + Misc.fatal_error "Pduparray is not allowed on mutable arrays" + | Allocated_const (Normal (Immutable_float_array floats)) -> + let const : Allocated_const.t = + match mutability with + | Immutable -> Immutable_float_array floats + | Mutable -> Float_array floats + in + Some (Flambda.Allocated_const const) + | Allocated_const (Array (Pfloatarray, _, vars)) -> + (* Important: [mutability] is from the [Duplicate_array] + construction above. *) + resolve_float_array_involving_variables ~mutability ~vars + | const -> + Misc.fatal_errorf + "Lift_constants.translate_definition_and_resolve_alias: \ + Duplicate Pfloatarray %a with wrong argument: %a" + Variable.print var + Alias_analysis.print_constant_defining_value const + end + | Allocated_const (Duplicate_array (_, _, _)) -> + Misc.fatal_errorf "Lift_constants.translate_definition_and_resolve_alias: \ + Duplicate_array with non-Pfloatarray kind: %a" + Alias_analysis.print_constant_defining_value definition + | Allocated_const (Array (Pfloatarray, mutability, vars)) -> + resolve_float_array_involving_variables ~mutability ~vars + | Allocated_const (Array (_, _, _)) -> + Misc.fatal_errorf "Lift_constants.translate_definition_and_resolve_alias: \ + Array with non-Pfloatarray kind: %a" + Alias_analysis.print_constant_defining_value definition + | Project_closure { set_of_closures; closure_id } -> + begin match Variable.Map.find set_of_closures aliases with + | Symbol s -> + Some (Flambda.Project_closure (s, closure_id)) + (* If a closure projection is a constant, the set of closures must + be assigned to a symbol. *) + | exception Not_found -> + assert false + | Variable v -> + match Variable.Tbl.find var_to_symbol_tbl v with + | s -> + Some (Flambda.Project_closure (s, closure_id)) + | exception Not_found -> + Format.eprintf "var: %a@." Variable.print v; + assert false + end + | Move_within_set_of_closures { closure; move_to } -> + let set_of_closure_symbol = + find_original_set_of_closure + aliases + var_to_symbol_tbl + var_to_definition_tbl + project_closure_map + closure + in + Some (Flambda.Project_closure (set_of_closure_symbol, move_to)) + | Set_of_closures set_of_closures -> + let set_of_closures = + translate_set_of_closures + inconstants + aliases + var_to_symbol_tbl + var_to_definition_tbl + set_of_closures + in + Some (Flambda.Set_of_closures set_of_closures) + | Project_var _ -> None + | Field (_,_) | Symbol_field _ -> None + | Const _ -> None + | Symbol _ -> None + | Variable _ -> None + +let translate_definitions_and_resolve_alias + inconstants + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl: + Alias_analysis.constant_defining_value Variable.Tbl.t) + symbol_definition_map + project_closure_map + ~backend = + Variable.Tbl.fold (fun var def map -> + match + translate_definition_and_resolve_alias inconstants aliases ~backend + var_to_symbol_tbl var_to_definition_tbl symbol_definition_map + project_closure_map def + with + | None -> map + | Some def -> + let symbol = Variable.Tbl.find var_to_symbol_tbl var in + Symbol.Map.add symbol def map) + var_to_definition_tbl Symbol.Map.empty + +(* Resorting of graph including Initialize_symbol *) +let constant_dependencies ~backend:_ + (const : Flambda.constant_defining_value) = + match const with + | Allocated_const _ -> Symbol.Set.empty + | Block (_, fields) -> + let symbol_fields = + List.filter_map + (function + | (Symbol s : Flambda.constant_defining_value_block_field) -> Some s + | Flambda.Const _ -> None) + fields + in + Symbol.Set.of_list symbol_fields + | Set_of_closures set_of_closures -> + Flambda.free_symbols_named (Set_of_closures set_of_closures) + | Project_closure (s, _) -> + Symbol.Set.singleton s + +module Symbol_SCC = Strongly_connected_components.Make (Symbol) + +let program_graph ~backend imported_symbols symbol_to_constant + (initialize_symbol_tbl : + (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t) + (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t) = + let expression_symbol_dependencies expr = Flambda.free_symbols expr in + let graph_with_only_constant_parts = + Symbol.Map.map (fun const -> + Symbol.Set.diff (constant_dependencies ~backend const) + imported_symbols) + symbol_to_constant + in + let graph_with_initialisation = + Symbol.Tbl.fold (fun sym (_tag, fields, previous) -> + let order_dep = + match previous with + | None -> Symbol.Set.empty + | Some previous -> Symbol.Set.singleton previous + in + let deps = List.fold_left (fun set field -> + Symbol.Set.union (expression_symbol_dependencies field) set) + order_dep fields + in + let deps = Symbol.Set.diff deps imported_symbols in + Symbol.Map.add sym deps) + initialize_symbol_tbl graph_with_only_constant_parts + in + let graph = + Symbol.Tbl.fold (fun sym (expr, previous) -> + let order_dep = + match previous with + | None -> Symbol.Set.empty + | Some previous -> Symbol.Set.singleton previous + in + let deps = + Symbol.Set.union (expression_symbol_dependencies expr) order_dep + in + let deps = Symbol.Set.diff deps imported_symbols in + Symbol.Map.add sym deps + ) + effect_tbl graph_with_initialisation + in + let components = + Symbol_SCC.connected_components_sorted_from_roots_to_leaf + graph + in + components + +(* rebuilding the program *) +let add_definition_of_symbol constant_definitions + (initialize_symbol_tbl : + (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t) + (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t) + (program : Flambda.program_body) component : Flambda.program_body = + let symbol_declaration sym = + (* A symbol declared through an Initialize_symbol construct + cannot be recursive, this is not allowed in the construction. + This also couldn't have been introduced by this pass, so we can + safely assert that this is not possible here *) + assert(not (Symbol.Tbl.mem initialize_symbol_tbl sym)); + (sym, Symbol.Map.find sym constant_definitions) + in + match component with + | Symbol_SCC.Has_loop l -> + let l = List.map symbol_declaration l in + Let_rec_symbol (l, program) + | Symbol_SCC.No_loop sym -> + match Symbol.Tbl.find initialize_symbol_tbl sym with + | (tag, fields, _previous) -> + Initialize_symbol (sym, tag, fields, program) + | exception Not_found -> + match Symbol.Tbl.find effect_tbl sym with + | (expr, _previous) -> + Effect (expr, program) + | exception Not_found -> + let decl = Symbol.Map.find sym constant_definitions in + Let_symbol (sym, decl, program) + +let add_definitions_of_symbols constant_definitions initialize_symbol_tbl + effect_tbl program components = + Array.fold_left + (add_definition_of_symbol constant_definitions initialize_symbol_tbl + effect_tbl) + program components + +let introduce_free_variables_in_set_of_closures + (var_to_block_field_tbl : + Flambda.constant_defining_value_block_field Variable.Tbl.t) + ({ Flambda.function_decls; free_vars; specialised_args; + direct_call_surrogates; } + as set_of_closures) = + let add_definition_and_make_substitution var (expr, subst) = + let searched_var = + match Variable.Map.find var specialised_args with + | exception Not_found -> var + | external_var -> + (* specialised arguments bound to constant can be rewritten *) + external_var.var + in + match Variable.Tbl.find var_to_block_field_tbl searched_var with + | def -> + let fresh = Variable.rename var in + let named : Flambda.named = match def with + | Symbol sym -> Symbol sym + | Const c -> Const c + in + (Flambda.create_let fresh named expr), Variable.Map.add var fresh subst + | exception Not_found -> + (* The variable is bound by the closure or the arguments or not + constant. In either case it does not need to be bound *) + expr, subst + in + let done_something = ref false in + let function_decls : Flambda.function_declarations = + Flambda.update_function_declarations function_decls + ~funs:(Variable.Map.map + (fun (func_decl : Flambda.function_declaration) -> + let variables_to_bind = + (* Closures from the same set must not be bound. *) + Variable.Set.diff func_decl.free_variables + (Variable.Map.keys function_decls.funs) + in + let body, subst = + Variable.Set.fold add_definition_and_make_substitution + variables_to_bind + (func_decl.body, Variable.Map.empty) + in + if Variable.Map.is_empty subst then begin + func_decl + end else begin + done_something := true; + let body = Flambda_utils.toplevel_substitution subst body in + Flambda.update_body_of_function_declaration func_decl ~body + end) + function_decls.funs) + in + let free_vars = + (* Keep only those that are not rewritten to constants. *) + Variable.Map.filter (fun v _ -> + let keep = not (Variable.Tbl.mem var_to_block_field_tbl v) in + if not keep then done_something := true; + keep) + free_vars + in + let free_vars = + Flambda_utils.clean_projections ~which_variables:free_vars + in + let specialised_args = + (* Keep only those that are not rewritten to constants. *) + Variable.Map.filter (fun _ (spec_to : Flambda.specialised_to) -> + let keep = + not (Variable.Tbl.mem var_to_block_field_tbl spec_to.var) + in + if not keep then begin + done_something := true + end; + keep) + specialised_args + in + let specialised_args = + Flambda_utils.clean_projections ~which_variables:specialised_args + in + if not !done_something then + set_of_closures + else + Flambda.create_set_of_closures ~function_decls ~free_vars + ~specialised_args ~direct_call_surrogates + +let rewrite_project_var + (var_to_block_field_tbl + : Flambda.constant_defining_value_block_field Variable.Tbl.t) + (project_var : Flambda.project_var) ~original : Flambda.named = + let var = Var_within_closure.unwrap project_var.var in + match Variable.Tbl.find var_to_block_field_tbl var with + | exception Not_found -> original + | Symbol sym -> Symbol sym + | Const const -> Const const + +let introduce_free_variables_in_sets_of_closures + (var_to_block_field_tbl: + Flambda.constant_defining_value_block_field Variable.Tbl.t) + (translate_definition : Flambda.constant_defining_value Symbol.Map.t) = + Symbol.Map.map (fun (def : Flambda.constant_defining_value) -> + match def with + | Allocated_const _ + | Block _ + | Project_closure _ -> def + | Set_of_closures set_of_closures -> + Flambda.Set_of_closures + (introduce_free_variables_in_set_of_closures + var_to_block_field_tbl + set_of_closures)) + translate_definition + +let var_to_block_field + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl : + Alias_analysis.constant_defining_value Variable.Tbl.t) = + let var_to_block_field_tbl = Variable.Tbl.create 42 in + Variable.Tbl.iter (fun var _ -> + let def = + resolve_variable aliases var_to_symbol_tbl var_to_definition_tbl var + in + Variable.Tbl.add var_to_block_field_tbl var def) + var_to_definition_tbl; + var_to_block_field_tbl + +let program_symbols ~backend (program : Flambda.program) = + let new_fake_symbol () = + let var = Variable.create Internal_variable_names.fake_effect_symbol in + Symbol.of_variable var + in + let initialize_symbol_tbl = Symbol.Tbl.create 42 in + let effect_tbl = Symbol.Tbl.create 42 in + let symbol_definition_tbl = Symbol.Tbl.create 42 in + let add_project_closure_definitions def_symbol + (const : Flambda.constant_defining_value) = + match const with + | Set_of_closures { function_decls = { funs } } -> + Variable.Map.iter (fun fun_var _ -> + let closure_id = Closure_id.wrap fun_var in + let closure_symbol = closure_symbol ~backend closure_id in + let project_closure = + Flambda.Project_closure (def_symbol, closure_id) + in + Symbol.Tbl.add symbol_definition_tbl closure_symbol + project_closure) + funs + | Project_closure _ + | Allocated_const _ + | Block _ -> () + in + let rec loop (program : Flambda.program_body) previous_effect = + match program with + | Flambda.Let_symbol (symbol, def, program) -> + add_project_closure_definitions symbol def; + Symbol.Tbl.add symbol_definition_tbl symbol def; + loop program previous_effect + | Flambda.Let_rec_symbol (defs, program) -> + List.iter (fun (symbol, def) -> + add_project_closure_definitions symbol def; + Symbol.Tbl.add symbol_definition_tbl symbol def) + defs; + loop program previous_effect + | Flambda.Initialize_symbol (symbol, tag, fields, program) -> + (* previous_effect is used to keep the order of initialize and effect + values. Their effects order must be kept ordered. + it is used as an extra dependency when sorting the symbols. *) + (* CR-someday pchambart: if the fields expressions are pure, we could + drop this dependency + mshinwell: deferred CR *) + Symbol.Tbl.add initialize_symbol_tbl symbol + (tag, fields, previous_effect); + loop program (Some symbol) + | Flambda.Effect (expr, program) -> + (* Used to ensure that effects are correctly ordered *) + let fake_effect_symbol = new_fake_symbol () in + Symbol.Tbl.add effect_tbl fake_effect_symbol (expr, previous_effect); + loop program (Some fake_effect_symbol) + | Flambda.End _ -> () + in + loop program.program_body None; + initialize_symbol_tbl, symbol_definition_tbl, effect_tbl + +let replace_definitions_in_initialize_symbol_and_effects + (inconstants : Inconstant_idents.result) + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl : + Alias_analysis.constant_defining_value Variable.Tbl.t) + (initialize_symbol_tbl : + (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t) + (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t) = + let rewrite_expr expr = + Flambda_iterators.map_all_immutable_let_and_let_rec_bindings expr + ~f:(fun var (named : Flambda.named) : Flambda.named -> + if Inconstant_idents.variable var inconstants then + named + else + let resolved = + resolve_variable + aliases + var_to_symbol_tbl + var_to_definition_tbl + var + in + match named, resolved with + | Symbol s1, Symbol s2 -> + assert (s1 == s2); (* physical equality for speed *) + named; + | Const c1, Const c2 -> + assert (c1 == c2); + named + | _, Symbol s -> Symbol s + | _, Const c -> Const c) + in + (* This is safe because we only [replace] the current key during + iteration (cf. https://github.com/ocaml/ocaml/pull/337) *) + Symbol.Tbl.iter + (fun symbol (tag, fields, previous) -> + let fields = List.map rewrite_expr fields in + Symbol.Tbl.replace initialize_symbol_tbl symbol (tag, fields, previous)) + initialize_symbol_tbl; + Symbol.Tbl.iter + (fun symbol (expr, previous) -> + Symbol.Tbl.replace effect_tbl symbol (rewrite_expr expr, previous)) + effect_tbl + +(* CR-soon mshinwell: Update the name of [project_closure_map]. *) +let project_closure_map symbol_definition_map = + Symbol.Map.fold (fun sym (const : Flambda.constant_defining_value) acc -> + match const with + | Project_closure (set_of_closures, _) -> + Symbol.Map.add sym set_of_closures acc + | Set_of_closures _ -> + Symbol.Map.add sym sym acc + | Allocated_const _ + | Block _ -> acc) + symbol_definition_map + Symbol.Map.empty + +let lift_constants (program : Flambda.program) ~backend = + let the_dead_constant = + let var = Variable.create Internal_variable_names.the_dead_constant in + Symbol.of_variable var + in + let program_body : Flambda.program_body = + Let_symbol (the_dead_constant, Allocated_const (Nativeint 0n), + program.program_body) + in + let program : Flambda.program = + { program with program_body; } + in + let inconstants = + Inconstant_idents.inconstants_on_program program ~backend + ~compilation_unit:(Compilation_unit.get_current_exn ()) + in + let initialize_symbol_tbl, symbol_definition_tbl, effect_tbl = + program_symbols ~backend program + in + let var_to_symbol_tbl, var_to_definition_tbl, let_symbol_to_definition_tbl, + initialize_symbol_to_definition_tbl = + assign_symbols_and_collect_constant_definitions ~backend ~program + ~inconstants + in + let aliases = + Alias_analysis.run var_to_definition_tbl + initialize_symbol_to_definition_tbl + let_symbol_to_definition_tbl + ~the_dead_constant + in + replace_definitions_in_initialize_symbol_and_effects + (inconstants : Inconstant_idents.result) + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl + : Alias_analysis.constant_defining_value Variable.Tbl.t) + initialize_symbol_tbl + effect_tbl; + let symbol_definition_map = + translate_constant_set_of_closures + (inconstants : Inconstant_idents.result) + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl + : Alias_analysis.constant_defining_value Variable.Tbl.t) + (Symbol.Tbl.to_map symbol_definition_tbl) + in + let project_closure_map = project_closure_map symbol_definition_map in + let translated_definitions = + translate_definitions_and_resolve_alias + inconstants + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl + : Alias_analysis.constant_defining_value Variable.Tbl.t) + symbol_definition_map + project_closure_map + ~backend + in + let var_to_block_field_tbl = + var_to_block_field + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl + : Alias_analysis.constant_defining_value Variable.Tbl.t) + in + let translated_definitions = + introduce_free_variables_in_sets_of_closures var_to_block_field_tbl + translated_definitions + in + let constant_definitions = + (* Add previous Let_symbol to the newly discovered ones *) + Symbol.Map.union + (fun _sym + (c1:Flambda.constant_defining_value) + (c2:Flambda.constant_defining_value) -> + match c1, c2 with + | Project_closure (s1, closure_id1), + Project_closure (s2, closure_id2) when + Symbol.equal s1 s2 && + Closure_id.equal closure_id1 closure_id2 -> + Some c1 + | Project_closure (s1, closure_id1), + Project_closure (s2, closure_id2) -> + Format.eprintf "not equal project closure@. s %a %a@. cid %a %a@." + Symbol.print s1 Symbol.print s2 + Closure_id.print closure_id1 Closure_id.print closure_id2; + assert false + | _ -> + assert false + ) + symbol_definition_map + translated_definitions + in + (* Upon the [Initialize_symbol]s, the [Effect]s and the constant definitions, + do the following: + 1. Introduce [Let]s to bind variables that are going to be replaced + by constants. + 2. If a variable bound by a closure gets replaced by a symbol and + thus eliminated from the [free_vars] set of the closure, we need to + rewrite any subsequent [Project_var] expressions that project that + variable. *) + let rewrite_expr expr = + Flambda_iterators.map_named (function + | (Set_of_closures set_of_closures) as named -> + let new_set_of_closures = + introduce_free_variables_in_set_of_closures + var_to_block_field_tbl set_of_closures + in + if new_set_of_closures == set_of_closures then + named + else + Set_of_closures new_set_of_closures + | (Project_var project_var) as original -> + rewrite_project_var var_to_block_field_tbl project_var ~original + | (Symbol _ | Const _ | Allocated_const _ | Project_closure _ + | Move_within_set_of_closures _ | Prim _ | Expr _ + | Read_mutable _ | Read_symbol_field _) as named -> named) + expr + in + let constant_definitions = + Symbol.Map.map (fun (const : Flambda.constant_defining_value) -> + match const with + | Allocated_const _ | Block _ | Project_closure _ -> const + | Set_of_closures set_of_closures -> + let set_of_closures = + Flambda_iterators.map_function_bodies set_of_closures + ~f:rewrite_expr + in + Flambda.Set_of_closures + (introduce_free_variables_in_set_of_closures + var_to_block_field_tbl set_of_closures)) + constant_definitions + in + let effect_tbl = + Symbol.Tbl.map effect_tbl (fun (effect, dep) -> rewrite_expr effect, dep) + in + let initialize_symbol_tbl = + Symbol.Tbl.map initialize_symbol_tbl (fun (tag, fields, dep) -> + let fields = List.map rewrite_expr fields in + tag, fields, dep) + in + let imported_symbols = Flambda_utils.imported_symbols program in + let components = + program_graph ~backend imported_symbols constant_definitions + initialize_symbol_tbl effect_tbl + in + let program_body = + add_definitions_of_symbols constant_definitions + initialize_symbol_tbl + effect_tbl + (End (Flambda_utils.root_symbol program)) + components + in + Flambda_utils.introduce_needed_import_symbols { program with program_body; } diff --git a/middle_end/flambda/lift_constants.mli b/middle_end/flambda/lift_constants.mli new file mode 100644 index 00000000..969c365e --- /dev/null +++ b/middle_end/flambda/lift_constants.mli @@ -0,0 +1,65 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** The aim of this pass is to assign symbols to values known to be + constant (in other words, whose values we know at compile time), with + appropriate sharing of constants, and replace the occurrences of the + constants with their corresponding symbols. + + This pass uses the results of two other passes, [Inconstant_idents] and + [Alias_analysis]. The relationship between these two deserves some + attention. + + [Inconstant_idents] is a "backwards" analysis that propagates implications + about inconstantness of variables and set of closures IDs. + + [Alias_analysis] is a "forwards" analysis that is analogous to the + propagation of [Simple_value_approx.t] values during [Inline_and_simplify]. + It gives us information about relationships between values but not actually + about their constantness. + + Combining these two into a single pass has been attempted previously, + but was not thought to be successful; this experiment could be repeated in + the future. (If "constant" is considered as "top" and "inconstant" is + considered as "bottom", then [Alias_analysis] corresponds to a least fixed + point and [Inconstant_idents] corresponds to a greatest fixed point.) + + At a high level, this pass operates as follows. Symbols are assigned to + variables known to be constant and their defining expressions examined. + Based on the results of [Alias_analysis], we simplify the destructive + elements within the defining expressions (specifically, projection of + fields from blocks), to eventually yield [Flambda.constant_defining_value]s + that are entirely constructive. These will be bound to symbols in the + resulting program. + + Another approach to this pass could be to only use the results of + [Inconstant_idents] and then repeatedly lift constants and run + [Inline_and_simplify] until a fixpoint. It was thought more robust to + instead use [Alias_analysis], where the fixpointing involves a less + complicated function. + + We still run [Inline_and_simplify] once after this pass since the lifting + of constants may enable more functions to become closed; the simplification + pass provides an easy way of cleaning up (e.g. making sure [free_vars] + maps in sets of closures are correct). +*) + +val lift_constants + : Flambda.program + -> backend:(module Backend_intf.S) + -> Flambda.program diff --git a/middle_end/flambda/lift_let_to_initialize_symbol.ml b/middle_end/flambda/lift_let_to_initialize_symbol.ml new file mode 100644 index 00000000..ccef0d8a --- /dev/null +++ b/middle_end/flambda/lift_let_to_initialize_symbol.ml @@ -0,0 +1,298 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type ('a, 'b) kind = + | Initialisation of (Symbol.t * Tag.t * Flambda.t list) + | Effect of 'b + +let should_copy (named:Flambda.named) = + match named with + | Symbol _ | Read_symbol_field _ | Const _ -> true + | _ -> false + +type extracted = + | Expr of Variable.t * Flambda.t + | Exprs of Variable.t list * Flambda.t + | Block of Variable.t * Tag.t * Variable.t list + +type accumulated = { + copied_lets : (Variable.t * Flambda.named) list; + extracted_lets : extracted list; + terminator : Flambda.expr; +} + +let rec accumulate ~substitution ~copied_lets ~extracted_lets + (expr : Flambda.t) = + match expr with + | Let { var; body = Var var'; _ } | Let_rec ([var, _], Var var') + when Variable.equal var var' -> + { copied_lets; extracted_lets; + terminator = Flambda_utils.toplevel_substitution substitution expr; + } + (* If the pattern is what lifting let_rec generates, prevent it from being + lifted again. *) + | Let_rec (defs, + Let { var; body = Var var'; + defining_expr = Prim (Pmakeblock _, fields, _); }) + when + Variable.equal var var' + && List.for_all (fun field -> + List.exists (fun (def_var, _) -> Variable.equal def_var field) defs) + fields -> + { copied_lets; extracted_lets; + terminator = Flambda_utils.toplevel_substitution substitution expr; + } + | Let { var; defining_expr = Expr (Var alias); body; _ } + | Let_rec ([var, Expr (Var alias)], body) -> + let alias = + match Variable.Map.find alias substitution with + | exception Not_found -> alias + | original_alias -> original_alias + in + accumulate + ~substitution:(Variable.Map.add var alias substitution) + ~copied_lets + ~extracted_lets + body + | Let { var; defining_expr = named; body; _ } + | Let_rec ([var, named], body) + when should_copy named -> + accumulate body + ~substitution + ~copied_lets:((var, named)::copied_lets) + ~extracted_lets + | Let { var; defining_expr = named; body; _ } -> + let extracted = + let renamed = Variable.rename var in + match named with + | Prim (Pmakeblock (tag, Asttypes.Immutable, _value_kind), args, _dbg) -> + let tag = Tag.create_exn tag in + let args = + List.map (fun v -> + try Variable.Map.find v substitution + with Not_found -> v) + args + in + Block (var, tag, args) + | named -> + let expr = + Flambda_utils.toplevel_substitution substitution + (Flambda.create_let renamed named (Var renamed)) + in + Expr (var, expr) + in + accumulate body + ~substitution + ~copied_lets + ~extracted_lets:(extracted::extracted_lets) + | Let_rec ([var, named], body) -> + let renamed = Variable.rename var in + let def_substitution = Variable.Map.add var renamed substitution in + let expr = + Flambda_utils.toplevel_substitution def_substitution + (Let_rec ([renamed, named], Var renamed)) + in + let extracted = Expr (var, expr) in + accumulate body + ~substitution + ~copied_lets + ~extracted_lets:(extracted::extracted_lets) + | Let_rec (defs, body) -> + let renamed_defs, def_substitution = + List.fold_right (fun (var, def) (acc, substitution) -> + let new_var = Variable.rename var in + (new_var, def) :: acc, + Variable.Map.add var new_var substitution) + defs ([], substitution) + in + let extracted = + let expr = + let name = Internal_variable_names.lifted_let_rec_block in + Flambda_utils.toplevel_substitution def_substitution + (Let_rec (renamed_defs, + Flambda_utils.name_expr ~name + (Prim (Pmakeblock (0, Immutable, None), + List.map fst renamed_defs, + Debuginfo.none)))) + in + Exprs (List.map fst defs, expr) + in + accumulate body + ~substitution + ~copied_lets + ~extracted_lets:(extracted::extracted_lets) + | _ -> + { copied_lets; + extracted_lets; + terminator = Flambda_utils.toplevel_substitution substitution expr; + } + +let rebuild_expr + ~(extracted_definitions : (Symbol.t * int list) Variable.Map.t) + ~(copied_definitions : Flambda.named Variable.Map.t) + ~(substitute : bool) + (expr : Flambda.t) = + let expr_with_read_symbols = + Flambda_utils.substitute_read_symbol_field_for_variables + extracted_definitions expr + in + let free_variables = Flambda.free_variables expr_with_read_symbols in + let substitution = + if substitute then + Variable.Map.of_set (fun x -> Variable.rename x) free_variables + else + Variable.Map.of_set (fun x -> x) free_variables + in + let expr_with_read_symbols = + Flambda_utils.toplevel_substitution substitution + expr_with_read_symbols + in + Variable.Map.fold (fun var declaration body -> + let definition = Variable.Map.find var copied_definitions in + Flambda.create_let declaration definition body) + substitution expr_with_read_symbols + +let rebuild (used_variables:Variable.Set.t) (accumulated:accumulated) = + let copied_definitions = Variable.Map.of_list accumulated.copied_lets in + let accumulated_extracted_lets = + List.map (fun decl -> + match decl with + | Block (var, _, _) | Expr (var, _) -> + Symbol.of_variable (Variable.rename var), decl + | Exprs _ -> + let name = Internal_variable_names.lifted_let_rec_block in + let var = Variable.create name in + Symbol.of_variable var, decl) + accumulated.extracted_lets + in + let extracted_definitions = + (* Blocks are lifted to direct top-level Initialize_block: + accessing the value be done directly through the symbol. + Other let bound variables are initialized inside a size + one static block: + accessing the value is done directly through the field 0 + of the symbol. + let rec of size more than one is represented as a block of + all the bound variables allocated inside a size one static + block: + accessing the value is done directly through the right + field of the field 0 of the symbol. *) + List.fold_left (fun map (symbol, decl) -> + match decl with + | Block (var, _tag, _fields) -> + Variable.Map.add var (symbol, []) map + | Expr (var, _expr) -> + Variable.Map.add var (symbol, [0]) map + | Exprs (vars, _expr) -> + let map, _ = + List.fold_left (fun (map, field) var -> + Variable.Map.add var (symbol, [field; 0]) map, + field + 1) + (map, 0) vars + in + map) + Variable.Map.empty accumulated_extracted_lets + in + let extracted = + List.map (fun (symbol, decl) -> + match decl with + | Expr (var, decl) -> + let expr = + rebuild_expr ~extracted_definitions ~copied_definitions + ~substitute:true decl + in + if Variable.Set.mem var used_variables then + Initialisation + (symbol, + Tag.create_exn 0, + [expr]) + else + Effect expr + | Exprs (_vars, decl) -> + let expr = + rebuild_expr ~extracted_definitions ~copied_definitions + ~substitute:true decl + in + Initialisation (symbol, Tag.create_exn 0, [expr]) + | Block (_var, tag, fields) -> + let fields = + List.map (fun var -> + rebuild_expr ~extracted_definitions ~copied_definitions + ~substitute:true (Var var)) + fields + in + Initialisation (symbol, tag, fields)) + accumulated_extracted_lets + in + let terminator = + (* We don't need to substitute the variables in the terminator, we + suppose that we did for every other occurrence. Avoiding this + substitution allows this transformation to be idempotent. *) + rebuild_expr ~extracted_definitions ~copied_definitions + ~substitute:false accumulated.terminator + in + List.rev extracted, terminator + +let introduce_symbols expr = + let accumulated = + accumulate expr + ~substitution:Variable.Map.empty + ~copied_lets:[] ~extracted_lets:[] + in + let used_variables = Flambda.used_variables expr in + let extracted, terminator = rebuild used_variables accumulated in + extracted, terminator + +let add_extracted introduced program = + List.fold_right (fun extracted program -> + match extracted with + | Initialisation (symbol, tag, def) -> + Flambda.Initialize_symbol (symbol, tag, def, program) + | Effect effect -> + Flambda.Effect (effect, program)) + introduced program + +let rec split_program (program : Flambda.program_body) : Flambda.program_body = + match program with + | End s -> End s + | Let_symbol (s, def, program) -> + Let_symbol (s, def, split_program program) + | Let_rec_symbol (defs, program) -> + Let_rec_symbol (defs, split_program program) + | Effect (expr, program) -> + let program = split_program program in + let introduced, expr = introduce_symbols expr in + add_extracted introduced (Flambda.Effect (expr, program)) + | Initialize_symbol (symbol, tag, ((_::_::_) as fields), program) -> + (* CR-someday pchambart: currently the only initialize_symbol with more + than 1 field is the module block. This could evolve, in that case + this pattern should be handled properly. *) + Initialize_symbol (symbol, tag, fields, split_program program) + | Initialize_symbol (sym, tag, [], program) -> + Let_symbol (sym, Block (tag, []), split_program program) + | Initialize_symbol (symbol, tag, [field], program) -> + let program = split_program program in + let introduced, field = introduce_symbols field in + add_extracted introduced + (Flambda.Initialize_symbol (symbol, tag, [field], program)) + +let lift ~backend:_ (program : Flambda.program) = + { program with + program_body = split_program program.program_body; + } diff --git a/middle_end/flambda/lift_let_to_initialize_symbol.mli b/middle_end/flambda/lift_let_to_initialize_symbol.mli new file mode 100644 index 00000000..afb1c60f --- /dev/null +++ b/middle_end/flambda/lift_let_to_initialize_symbol.mli @@ -0,0 +1,38 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Lift toplevel [Let]-expressions to Flambda [program] constructions such + that the results of evaluation of such expressions may be accessed + directly, through symbols, rather than through closures. The + [Let]-expressions typically come from the compilation of modules (using + the bytecode strategy) in [Translmod]. + + This means of compilation supersedes the old "transl_store_" methodology + for native code. + + An [Initialize_symbol] construction generated by this pass may be + subsequently rewritten to [Let_symbol] if it is discovered that the + initializer is in fact constant. (See [Initialize_symbol_to_let_symbol].) + + The [program] constructions generated by this pass will be joined by + others that arise from the lifting of constants (see [Lift_constants]). +*) +val lift + : backend:(module Backend_intf.S) + -> Flambda.program + -> Flambda.program diff --git a/middle_end/flambda/parameter.ml b/middle_end/flambda/parameter.ml new file mode 100644 index 00000000..0c916dd7 --- /dev/null +++ b/middle_end/flambda/parameter.ml @@ -0,0 +1,69 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +[@@@ocaml.warning "+9"] +(* Warning 9 is enabled to ensure correct update of each function when + a field is added to type parameter *) + +type parameter = { + var : Variable.t; +} + +let wrap var = { var } + +let var p = p.var + +module M = + Identifiable.Make (struct + type t = parameter + + let compare { var = var1 } { var = var2 } = + Variable.compare var1 var2 + + let equal { var = var1 } { var = var2 } = + Variable.equal var1 var2 + + let hash { var } = + Variable.hash var + + let print ppf { var } = + Variable.print ppf var + + let output o { var } = + Variable.output o var + end) + +module T = M.T +include T + +module Map = M.Map +module Tbl = M.Tbl +module Set = struct + include M.Set + let vars l = Variable.Set.of_list (List.map var l) +end + +let rename ?current_compilation_unit p = + { var = Variable.rename ?current_compilation_unit p.var } + +let map_var f { var } = { var = f var } + +module List = struct + let vars params = List.map (fun { var } -> var) params +end diff --git a/middle_end/flambda/parameter.mli b/middle_end/flambda/parameter.mli new file mode 100644 index 00000000..ceed1678 --- /dev/null +++ b/middle_end/flambda/parameter.mli @@ -0,0 +1,52 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** [Parameter.t] carries a unique [Variable.t] used as function parameter. + It can also carry annotations about the usage of the variable. *) + +type t +type parameter = t + +(** Make a parameter from a variable with default attributes *) +val wrap : Variable.t -> t + +val var : t -> Variable.t + +(** Rename the inner variable of the parameter *) +val rename + : ?current_compilation_unit:Compilation_unit.t + -> t + -> t + +val map_var : (Variable.t -> Variable.t) -> t -> t + +module T : Identifiable.Thing with type t = t + +module Set : sig + include Identifiable.Set with module T := T + val vars : parameter list -> Variable.Set.t +end + +include Identifiable.S with type t := t + and module T := T + and module Set := Set + +module List : sig + (** extract variables from a list of parameters, preserving the order *) + val vars : t list -> Variable.t list +end diff --git a/middle_end/flambda/pass_wrapper.ml b/middle_end/flambda/pass_wrapper.ml new file mode 100644 index 00000000..a2005332 --- /dev/null +++ b/middle_end/flambda/pass_wrapper.ml @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let register ~pass_name = + Clflags.all_passes := pass_name :: !Clflags.all_passes + +let with_dump ~ppf_dump ~pass_name ~f ~input ~print_input ~print_output = + let dump = Clflags.dumped_pass pass_name in + let result = f () in + match result with + | None -> + if dump then Format.fprintf ppf_dump "%s: no-op.\n\n%!" pass_name; + None + | Some result -> + if dump then begin + Format.fprintf ppf_dump "Before %s:@ %a@.@." pass_name print_input input; + Format.fprintf ppf_dump "After %s:@ %a@.@." pass_name print_output result; + end; + Some result diff --git a/middle_end/flambda/pass_wrapper.mli b/middle_end/flambda/pass_wrapper.mli new file mode 100644 index 00000000..3a30e61d --- /dev/null +++ b/middle_end/flambda/pass_wrapper.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +val register : pass_name:string -> unit + +val with_dump + : ppf_dump:Format.formatter + -> pass_name:string + -> f:(unit -> 'b option) + -> input:'a + -> print_input:(Format.formatter -> 'a -> unit) + -> print_output:(Format.formatter -> 'b -> unit) + -> 'b option diff --git a/middle_end/flambda/projection.ml b/middle_end/flambda/projection.ml new file mode 100644 index 00000000..2c660a2a --- /dev/null +++ b/middle_end/flambda/projection.ml @@ -0,0 +1,170 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +(* CR-someday mshinwell: Move these three types into their own modules. *) + +type project_closure = { + set_of_closures : Variable.t; + closure_id : Closure_id.t; +} + +type move_within_set_of_closures = { + closure : Variable.t; + start_from : Closure_id.t; + move_to : Closure_id.t; +} + +type project_var = { + closure : Variable.t; + closure_id : Closure_id.t; + var : Var_within_closure.t; +} + +let compare_project_var + ({ closure = closure1; closure_id = closure_id1; var = var1; } + : project_var) + ({ closure = closure2; closure_id = closure_id2; var = var2; } + : project_var) = + let c = Variable.compare closure1 closure2 in + if c <> 0 then c + else + let c = Closure_id.compare closure_id1 closure_id2 in + if c <> 0 then c + else + Var_within_closure.compare var1 var2 + +let compare_move_within_set_of_closures + ({ closure = closure1; start_from = start_from1; move_to = move_to1; } + : move_within_set_of_closures) + ({ closure = closure2; start_from = start_from2; move_to = move_to2; } + : move_within_set_of_closures) = + let c = Variable.compare closure1 closure2 in + if c <> 0 then c + else + let c = Closure_id.compare start_from1 start_from2 in + if c <> 0 then c + else + Closure_id.compare move_to1 move_to2 + +let compare_project_closure + ({ set_of_closures = set_of_closures1; closure_id = closure_id1; } + : project_closure) + ({ set_of_closures = set_of_closures2; closure_id = closure_id2; } + : project_closure) = + let c = Variable.compare set_of_closures1 set_of_closures2 in + if c <> 0 then c + else + Closure_id.compare closure_id1 closure_id2 + +let print_project_closure ppf (project_closure : project_closure) = + Format.fprintf ppf "@[<2>(project_closure@ %a@ from@ %a)@]" + Closure_id.print project_closure.closure_id + Variable.print project_closure.set_of_closures + +let print_move_within_set_of_closures ppf + (move_within_set_of_closures : move_within_set_of_closures) = + Format.fprintf ppf + "@[<2>(move_within_set_of_closures@ %a <-- %a@ (closure = %a))@]" + Closure_id.print move_within_set_of_closures.move_to + Closure_id.print move_within_set_of_closures.start_from + Variable.print move_within_set_of_closures.closure + +let print_project_var ppf (project_var : project_var) = + Format.fprintf ppf "@[<2>(project_var@ %a@ from %a=%a)@]" + Var_within_closure.print project_var.var + Closure_id.print project_var.closure_id + Variable.print project_var.closure + +type t = + | Project_var of project_var + | Project_closure of project_closure + | Move_within_set_of_closures of move_within_set_of_closures + | Field of int * Variable.t + +include Identifiable.Make (struct + type nonrec t = t + + let compare t1 t2 = + match t1, t2 with + | Project_var project_var1, Project_var project_var2 -> + compare_project_var project_var1 project_var2 + | Project_closure project_closure1, Project_closure project_closure2 -> + compare_project_closure project_closure1 project_closure2 + | Move_within_set_of_closures move1, Move_within_set_of_closures move2 -> + compare_move_within_set_of_closures move1 move2 + | Field (index1, var1), Field (index2, var2) -> + let c = compare index1 index2 in + if c <> 0 then c + else Variable.compare var1 var2 + | Project_var _, _ -> -1 + | _, Project_var _ -> 1 + | Project_closure _, _ -> -1 + | _, Project_closure _ -> 1 + | Move_within_set_of_closures _, _ -> -1 + | _, Move_within_set_of_closures _ -> 1 + + let equal t1 t2 = + (compare t1 t2) = 0 + + let hash = Hashtbl.hash + + let print ppf t = + match t with + | Project_closure (project_closure) -> + print_project_closure ppf project_closure + | Project_var (project_var) -> print_project_var ppf project_var + | Move_within_set_of_closures (move_within_set_of_closures) -> + print_move_within_set_of_closures ppf move_within_set_of_closures + | Field (field_index, var) -> + Format.fprintf ppf "Field %d of %a" field_index Variable.print var + + let output _ _ = failwith "Projection.output: not yet implemented" +end) + +let projecting_from t = + match t with + | Project_var { closure; _ } -> closure + | Project_closure { set_of_closures; _ } -> set_of_closures + | Move_within_set_of_closures { closure; _ } -> closure + | Field (_, var) -> var + +let map_projecting_from t ~f : t = + match t with + | Project_var project_var -> + let project_var : project_var = + { project_var with + closure = f project_var.closure; + } + in + Project_var project_var + | Project_closure project_closure -> + let project_closure : project_closure = + { project_closure with + set_of_closures = f project_closure.set_of_closures; + } + in + Project_closure project_closure + | Move_within_set_of_closures move -> + let move : move_within_set_of_closures = + { move with + closure = f move.closure; + } + in + Move_within_set_of_closures move + | Field (field_index, var) -> Field (field_index, f var) diff --git a/middle_end/flambda/projection.mli b/middle_end/flambda/projection.mli new file mode 100644 index 00000000..1b251ca2 --- /dev/null +++ b/middle_end/flambda/projection.mli @@ -0,0 +1,80 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Representation of projections from closures and blocks. *) + +(** The selection of one closure given a set of closures, required before + a function defined by said set of closures can be applied. See more + detailed documentation below on [set_of_closures]. *) +type project_closure = { + set_of_closures : Variable.t; (** must yield a set of closures *) + closure_id : Closure_id.t; +} + +(** The selection of one closure given another closure in the same set of + closures. See more detailed documentation below on [set_of_closures]. + The [move_to] closure must be part of the free variables of + [start_from]. *) +type move_within_set_of_closures = { + closure : Variable.t; (** must yield a closure *) + start_from : Closure_id.t; + move_to : Closure_id.t; +} + +(** The selection from a closure of a variable bound by said closure. + In other words, access to a function's environment. Also see more + detailed documentation below on [set_of_closures]. *) +type project_var = { + closure : Variable.t; (** must yield a closure *) + closure_id : Closure_id.t; + var : Var_within_closure.t; +} + +val print_project_closure + : Format.formatter + -> project_closure + -> unit + +val print_move_within_set_of_closures + : Format.formatter + -> move_within_set_of_closures + -> unit + +val print_project_var + : Format.formatter + -> project_var + -> unit + +val compare_project_var : project_var -> project_var -> int +val compare_project_closure : project_closure -> project_closure -> int +val compare_move_within_set_of_closures + : move_within_set_of_closures + -> move_within_set_of_closures + -> int + +type t = + | Project_var of project_var + | Project_closure of project_closure + | Move_within_set_of_closures of move_within_set_of_closures + | Field of int * Variable.t + +include Identifiable.S with type t := t + +(** Return which variable the given projection projects from. *) +val projecting_from : t -> Variable.t + +(** Change the variable that the given projection projects from. *) +val map_projecting_from : t -> f:(Variable.t -> Variable.t) -> t diff --git a/middle_end/flambda/ref_to_variables.ml b/middle_end/flambda/ref_to_variables.ml new file mode 100644 index 00000000..f93948f9 --- /dev/null +++ b/middle_end/flambda/ref_to_variables.ml @@ -0,0 +1,199 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let variables_not_used_as_local_reference (tree:Flambda.t) = + let set = ref Variable.Set.empty in + let rec loop_named (flam : Flambda.named) = + match flam with + (* Directly used block: does not prevent use as a variable *) + | Prim(Pfield _, [_], _) + | Prim(Poffsetref _, [_], _) -> () + | Prim(Psetfield _, [_block; v], _) -> + (* block is not prevented to be used as a local reference, but v is *) + set := Variable.Set.add v !set + | Prim(_, _, _) + | Symbol _ |Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field _ | Project_closure _ + | Move_within_set_of_closures _ | Project_var _ -> + set := Variable.Set.union !set (Flambda.free_variables_named flam) + | Set_of_closures set_of_closures -> + set := Variable.Set.union !set (Flambda.free_variables_named flam); + Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) -> + loop function_decl.body) + set_of_closures.function_decls.funs + | Expr e -> + loop e + and loop (flam : Flambda.t) = + match flam with + | Let { defining_expr; body; _ } -> + loop_named defining_expr; + loop body + | Let_rec (defs, body) -> + List.iter (fun (_var, named) -> loop_named named) defs; + loop body + | Var v -> + set := Variable.Set.add v !set + | Let_mutable { initial_value = v; body } -> + set := Variable.Set.add v !set; + loop body + | If_then_else (cond, ifso, ifnot) -> + set := Variable.Set.add cond !set; + loop ifso; + loop ifnot + | Switch (cond, { consts; blocks; failaction }) -> + set := Variable.Set.add cond !set; + List.iter (fun (_, branch) -> loop branch) consts; + List.iter (fun (_, branch) -> loop branch) blocks; + Misc.may loop failaction + | String_switch (cond, branches, default) -> + set := Variable.Set.add cond !set; + List.iter (fun (_, branch) -> loop branch) branches; + Misc.may loop default + | Static_catch (_, _, body, handler) -> + loop body; + loop handler + | Try_with (body, _, handler) -> + loop body; + loop handler + | While (cond, body) -> + loop cond; + loop body + | For { bound_var = _; from_value; to_value; direction = _; body; } -> + set := Variable.Set.add from_value !set; + set := Variable.Set.add to_value !set; + loop body + | Static_raise (_, args) -> + set := Variable.Set.union (Variable.Set.of_list args) !set + | Proved_unreachable | Apply _ | Send _ | Assign _ -> + set := Variable.Set.union !set (Flambda.free_variables flam) + in + loop tree; + !set + +let variables_containing_ref (flam:Flambda.t) = + let map = ref Variable.Map.empty in + let aux (flam : Flambda.t) = + match flam with + | Let { var; + defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable, _), l, _); + } -> + map := Variable.Map.add var (List.length l) !map + | _ -> () + in + Flambda_iterators.iter aux (fun _ -> ()) flam; + !map + +let eliminate_ref_of_expr flam = + let variables_not_used_as_local_reference = + variables_not_used_as_local_reference flam + in + let convertible_variables = + Variable.Map.filter + (fun v _ -> + not (Variable.Set.mem v variables_not_used_as_local_reference)) + (variables_containing_ref flam) + in + if Variable.Map.cardinal convertible_variables = 0 then flam + else + let convertible_variables = + Variable.Map.mapi (fun v size -> + Array.init size (fun _ -> Mutable_variable.create_from_variable v)) + convertible_variables + in + let convertible_variable v = Variable.Map.mem v convertible_variables in + let get_variable v field = + let arr = try Variable.Map.find v convertible_variables + with Not_found -> assert false in + if Array.length arr <= field + then None (* This case could apply when inlining code containing GADTS *) + else Some (arr.(field), Array.length arr) + in + let aux (flam : Flambda.t) : Flambda.t = + match flam with + | Let { var; + defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable, shape), l,_); + body } + when convertible_variable var -> + let shape = match shape with + | None -> List.map (fun _ -> Lambda.Pgenval) l + | Some shape -> shape + in + let _, expr = + List.fold_left2 (fun (field,body) init kind -> + match get_variable var field with + | None -> assert false + | Some (field_var, _) -> + field+1, + (Let_mutable { var = field_var; + initial_value = init; + body; + contents_kind = kind } : Flambda.t)) + (0,body) l shape in + expr + | Let _ | Let_mutable _ + | Assign _ | Var _ | Apply _ + | Let_rec _ | Switch _ | String_switch _ + | Static_raise _ | Static_catch _ + | Try_with _ | If_then_else _ + | While _ | For _ | Send _ | Proved_unreachable -> + flam + and aux_named (named : Flambda.named) : Flambda.named = + match named with + | Prim(Pfield field, [v], _) + when convertible_variable v -> + (match get_variable v field with + | None -> Expr Proved_unreachable + | Some (var,_) -> Read_mutable var) + | Prim(Poffsetref delta, [v], dbg) + when convertible_variable v -> + (match get_variable v 0 with + | None -> Expr Proved_unreachable + | Some (var,size) -> + if size = 1 + then begin + let mut_name = Internal_variable_names.read_mutable in + let mut = Variable.create mut_name in + let new_value_name = Internal_variable_names.offsetted in + let new_value = Variable.create new_value_name in + let expr = + Flambda.create_let mut (Read_mutable var) + (Flambda.create_let new_value + (Prim(Poffsetint delta, [mut], dbg)) + (Assign { being_assigned = var; new_value })) + in + Expr expr + end + else + Expr Proved_unreachable) + | Prim(Psetfield (field, _, _), [v; new_value], _) + when convertible_variable v -> + (match get_variable v field with + | None -> Expr Proved_unreachable + | Some (being_assigned,_) -> + Expr (Assign { being_assigned; new_value })) + | Prim _ | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field _ | Set_of_closures _ | Project_closure _ + | Move_within_set_of_closures _ | Project_var _ | Expr _ -> + named + in + Flambda_iterators.map aux aux_named flam + +let eliminate_ref (program:Flambda.program) = + Flambda_iterators.map_exprs_at_toplevel_of_program program + ~f:eliminate_ref_of_expr diff --git a/middle_end/flambda/ref_to_variables.mli b/middle_end/flambda/ref_to_variables.mli new file mode 100644 index 00000000..38d36889 --- /dev/null +++ b/middle_end/flambda/ref_to_variables.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Transform [let]-bound references into variables. *) + +val eliminate_ref + : Flambda.program + -> Flambda.program diff --git a/middle_end/flambda/remove_free_vars_equal_to_args.ml b/middle_end/flambda/remove_free_vars_equal_to_args.ml new file mode 100644 index 00000000..6327d30c --- /dev/null +++ b/middle_end/flambda/remove_free_vars_equal_to_args.ml @@ -0,0 +1,99 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let pass_name = "remove-free-vars-equal-to-args" +let () = Pass_wrapper.register ~pass_name + +let rewrite_one_function_decl ~(function_decl : Flambda.function_declaration) + ~back_free_vars ~specialised_args = + let params_for_equal_free_vars = + List.fold_left (fun subst param -> + match Variable.Map.find param specialised_args with + | exception Not_found -> + (* param is not specialised *) + subst + | (spec_to : Flambda.specialised_to) -> + let outside_var = spec_to.var in + match Variable.Map.find outside_var back_free_vars with + | exception Not_found -> + (* No free variables equal to the param *) + subst + | set -> + (* Replace the free variables equal to a parameter *) + Variable.Set.fold (fun free_var subst -> + Variable.Map.add free_var param subst) + set subst) + Variable.Map.empty (Parameter.List.vars function_decl.params) + in + if Variable.Map.is_empty params_for_equal_free_vars then + function_decl + else + let body = + Flambda_utils.toplevel_substitution + params_for_equal_free_vars + function_decl.body + in + Flambda.update_function_declaration function_decl + ~params:function_decl.params ~body:body + +let rewrite_one_set_of_closures (set_of_closures : Flambda.set_of_closures) = + let back_free_vars = + Variable.Map.fold (fun var (outside_var : Flambda.specialised_to) map -> + let set = + match Variable.Map.find outside_var.var map with + | exception Not_found -> Variable.Set.singleton var + | set -> Variable.Set.add var set + in + Variable.Map.add outside_var.var set map) + set_of_closures.free_vars Variable.Map.empty + in + let done_something = ref false in + let funs = + Variable.Map.map (fun function_decl -> + let new_function_decl = + rewrite_one_function_decl ~function_decl ~back_free_vars + ~specialised_args:set_of_closures.specialised_args + in + if not (new_function_decl == function_decl) then begin + done_something := true + end; + new_function_decl) + set_of_closures.function_decls.funs + in + if not !done_something then + None + else + let function_decls = + Flambda.update_function_declarations + set_of_closures.function_decls ~funs + in + let set_of_closures = + Flambda.create_set_of_closures + ~function_decls + ~free_vars:set_of_closures.free_vars + ~specialised_args:set_of_closures.specialised_args + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + in + Some set_of_closures + +let run ~ppf_dump set_of_closures = + Pass_wrapper.with_dump ~ppf_dump ~pass_name ~input:set_of_closures + ~print_input:Flambda.print_set_of_closures + ~print_output:Flambda.print_set_of_closures + ~f:(fun () -> rewrite_one_set_of_closures set_of_closures) diff --git a/middle_end/flambda/remove_free_vars_equal_to_args.mli b/middle_end/flambda/remove_free_vars_equal_to_args.mli new file mode 100644 index 00000000..49f25ac1 --- /dev/null +++ b/middle_end/flambda/remove_free_vars_equal_to_args.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Replace free variables in closures known to be equal to specialised + arguments of such closures with those specialised arguments. *) + +val run + : ppf_dump:Format.formatter + -> Flambda.set_of_closures + -> Flambda.set_of_closures option diff --git a/middle_end/flambda/remove_unused_arguments.ml b/middle_end/flambda/remove_unused_arguments.ml new file mode 100644 index 00000000..f70da729 --- /dev/null +++ b/middle_end/flambda/remove_unused_arguments.ml @@ -0,0 +1,242 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let pass_name = "remove-unused-arguments" +let () = Clflags.all_passes := pass_name :: !Clflags.all_passes + +let rename_var var = + Variable.rename var + ~current_compilation_unit:(Compilation_unit.get_current_exn ()) + +let remove_params unused (fun_decl: Flambda.function_declaration) + ~new_fun_var = + let unused_params, used_params = + List.partition (fun v -> Variable.Set.mem (Parameter.var v) unused) + fun_decl.params + in + let unused_params = List.filter (fun v -> + Variable.Set.mem (Parameter.var v) fun_decl.free_variables) unused_params + in + let body = + List.fold_left (fun body param -> + Flambda.create_let (Parameter.var param) (Const (Const_pointer 0)) body) + fun_decl.body + unused_params + in + Flambda.create_function_declaration ~params:used_params ~body + ~stub:fun_decl.stub ~dbg:fun_decl.dbg ~inline:fun_decl.inline + ~specialise:fun_decl.specialise ~is_a_functor:fun_decl.is_a_functor + ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var)) + +let make_stub unused var (fun_decl : Flambda.function_declaration) + ~specialised_args ~additional_specialised_args = + let renamed = rename_var var in + let args' = + List.map (fun param -> param, Parameter.rename param) fun_decl.params + in + let used_args' = + List.filter (fun (param, _) -> + not (Variable.Set.mem (Parameter.var param) unused)) args' + in + let args'_var = + List.map (fun (p1, p2) -> Parameter.var p1, Parameter.var p2) args' + in + let args_renaming = Variable.Map.of_list args'_var in + let additional_specialised_args = + List.fold_left (fun additional_specialised_args (original_arg,arg) -> + match Variable.Map.find original_arg specialised_args with + | exception Not_found -> additional_specialised_args + | (outer_var : Flambda.specialised_to) -> + (* CR-soon mshinwell: share with Augment_specialised_args *) + let outer_var : Flambda.specialised_to = + match outer_var.projection with + | None -> outer_var + | Some projection -> + let projection = + Projection.map_projecting_from projection ~f:(fun var -> + match Variable.Map.find var args_renaming with + | exception Not_found -> + (* Must always be a parameter of this + [function_decl]. *) + assert false + | wrapper_arg -> wrapper_arg) + in + { outer_var with + projection = Some projection; + } + in + Variable.Map.add arg outer_var additional_specialised_args) + additional_specialised_args args'_var + in + let args = List.map (fun (_, var) -> var) used_args' in + let kind = Flambda.Direct (Closure_id.wrap renamed) in + let body : Flambda.t = + Apply { + func = renamed; + args = Parameter.List.vars args; + kind; + dbg = fun_decl.dbg; + inline = Default_inline; + specialise = Default_specialise; + } + in + let function_decl = + Flambda.create_function_declaration ~params:(List.map snd args') ~body + ~stub:true ~dbg:fun_decl.dbg ~inline:Default_inline + ~specialise:Default_specialise ~is_a_functor:fun_decl.is_a_functor + ~closure_origin:fun_decl.closure_origin + in + function_decl, renamed, additional_specialised_args + +let separate_unused_arguments ~only_specialised + ~backend ~(set_of_closures : Flambda.set_of_closures) = + let function_decls = set_of_closures.function_decls in + let unused = Invariant_params.unused_arguments ~backend function_decls in + let non_stub_arguments = + Variable.Map.fold (fun _ (decl : Flambda.function_declaration) acc -> + if decl.stub then + acc + else + Variable.Set.union acc (Parameter.Set.vars decl.Flambda.params)) + function_decls.funs Variable.Set.empty + in + let unused = Variable.Set.inter non_stub_arguments unused in + let specialised_args = Variable.Map.keys set_of_closures.specialised_args in + let unused = + if only_specialised then Variable.Set.inter specialised_args unused + else unused + in + if Variable.Set.is_empty unused + then None + else begin + let funs, additional_specialised_args = + Variable.Map.fold (fun fun_id (fun_decl : Flambda.function_declaration) + (funs, additional_specialised_args) -> + if List.exists (fun v -> Variable.Set.mem (Parameter.var v) unused) + fun_decl.params + then begin + let stub, renamed_fun_id, additional_specialised_args = + make_stub unused fun_id fun_decl + ~specialised_args:set_of_closures.specialised_args + ~additional_specialised_args + in + let cleaned = + remove_params unused fun_decl ~new_fun_var:renamed_fun_id + in + Variable.Map.add fun_id stub + (Variable.Map.add renamed_fun_id cleaned funs), + additional_specialised_args + end + else + Variable.Map.add fun_id fun_decl funs, + additional_specialised_args + ) + function_decls.funs (Variable.Map.empty, Variable.Map.empty) + in + let specialised_args = + Variable.Map.disjoint_union additional_specialised_args + (Variable.Map.filter (fun param _ -> + not (Variable.Set.mem param unused)) + set_of_closures.specialised_args) + in + let specialised_args = + Flambda_utils.clean_projections ~which_variables:specialised_args + in + let function_decls = + Flambda.update_function_declarations function_decls ~funs + in + let set_of_closures = + Flambda.create_set_of_closures ~function_decls + ~free_vars:set_of_closures.free_vars ~specialised_args + (* CR-soon mshinwell: Use direct_call_surrogates for this + transformation. *) + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + in + Some set_of_closures + end + +(* Splitting is not always beneficial. For instance when a function + is only indirectly called, suppressing unused arguments does not + benefit, and introduce an useless intermediate call. Specialised + args should always be beneficial since they should not be used in + indirect calls. *) +let should_split_only_specialised_args + (fun_decls : Flambda.function_declarations) + ~backend = + if not !Clflags.remove_unused_arguments then begin + true + end else begin + let no_recursive_functions = + Variable.Set.is_empty + (Find_recursive_functions.in_function_declarations fun_decls ~backend) + in + let number_of_non_stub_functions = + Variable.Map.cardinal + (Variable.Map.filter (fun _ { Flambda.stub } -> not stub) + fun_decls.funs) + in + (* CR-soon lwhite: this criteria could use some justification. + mshinwell: pchambart cannot remember how these criteria arose, + but we're going to leave this as-is for 4.03. *) + no_recursive_functions && (number_of_non_stub_functions <= 1) + end + +let separate_unused_arguments_in_set_of_closures set_of_closures ~backend = + let dump = Clflags.dumped_pass pass_name in + let only_specialised = + should_split_only_specialised_args + set_of_closures.Flambda.function_decls + ~backend + in + match separate_unused_arguments + ~only_specialised ~backend ~set_of_closures with + | None -> + if dump then + Format.eprintf "No change for Remove_unused_arguments:@ %a@.@." + Flambda.print_set_of_closures set_of_closures; + None + | Some result -> + if dump then + Format.eprintf "Before Remove_unused_arguments:@ %a@.@.\ + After Remove_unused_arguments:@ %a@.@." + Flambda.print_set_of_closures set_of_closures + Flambda.print_set_of_closures result; + Some result + +let separate_unused_arguments_in_closures_expr tree ~backend = + let aux_named (named : Flambda.named) : Flambda.named = + match named with + | Set_of_closures set_of_closures -> begin + let only_specialised = + should_split_only_specialised_args + set_of_closures.function_decls + ~backend + in + match separate_unused_arguments + ~only_specialised ~backend ~set_of_closures with + | None -> named + | Some set_of_closures -> Set_of_closures set_of_closures + end + | e -> e + in + Flambda_iterators.map_named aux_named tree + +let separate_unused_arguments_in_closures program ~backend = + Flambda_iterators.map_exprs_at_toplevel_of_program program ~f:(fun expr -> + separate_unused_arguments_in_closures_expr expr ~backend) diff --git a/middle_end/flambda/remove_unused_arguments.mli b/middle_end/flambda/remove_unused_arguments.mli new file mode 100644 index 00000000..759b32f2 --- /dev/null +++ b/middle_end/flambda/remove_unused_arguments.mli @@ -0,0 +1,39 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Introduce a stub function to avoid depending on unused arguments. + + For instance, it turns + [let rec fact n unused = + if n = 0 then 1 + else n * fact (n-1) unused] + into + [let rec fact' n = + if n = 0 then 1 + else n * fact' (n-1) + and fact n unused = fact' n] +*) +val separate_unused_arguments_in_closures + : Flambda.program + -> backend:(module Backend_intf.S) + -> Flambda.program + +val separate_unused_arguments_in_set_of_closures + : Flambda.set_of_closures + -> backend:(module Backend_intf.S) + -> Flambda.set_of_closures option diff --git a/middle_end/flambda/remove_unused_closure_vars.ml b/middle_end/flambda/remove_unused_closure_vars.ml new file mode 100644 index 00000000..0d4ad621 --- /dev/null +++ b/middle_end/flambda/remove_unused_closure_vars.ml @@ -0,0 +1,125 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +(** A variable in a closure can either be used by the closure itself + or by an inlined version of the function. *) +let remove_unused_closure_variables ~remove_direct_call_surrogates program = + let used_vars_within_closure, used_closure_ids = + let used = Var_within_closure.Tbl.create 13 in + let used_fun = Closure_id.Tbl.create 13 in + let aux_named (named : Flambda.named) = + match named with + | Project_closure { set_of_closures = _; closure_id } -> + Closure_id.Tbl.add used_fun closure_id () + | Project_var { closure_id; var } -> + Var_within_closure.Tbl.add used var (); + Closure_id.Tbl.add used_fun closure_id () + | Move_within_set_of_closures { closure = _; start_from; move_to } -> + Closure_id.Tbl.add used_fun start_from (); + Closure_id.Tbl.add used_fun move_to () + | Symbol _ | Const _ | Set_of_closures _ | Prim _ | Expr _ + | Allocated_const _ | Read_mutable _ | Read_symbol_field _ -> () + in + Flambda_iterators.iter_named_of_program ~f:aux_named program; + used, used_fun + in + let aux_named _ (named : Flambda.named) : Flambda.named = + match named with + | Set_of_closures ({ function_decls; free_vars; _ } as set_of_closures) -> + let direct_call_surrogates = + if remove_direct_call_surrogates then Variable.Set.empty + else + Variable.Set.of_list + (Variable.Map.data set_of_closures.direct_call_surrogates) + in + let rec add_needed needed_funs remaining_funs free_vars_of_kept_funs = + let new_needed_funs, remaining_funs = + (* Keep a function if it is used either by the rest of the code, + (in used_closure_ids), or by any other kept function + (in free_vars_of_kept_funs) *) + Variable.Map.partition (fun fun_id _ -> + Variable.Set.mem fun_id free_vars_of_kept_funs + || Closure_id.Tbl.mem used_closure_ids + (Closure_id.wrap fun_id) + || Variable.Set.mem fun_id direct_call_surrogates) + remaining_funs + in + if Variable.Map.is_empty new_needed_funs then + (* If no new function is needed, we reached fixpoint *) + needed_funs, free_vars_of_kept_funs + else begin + let needed_funs = + Variable.Map.disjoint_union needed_funs new_needed_funs + in + let free_vars_of_kept_funs = + Variable.Map.fold (fun _ { Flambda. free_variables } acc -> + Variable.Set.union free_variables acc) + new_needed_funs + free_vars_of_kept_funs + in + add_needed needed_funs remaining_funs free_vars_of_kept_funs + end + in + let funs, free_vars_of_kept_funs = + add_needed Variable.Map.empty function_decls.funs Variable.Set.empty + in + let free_vars = + Variable.Map.filter (fun id _var -> + Variable.Set.mem id free_vars_of_kept_funs + || Var_within_closure.Tbl.mem + used_vars_within_closure + (Var_within_closure.wrap id)) + free_vars + in + let function_decls = + Flambda.update_function_declarations function_decls ~funs + in + let specialised_args = + (* Remove specialised args that are used by removed functions *) + let all_remaining_arguments = + Variable.Map.fold (fun _ { Flambda.params } set -> + Variable.Set.union set (Parameter.Set.vars params)) + funs Variable.Set.empty + in + Variable.Map.filter (fun arg _ -> + Variable.Set.mem arg all_remaining_arguments) + set_of_closures.specialised_args + in + let free_vars = + Flambda_utils.clean_projections ~which_variables:free_vars + in + let direct_call_surrogates = + (* Remove direct call surrogates where either the existing function + or the surrogate has been eliminated. *) + Variable.Map.fold (fun existing surrogate surrogates -> + if not (Variable.Map.mem existing funs) + || not (Variable.Map.mem surrogate funs) + then surrogates + else Variable.Map.add existing surrogate surrogates) + set_of_closures.direct_call_surrogates + Variable.Map.empty + in + let set_of_closures = + Flambda.create_set_of_closures ~function_decls + ~free_vars ~specialised_args ~direct_call_surrogates + in + Set_of_closures set_of_closures + | e -> e + in + Flambda_iterators.map_named_of_program ~f:aux_named program diff --git a/middle_end/flambda/remove_unused_closure_vars.mli b/middle_end/flambda/remove_unused_closure_vars.mli new file mode 100644 index 00000000..225697a8 --- /dev/null +++ b/middle_end/flambda/remove_unused_closure_vars.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(* CR-soon mshinwell: Rename this module. *) + +(** Eliminate variables bound by sets of closures that are not required. + Also eliminate functions within sets of closures that are not required. *) +val remove_unused_closure_variables + : remove_direct_call_surrogates:bool + -> Flambda.program + -> Flambda.program diff --git a/middle_end/flambda/remove_unused_program_constructs.ml b/middle_end/flambda/remove_unused_program_constructs.ml new file mode 100644 index 00000000..059d68bc --- /dev/null +++ b/middle_end/flambda/remove_unused_program_constructs.ml @@ -0,0 +1,111 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let dependency (expr:Flambda.t) = Flambda.free_symbols expr + +(* CR-soon pchambart: copied from lift_constant. Needs remerging *) +let constant_dependencies (const:Flambda.constant_defining_value) = + let closure_dependencies (set_of_closures:Flambda.set_of_closures) = + Flambda.free_symbols_named (Set_of_closures set_of_closures) + in + match const with + | Allocated_const _ -> Symbol.Set.empty + | Block (_, fields) -> + let symbol_fields = + List.filter_map (function + | (Symbol s : Flambda.constant_defining_value_block_field) -> + Some s + | Flambda.Const _ -> None) + fields + in + Symbol.Set.of_list symbol_fields + | Set_of_closures set_of_closures -> closure_dependencies set_of_closures + | Project_closure (s, _) -> Symbol.Set.singleton s + +let let_rec_dep defs dep = + let add_deps l dep = + List.fold_left (fun dep (sym, sym_dep) -> + if Symbol.Set.mem sym dep then Symbol.Set.union dep sym_dep + else dep) + dep l + in + let defs_deps = + List.map (fun (sym, def) -> sym, constant_dependencies def) defs + in + let rec fixpoint dep = + let new_dep = add_deps defs_deps dep in + if Symbol.Set.equal dep new_dep then dep + else fixpoint new_dep + in + fixpoint dep + +let rec loop (program : Flambda.program_body) + : Flambda.program_body * Symbol.Set.t = + match program with + | Let_symbol (sym, def, program) -> + let program, dep = loop program in + if Symbol.Set.mem sym dep then + Let_symbol (sym, def, program), + Symbol.Set.union dep (constant_dependencies def) + else + program, dep + | Let_rec_symbol (defs, program) -> + let program, dep = loop program in + let dep = let_rec_dep defs dep in + let defs = + List.filter (fun (sym, _) -> Symbol.Set.mem sym dep) defs + in begin match defs with + | [] -> program, dep + | _ -> Let_rec_symbol (defs, program), dep + end + | Initialize_symbol (sym, tag, fields, program) -> + let program, dep = loop program in + if Symbol.Set.mem sym dep then + let dep = + List.fold_left (fun dep field -> + Symbol.Set.union dep (dependency field)) + dep fields + in + Initialize_symbol (sym, tag, fields, program), dep + else begin + List.fold_left + (fun (program, dep) field -> + if Effect_analysis.no_effects field then + program, dep + else + let new_dep = dependency field in + let dep = Symbol.Set.union new_dep dep in + Flambda.Effect (field, program), dep) + (program, dep) fields + end + | Effect (effect, program) -> + let program, dep = loop program in + if Effect_analysis.no_effects effect then begin + program, dep + end else begin + let new_dep = dependency effect in + let dep = Symbol.Set.union new_dep dep in + Effect (effect, program), dep + end + | End symbol -> program, Symbol.Set.singleton symbol + +let remove_unused_program_constructs (program : Flambda.program) = + { program with + program_body = fst (loop program.program_body); + } diff --git a/middle_end/flambda/remove_unused_program_constructs.mli b/middle_end/flambda/remove_unused_program_constructs.mli new file mode 100644 index 00000000..3a722011 --- /dev/null +++ b/middle_end/flambda/remove_unused_program_constructs.mli @@ -0,0 +1,24 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(* Remove unused [Flambda.program] constructs from the given program. + - Symbols (whose defining expressions have no effects) are eliminated + if unused. + - [Effect] constructs that turn out to have no effects are eliminated. +*) +val remove_unused_program_constructs : Flambda.program -> Flambda.program diff --git a/middle_end/flambda/share_constants.ml b/middle_end/flambda/share_constants.ml new file mode 100644 index 00000000..2bbd7134 --- /dev/null +++ b/middle_end/flambda/share_constants.ml @@ -0,0 +1,130 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module Constant_defining_value = Flambda.Constant_defining_value + +let update_constant_for_sharing sharing_symbol_tbl const + : Flambda.constant_defining_value = + let substitute_symbol sym = + match Symbol.Tbl.find sharing_symbol_tbl sym with + | exception Not_found -> sym + | symbol -> symbol + in + match (const:Flambda.constant_defining_value) with + | Allocated_const _ -> const + | Block (tag, fields) -> + let subst_field (field:Flambda.constant_defining_value_block_field) : + Flambda.constant_defining_value_block_field = + match field with + | Const _ -> field + | Symbol sym -> + Symbol (substitute_symbol sym) + in + let fields = List.map subst_field fields in + Block (tag, fields) + | Set_of_closures set_of_closures -> + Set_of_closures ( + Flambda_iterators.map_symbols_on_set_of_closures + ~f:substitute_symbol set_of_closures + ) + | Project_closure (sym, closure_id) -> + Project_closure (substitute_symbol sym, closure_id) + +let cannot_share (const : Flambda.constant_defining_value) = + match const with + (* Strings and float arrays are mutable; we never share them. *) + | Allocated_const ((String _) | (Float_array _)) -> true + | Allocated_const _ | Set_of_closures _ | Project_closure _ | Block _ -> + false + +let share_definition constant_to_symbol_tbl sharing_symbol_tbl + symbol def end_symbol = + let def = update_constant_for_sharing sharing_symbol_tbl def in + if cannot_share def || Symbol.equal symbol end_symbol then + (* The symbol exported by the unit (end_symbol), cannot be removed + from the module. We prevent it from being shared to avoid that. *) + Some def + else + begin match Constant_defining_value.Tbl.find constant_to_symbol_tbl def with + | exception Not_found -> + Constant_defining_value.Tbl.add constant_to_symbol_tbl def symbol; + Some def + | equal_symbol -> + Symbol.Tbl.add sharing_symbol_tbl symbol equal_symbol; + None + end + +let rec end_symbol (program : Flambda.program_body) = + match program with + | End symbol -> symbol + | Let_symbol (_, _, program) + | Let_rec_symbol (_, program) + | Initialize_symbol (_, _, _, program) + | Effect (_, program) -> + end_symbol program + +let share_constants (program : Flambda.program) = + let end_symbol = end_symbol program.program_body in + let sharing_symbol_tbl = Symbol.Tbl.create 42 in + let constant_to_symbol_tbl = Constant_defining_value.Tbl.create 42 in + let rec loop (program : Flambda.program_body) : Flambda.program_body = + match program with + | Let_symbol (symbol,def,program) -> + begin match + share_definition constant_to_symbol_tbl sharing_symbol_tbl symbol + def end_symbol + with + | None -> + loop program + | Some def' -> + Let_symbol (symbol,def',loop program) + end + | Let_rec_symbol (defs,program) -> + let defs = + List.map (fun (symbol, def) -> + let def = update_constant_for_sharing sharing_symbol_tbl def in + symbol, def) + defs + in + Let_rec_symbol (defs, loop program) + | Initialize_symbol (symbol,tag,fields,program) -> + let fields = + List.map (fun field -> + Flambda_iterators.map_symbols + ~f:(fun symbol -> + try Symbol.Tbl.find sharing_symbol_tbl symbol with + | Not_found -> symbol) + field) + fields + in + Initialize_symbol (symbol,tag,fields,loop program) + | Effect (expr,program) -> + let expr = + Flambda_iterators.map_symbols + ~f:(fun symbol -> + try Symbol.Tbl.find sharing_symbol_tbl symbol with + | Not_found -> symbol) + expr + in + Effect (expr, loop program) + | End root -> End root + in + { program with + program_body = loop program.program_body; + } diff --git a/middle_end/flambda/share_constants.mli b/middle_end/flambda/share_constants.mli new file mode 100644 index 00000000..7fec22bc --- /dev/null +++ b/middle_end/flambda/share_constants.mli @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Share lifted constants that are eligible for sharing (e.g. not strings) + and have equal definitions. *) + +val share_constants : Flambda.program -> Flambda.program diff --git a/middle_end/flambda/simple_value_approx.ml b/middle_end/flambda/simple_value_approx.ml new file mode 100644 index 00000000..34fc5ce0 --- /dev/null +++ b/middle_end/flambda/simple_value_approx.ml @@ -0,0 +1,1043 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module U = Flambda_utils + +type 'a boxed_int = + | Int32 : int32 boxed_int + | Int64 : int64 boxed_int + | Nativeint : nativeint boxed_int + +type value_string = { + (* CR-soon mshinwell: use variant *) + contents : string option; (* None if unknown or mutable *) + size : int; +} + +type unresolved_value = + | Set_of_closures_id of Set_of_closures_id.t + | Symbol of Symbol.t + +type unknown_because_of = + | Unresolved_value of unresolved_value + | Other + +type t = { + descr : descr; + var : Variable.t option; + symbol : (Symbol.t * int option) option; +} + +and descr = + | Value_block of Tag.t * t array + | Value_int of int + | Value_char of char + | Value_constptr of int + | Value_float of float option + | Value_boxed_int : 'a boxed_int * 'a -> descr + | Value_set_of_closures of value_set_of_closures + | Value_closure of value_closure + | Value_string of value_string + | Value_float_array of value_float_array + | Value_unknown of unknown_because_of + | Value_bottom + | Value_extern of Export_id.t + | Value_symbol of Symbol.t + | Value_unresolved of unresolved_value + (* No description was found for this value *) + +and value_closure = { + set_of_closures : t; + closure_id : Closure_id.t; +} + +and function_declarations = { + is_classic_mode : bool; + set_of_closures_id : Set_of_closures_id.t; + set_of_closures_origin : Set_of_closures_origin.t; + funs : function_declaration Variable.Map.t; +} + +and function_body = { + free_variables : Variable.Set.t; + free_symbols : Symbol.Set.t; + stub : bool; + dbg : Debuginfo.t; + inline : Lambda.inline_attribute; + specialise : Lambda.specialise_attribute; + is_a_functor : bool; + body : Flambda.t; +} + +and function_declaration = { + closure_origin : Closure_origin.t; + params : Parameter.t list; + function_body : function_body option; +} + +and value_set_of_closures = { + function_decls : function_declarations; + bound_vars : t Var_within_closure.Map.t; + free_vars : Flambda.specialised_to Variable.Map.t; + invariant_params : Variable.Set.t Variable.Map.t Lazy.t; + recursive : Variable.Set.t Lazy.t; + size : int option Variable.Map.t Lazy.t; + specialised_args : Flambda.specialised_to Variable.Map.t; + freshening : Freshening.Project_var.t; + direct_call_surrogates : Closure_id.t Closure_id.Map.t; +} + +and value_float_array_contents = + | Contents of t array + | Unknown_or_mutable + +and value_float_array = { + contents : value_float_array_contents; + size : int; +} + +let descr t = t.descr + +let print_value_set_of_closures ppf + { function_decls = { funs }; invariant_params; freshening; size; _ } = + Format.fprintf ppf + "(set_of_closures:@ %a invariant_params=%a freshening=%a size=%a)" + (fun ppf -> Variable.Map.iter (fun id _ -> Variable.print ppf id)) funs + (Variable.Map.print Variable.Set.print) (Lazy.force invariant_params) + Freshening.Project_var.print freshening + (Variable.Map.print (fun ppf some_size -> + match some_size with + | None -> Format.fprintf ppf "None" + | Some size -> Format.fprintf ppf "Some %d" size)) + (Lazy.force size) + +let print_unresolved_value ppf = function + | Set_of_closures_id set -> + Format.fprintf ppf "Set_of_closures_id %a" Set_of_closures_id.print set + | Symbol symbol -> + Format.fprintf ppf "Symbol %a" Symbol.print symbol + +let print_function_declaration ppf var (f : function_declaration) = + let param ppf p = Variable.print ppf (Parameter.var p) in + let params ppf = List.iter (Format.fprintf ppf "@ %a" param) in + match f.function_body with + | None -> + Format.fprintf ppf "@[<2>(%a@ =@ fun@[<2>%a@])@]@ " + Variable.print var params f.params + | Some (b : function_body) -> + let stub = if b.stub then " *stub*" else "" in + let is_a_functor = if b.is_a_functor then " *functor*" else "" in + let inline = + match b.inline with + | Always_inline -> " *inline*" + | Never_inline -> " *never_inline*" + | Unroll _ -> " *unroll*" + | Default_inline -> "" + in + let specialise = + match b.specialise with + | Always_specialise -> " *specialise*" + | Never_specialise -> " *never_specialise*" + | Default_specialise -> "" + in + let print_body ppf _ = + Format.fprintf ppf "" + in + Format.fprintf ppf "@[<2>(%a%s%s%s%s@ =@ fun@[<2>%a@] ->@ @[<2><%a>@])@]@ " + Variable.print var stub is_a_functor inline specialise + params f.params + print_body b + +let print_function_declarations ppf (fd : function_declarations) = + let funs ppf = Variable.Map.iter (print_function_declaration ppf) in + Format.fprintf ppf "@[<2>(%a)@]" funs fd.funs + +let rec print_descr ppf = function + | Value_int i -> Format.pp_print_int ppf i + | Value_char c -> Format.fprintf ppf "%c" c + | Value_constptr i -> Format.fprintf ppf "%ia" i + | Value_block (tag,fields) -> + let p ppf fields = + Array.iter (fun v -> Format.fprintf ppf "%a@ " print v) fields in + Format.fprintf ppf "[%i:@ @[<1>%a@]]" (Tag.to_int tag) p fields + | Value_unknown reason -> + begin match reason with + | Unresolved_value value -> + Format.fprintf ppf "?(due to unresolved %a)" print_unresolved_value value + | Other -> Format.fprintf ppf "?" + end; + | Value_bottom -> Format.fprintf ppf "bottom" + | Value_extern id -> Format.fprintf ppf "_%a_" Export_id.print id + | Value_symbol sym -> Format.fprintf ppf "%a" Symbol.print sym + | Value_closure { set_of_closures; closure_id; } -> + Format.fprintf ppf "(closure:@ %a from@ %a)" Closure_id.print closure_id + print set_of_closures + | Value_set_of_closures set_of_closures -> + print_value_set_of_closures ppf set_of_closures + | Value_unresolved value -> + Format.fprintf ppf "(unresolved %a)" print_unresolved_value value + | Value_float (Some f) -> Format.pp_print_float ppf f + | Value_float None -> Format.pp_print_string ppf "float" + | Value_string { contents; size } -> begin + match contents with + | None -> + Format.fprintf ppf "string %i" size + | Some s -> + let s = + if size > 10 + then String.sub s 0 8 ^ "..." + else s + in + Format.fprintf ppf "string %i %S" size s + end + | Value_float_array float_array -> + begin match float_array.contents with + | Unknown_or_mutable -> + Format.fprintf ppf "float_array %i" float_array.size + | Contents _ -> + Format.fprintf ppf "float_array_imm %i" float_array.size + end + | Value_boxed_int (t, i) -> + match t with + | Int32 -> Format.fprintf ppf "%li" i + | Int64 -> Format.fprintf ppf "%Li" i + | Nativeint -> Format.fprintf ppf "%ni" i + +and print ppf { descr; var; symbol; } = + let print ppf = function + | None -> Symbol.print_opt ppf None + | Some (sym, None) -> Symbol.print ppf sym + | Some (sym, Some field) -> + Format.fprintf ppf "%a.(%i)" Symbol.print sym field + in + Format.fprintf ppf "{ descr=%a var=%a symbol=%a }" + print_descr descr + Variable.print_opt var + print symbol + +let approx descr = { descr; var = None; symbol = None } + +let augment_with_variable t var = { t with var = Some var } +let augment_with_symbol t symbol = { t with symbol = Some (symbol, None) } +let augment_with_symbol_field t symbol field = + match t.symbol with + | None -> { t with symbol = Some (symbol, Some field) } + | Some _ -> t +let replace_description t descr = { t with descr } + +let augment_with_kind t (kind:Lambda.value_kind) = + match kind with + | Pgenval -> t + | Pfloatval -> + begin match t.descr with + | Value_float _ -> + t + | Value_unknown _ | Value_unresolved _ -> + { t with descr = Value_float None } + | Value_block _ + | Value_int _ + | Value_char _ + | Value_constptr _ + | Value_boxed_int _ + | Value_set_of_closures _ + | Value_closure _ + | Value_string _ + | Value_float_array _ + | Value_bottom -> + (* Unreachable *) + { t with descr = Value_bottom } + | Value_extern _ | Value_symbol _ -> + (* We don't know yet *) + t + end + | _ -> t + +let augment_kind_with_approx t (kind:Lambda.value_kind) : Lambda.value_kind = + match t.descr with + | Value_float _ -> Pfloatval + | Value_int _ -> Pintval + | Value_boxed_int (Int32, _) -> Pboxedintval Pint32 + | Value_boxed_int (Int64, _) -> Pboxedintval Pint64 + | Value_boxed_int (Nativeint, _) -> Pboxedintval Pnativeint + | _ -> kind + +let value_unknown reason = approx (Value_unknown reason) +let value_int i = approx (Value_int i) +let value_char i = approx (Value_char i) +let value_constptr i = approx (Value_constptr i) +let value_float f = approx (Value_float (Some f)) +let value_any_float = approx (Value_float None) +let value_boxed_int bi i = approx (Value_boxed_int (bi,i)) + +let value_closure ?closure_var ?set_of_closures_var ?set_of_closures_symbol + value_set_of_closures closure_id = + let approx_set_of_closures = + { descr = Value_set_of_closures value_set_of_closures; + var = set_of_closures_var; + symbol = Misc.may_map (fun s -> s, None) set_of_closures_symbol; + } + in + let value_closure = + { set_of_closures = approx_set_of_closures; + closure_id; + } + in + { descr = Value_closure value_closure; + var = closure_var; + symbol = None; + } + +let create_value_set_of_closures + ~(function_decls : function_declarations) ~bound_vars ~free_vars + ~invariant_params ~recursive ~specialised_args ~freshening + ~direct_call_surrogates = + let size = + lazy ( + let functions = Variable.Map.keys function_decls.funs in + Variable.Map.fold + (fun fun_var function_decl sizes -> + match function_decl.function_body with + | None -> sizes + | Some function_body -> + let params = Parameter.Set.vars function_decl.params in + let free_vars = + Variable.Set.diff + (Variable.Set.diff function_body.free_variables params) + functions + in + let num_free_vars = Variable.Set.cardinal free_vars in + let max_size = + Inlining_cost.maximum_interesting_size_of_function_body + num_free_vars + in + let size = + Inlining_cost.lambda_smaller' function_body.body ~than:max_size + in + Variable.Map.add fun_var size sizes) + function_decls.funs Variable.Map.empty) + in + { function_decls; + bound_vars; + free_vars; + invariant_params; + recursive; + size; + specialised_args; + freshening; + direct_call_surrogates; + } + +let update_freshening_of_value_set_of_closures value_set_of_closures + ~freshening = + (* CR-someday mshinwell: We could maybe check that [freshening] is + reasonable. *) + { value_set_of_closures with freshening; } + +let value_set_of_closures ?set_of_closures_var value_set_of_closures = + { descr = Value_set_of_closures value_set_of_closures; + var = set_of_closures_var; + symbol = None; + } + +let value_block t b = approx (Value_block (t, b)) +let value_extern ex = approx (Value_extern ex) +let value_symbol sym = + { (approx (Value_symbol sym)) with symbol = Some (sym, None) } +let value_bottom = approx Value_bottom +let value_unresolved value = approx (Value_unresolved value) + +let value_string size contents = approx (Value_string {size; contents }) +let value_mutable_float_array ~size = + approx (Value_float_array { contents = Unknown_or_mutable; size; } ) +let value_immutable_float_array (contents:t array) = + let size = Array.length contents in + let contents = + Array.map (fun t -> augment_with_kind t Pfloatval) contents + in + approx (Value_float_array { contents = Contents contents; size; } ) + +let name_expr_fst (named, thing) ~name = + (Flambda_utils.name_expr named ~name), thing + +let make_const_int_named n : Flambda.named * t = + Const (Int n), value_int n +let make_const_int (n : int) = + let name = + match n with + | 0 -> Internal_variable_names.const_zero + | 1 -> Internal_variable_names.const_one + | _ -> Internal_variable_names.const_int + in + name_expr_fst (make_const_int_named n) ~name + +let make_const_char_named n : Flambda.named * t = + Const (Char n), value_char n +let make_const_char n = + let name = Internal_variable_names.const_char in + name_expr_fst (make_const_char_named n) ~name + +let make_const_ptr_named n : Flambda.named * t = + Const (Const_pointer n), value_constptr n +let make_const_ptr (n : int) = + let name = + match n with + | 0 -> Internal_variable_names.const_ptr_zero + | 1 -> Internal_variable_names.const_ptr_one + | _ -> Internal_variable_names.const_ptr + in + name_expr_fst (make_const_ptr_named n) ~name + +let make_const_bool_named b : Flambda.named * t = + make_const_ptr_named (if b then 1 else 0) +let make_const_bool b = + name_expr_fst (make_const_bool_named b) + ~name:Internal_variable_names.const_bool + +let make_const_float_named f : Flambda.named * t = + Allocated_const (Float f), value_float f +let make_const_float f = + name_expr_fst (make_const_float_named f) + ~name:Internal_variable_names.const_float + +let make_const_boxed_int_named (type bi) (t:bi boxed_int) (i:bi) + : Flambda.named * t = + let c : Allocated_const.t = + match t with + | Int32 -> Int32 i + | Int64 -> Int64 i + | Nativeint -> Nativeint i + in + Allocated_const c, value_boxed_int t i +let make_const_boxed_int t i = + name_expr_fst (make_const_boxed_int_named t i) + ~name:Internal_variable_names.const_boxed_int + +type simplification_summary = + | Nothing_done + | Replaced_term + +type simplification_result = Flambda.t * simplification_summary * t +type simplification_result_named = Flambda.named * simplification_summary * t + +let simplify t (lam : Flambda.t) : simplification_result = + if Effect_analysis.no_effects lam then + match t.descr with + | Value_int n -> + let const, approx = make_const_int n in + const, Replaced_term, approx + | Value_char n -> + let const, approx = make_const_char n in + const, Replaced_term, approx + | Value_constptr n -> + let const, approx = make_const_ptr n in + const, Replaced_term, approx + | Value_float (Some f) -> + let const, approx = make_const_float f in + const, Replaced_term, approx + | Value_boxed_int (t, i) -> + let const, approx = make_const_boxed_int t i in + const, Replaced_term, approx + | Value_symbol sym -> + let name = Internal_variable_names.symbol in + U.name_expr (Symbol sym) ~name, Replaced_term, t + | Value_string _ | Value_float_array _ | Value_float None + | Value_block _ | Value_set_of_closures _ | Value_closure _ + | Value_unknown _ | Value_bottom | Value_extern _ | Value_unresolved _ -> + lam, Nothing_done, t + else + lam, Nothing_done, t + +let simplify_named t (named : Flambda.named) : simplification_result_named = + if Effect_analysis.no_effects_named named then + match t.descr with + | Value_int n -> + let const, approx = make_const_int_named n in + const, Replaced_term, approx + | Value_char n -> + let const, approx = make_const_char_named n in + const, Replaced_term, approx + | Value_constptr n -> + let const, approx = make_const_ptr_named n in + const, Replaced_term, approx + | Value_float (Some f) -> + let const, approx = make_const_float_named f in + const, Replaced_term, approx + | Value_boxed_int (t, i) -> + let const, approx = make_const_boxed_int_named t i in + const, Replaced_term, approx + | Value_symbol sym -> + Symbol sym, Replaced_term, t + | Value_string _ | Value_float_array _ | Value_float None + | Value_block _ | Value_set_of_closures _ | Value_closure _ + | Value_unknown _ | Value_bottom | Value_extern _ | Value_unresolved _ -> + named, Nothing_done, t + else + named, Nothing_done, t + +(* CR-soon mshinwell: bad name. This function and its call site in + [Inline_and_simplify] is also messy. *) +let simplify_var t : (Flambda.named * t) option = + match t.descr with + | Value_int n -> Some (make_const_int_named n) + | Value_char n -> Some (make_const_char_named n) + | Value_constptr n -> Some (make_const_ptr_named n) + | Value_float (Some f) -> Some (make_const_float_named f) + | Value_boxed_int (t, i) -> Some (make_const_boxed_int_named t i) + | Value_symbol sym -> Some (Symbol sym, t) + | Value_string _ | Value_float_array _ | Value_float None + | Value_block _ | Value_set_of_closures _ | Value_closure _ + | Value_unknown _ | Value_bottom | Value_extern _ + | Value_unresolved _ -> + match t.symbol with + | Some (sym, None) -> Some (Symbol sym, t) + | Some (sym, Some field) -> Some (Read_symbol_field (sym, field), t) + | None -> None + +let join_summaries summary ~replaced_by_var_or_symbol = + match replaced_by_var_or_symbol, summary with + | true, Nothing_done + | true, Replaced_term + | false, Replaced_term -> Replaced_term + | false, Nothing_done -> Nothing_done + +let simplify_using_env t ~is_present_in_env flam = + let replaced_by_var_or_symbol, flam = + match t.var with + | Some var when is_present_in_env var -> true, Flambda.Var var + | _ -> + match t.symbol with + | Some (sym, None) -> + let name = Internal_variable_names.symbol in + (true, U.name_expr (Symbol sym) ~name) + | Some (sym, Some field) -> + let name = Internal_variable_names.symbol_field in + (true, U.name_expr (Read_symbol_field (sym, field)) ~name) + | None -> false, flam + in + let const, summary, approx = simplify t flam in + const, join_summaries summary ~replaced_by_var_or_symbol, approx + +let simplify_named_using_env t ~is_present_in_env named = + let replaced_by_var_or_symbol, named = + match t.var with + | Some var when is_present_in_env var -> + true, Flambda.Expr (Var var) + | _ -> + match t.symbol with + | Some (sym, None) -> true, (Flambda.Symbol sym:Flambda.named) + | Some (sym, Some field) -> + true, Flambda.Read_symbol_field (sym, field) + | None -> false, named + in + let const, summary, approx = simplify_named t named in + const, join_summaries summary ~replaced_by_var_or_symbol, approx + +let simplify_var_to_var_using_env t ~is_present_in_env = + match t.var with + | Some var when is_present_in_env var -> Some var + | _ -> None + +let known t = + match t.descr with + | Value_unresolved _ + | Value_unknown _ -> false + | Value_string _ | Value_float_array _ + | Value_bottom | Value_block _ | Value_int _ | Value_char _ + | Value_constptr _ | Value_set_of_closures _ | Value_closure _ + | Value_extern _ | Value_float _ | Value_boxed_int _ | Value_symbol _ -> true + +let useful t = + match t.descr with + | Value_unresolved _ | Value_unknown _ | Value_bottom -> false + | Value_string _ | Value_float_array _ | Value_block _ | Value_int _ + | Value_char _ | Value_constptr _ | Value_set_of_closures _ + | Value_float _ | Value_boxed_int _ | Value_closure _ | Value_extern _ + | Value_symbol _ -> true + +let all_not_useful ts = List.for_all (fun t -> not (useful t)) ts + +let warn_on_mutation t = + match t.descr with + | Value_block(_, fields) -> Array.length fields > 0 + | Value_string { contents = Some _ } + | Value_int _ | Value_char _ | Value_constptr _ + | Value_set_of_closures _ | Value_float _ | Value_boxed_int _ + | Value_closure _ -> true + | Value_string { contents = None } | Value_float_array _ + | Value_unresolved _ | Value_unknown _ | Value_bottom -> false + | Value_extern _ | Value_symbol _ -> assert false + +type get_field_result = + | Ok of t + | Unreachable + +let get_field t ~field_index:i : get_field_result = + match t.descr with + | Value_block (_tag, fields) -> + if i >= 0 && i < Array.length fields then begin + Ok fields.(i) + end else begin + (* This (unfortunately) cannot be a fatal error; it can happen if a + .cmx file is missing. However for debugging the compiler this can + be a useful point to put a [Misc.fatal_errorf]. *) + Unreachable + end + (* CR-someday mshinwell: This should probably return Unreachable in more + cases. I added a couple more. *) + | Value_bottom + | Value_int _ | Value_char _ | Value_constptr _ -> + (* Something seriously wrong is happening: either the user is doing + something exceptionally unsafe, or it is an unreachable branch. + We consider this as unreachable and mark the result accordingly. *) + Ok value_bottom + | Value_float_array _ -> + (* For the moment we return "unknown" even for immutable arrays, since + it isn't possible for user code to project from an immutable array. *) + (* CR-someday mshinwell: If Leo's array's patch lands, then we can + change this, although it's probably not Pfield that is used to + do the projection. *) + Ok (value_unknown Other) + | Value_string _ | Value_float _ | Value_boxed_int _ -> + (* The user is doing something unsafe. *) + Unreachable + | Value_set_of_closures _ | Value_closure _ + (* This is used by [CamlinternalMod]. *) + | Value_symbol _ | Value_extern _ -> + (* These should have been resolved. *) + Ok (value_unknown Other) + | Value_unknown reason -> + Ok (value_unknown reason) + | Value_unresolved value -> + (* We don't know anything, but we must remember that it comes + from another compilation unit in case it contains a closure. *) + Ok (value_unknown (Unresolved_value value)) + +type checked_approx_for_block = + | Wrong + | Ok of Tag.t * t array + +let check_approx_for_block t = + match t.descr with + | Value_block (tag, fields) -> + Ok (tag, fields) + | Value_bottom + | Value_int _ | Value_char _ | Value_constptr _ + | Value_float_array _ + | Value_string _ | Value_float _ | Value_boxed_int _ + | Value_set_of_closures _ | Value_closure _ + | Value_symbol _ | Value_extern _ + | Value_unknown _ + | Value_unresolved _ -> + Wrong + +let descrs approxs = List.map (fun v -> v.descr) approxs + +let equal_boxed_int (type t1) (type t2) + (bi1:t1 boxed_int) (i1:t1) + (bi2:t2 boxed_int) (i2:t2) = + match bi1, bi2 with + | Int32, Int32 -> Int32.equal i1 i2 + | Int64, Int64 -> Int64.equal i1 i2 + | Nativeint, Nativeint -> Nativeint.equal i1 i2 + | _ -> false + +let equal_floats f1 f2 = + match f1, f2 with + | None, None -> true + | None, Some _ | Some _, None -> false + | Some f1, Some f2 -> Allocated_const.compare_floats f1 f2 = 0 + +(* Closures and set of closures descriptions cannot be merged. + + let f x = + let g y -> x + y in + g + in + let v = + if ... + then f 1 + else f 2 + in + v 3 + + The approximation for [f 1] and [f 2] could both contain the + description of [g]. But if [f] where inlined, a new [g] would + be created in each branch, leading to incompatible description. + And we must never make the description for a function less + precise that it used to be: its information are needed for + rewriting [Project_var] and [Project_closure] constructions + in [Flambdainline.loop] +*) +let rec meet_descr ~really_import_approx d1 d2 = match d1, d2 with + | Value_int i, Value_int j when i = j -> + d1 + | Value_constptr i, Value_constptr j when i = j -> + d1 + | Value_symbol s1, Value_symbol s2 when Symbol.equal s1 s2 -> + d1 + | Value_extern e1, Value_extern e2 when Export_id.equal e1 e2 -> + d1 + | Value_float i, Value_float j when equal_floats i j -> + d1 + | Value_boxed_int (bi1, i1), Value_boxed_int (bi2, i2) when + equal_boxed_int bi1 i1 bi2 i2 -> + d1 + | Value_block (tag1, a1), Value_block (tag2, a2) + when Tag.compare tag1 tag2 = 0 && Array.length a1 = Array.length a2 -> + let fields = + Array.mapi (fun i v -> meet ~really_import_approx v a2.(i)) a1 + in + Value_block (tag1, fields) + | _ -> Value_unknown Other + +and meet ~really_import_approx a1 a2 = + match a1, a2 with + | { descr = Value_bottom }, a + | a, { descr = Value_bottom } -> a + | { descr = (Value_symbol _ | Value_extern _) }, _ + | _, { descr = (Value_symbol _ | Value_extern _) } -> + meet ~really_import_approx + (really_import_approx a1) (really_import_approx a2) + | _ -> + let var = + match a1.var, a2.var with + | None, _ | _, None -> None + | Some v1, Some v2 -> + if Variable.equal v1 v2 + then Some v1 + else None + in + let symbol = + match a1.symbol, a2.symbol with + | None, _ | _, None -> None + | Some (v1, field1), Some (v2, field2) -> + if Symbol.equal v1 v2 + then match field1, field2 with + | None, None -> a1.symbol + | Some f1, Some f2 when f1 = f2 -> + a1.symbol + | _ -> None + else None + in + { descr = meet_descr ~really_import_approx a1.descr a2.descr; + var; + symbol } + +(* Given a set-of-closures approximation and a closure ID, apply any + freshening specified in the approximation to the closure ID, and return + that new closure ID. A fatal error is produced if the new closure ID + does not correspond to a function declaration in the given approximation. *) +let freshen_and_check_closure_id + (value_set_of_closures : value_set_of_closures) closure_id = + let closure_id = + Freshening.Project_var.apply_closure_id + value_set_of_closures.freshening closure_id + in + try + ignore ( + Variable.Map.find (Closure_id.unwrap closure_id) + value_set_of_closures.function_decls.funs + ); + closure_id + with Not_found -> + Misc.fatal_error (Format.asprintf + "Function %a not found in the set of closures@ %a@.%a@." + Closure_id.print closure_id + print_value_set_of_closures value_set_of_closures + print_function_declarations value_set_of_closures.function_decls) + +type checked_approx_for_set_of_closures = + | Wrong + | Unresolved of unresolved_value + | Unknown + | Unknown_because_of_unresolved_value of unresolved_value + | Ok of Variable.t option * value_set_of_closures + +let check_approx_for_set_of_closures t : checked_approx_for_set_of_closures = + match t.descr with + | Value_unresolved value -> Unresolved value + | Value_unknown (Unresolved_value value) -> + Unknown_because_of_unresolved_value value + | Value_set_of_closures value_set_of_closures -> + (* Note that [var] might be [None]; we might be reaching the set of + closures via approximations only, with the variable originally bound + to the set now out of scope. *) + Ok (t.var, value_set_of_closures) + | Value_closure _ | Value_block _ | Value_int _ | Value_char _ + | Value_constptr _ | Value_float _ | Value_boxed_int _ | Value_unknown _ + | Value_bottom | Value_extern _ | Value_string _ | Value_float_array _ + | Value_symbol _ -> + Wrong + +type strict_checked_approx_for_set_of_closures = + | Wrong + | Ok of Variable.t option * value_set_of_closures + +let strict_check_approx_for_set_of_closures t + : strict_checked_approx_for_set_of_closures = + match check_approx_for_set_of_closures t with + | Ok (var, value_set_of_closures) -> Ok (var, value_set_of_closures) + | Wrong | Unresolved _ + | Unknown | Unknown_because_of_unresolved_value _ -> Wrong + +type checked_approx_for_closure_allowing_unresolved = + | Wrong + | Unresolved of unresolved_value + | Unknown + | Unknown_because_of_unresolved_value of unresolved_value + | Ok of value_closure * Variable.t option + * Symbol.t option * value_set_of_closures + +let check_approx_for_closure_allowing_unresolved t + : checked_approx_for_closure_allowing_unresolved = + match t.descr with + | Value_closure value_closure -> + begin match value_closure.set_of_closures.descr with + | Value_set_of_closures value_set_of_closures -> + let symbol = match value_closure.set_of_closures.symbol with + | Some (symbol, None) -> Some symbol + | None | Some (_, Some _) -> None + in + Ok (value_closure, value_closure.set_of_closures.var, + symbol, value_set_of_closures) + | Value_unresolved _ + | Value_closure _ | Value_block _ | Value_int _ | Value_char _ + | Value_constptr _ | Value_float _ | Value_boxed_int _ | Value_unknown _ + | Value_bottom | Value_extern _ | Value_string _ | Value_float_array _ + | Value_symbol _ -> + Wrong + end + | Value_unknown (Unresolved_value value) -> + Unknown_because_of_unresolved_value value + | Value_unresolved symbol -> Unresolved symbol + | Value_set_of_closures _ | Value_block _ | Value_int _ | Value_char _ + | Value_constptr _ | Value_float _ | Value_boxed_int _ + | Value_bottom | Value_extern _ | Value_string _ | Value_float_array _ + | Value_symbol _ -> + Wrong + (* CR-soon mshinwell: This should be unwound once the reason for a value + being unknown can be correctly propagated through the export info. *) + | Value_unknown Other -> Unknown + +type checked_approx_for_closure = + | Wrong + | Ok of value_closure * Variable.t option + * Symbol.t option * value_set_of_closures + +let check_approx_for_closure t : checked_approx_for_closure = + match check_approx_for_closure_allowing_unresolved t with + | Ok (value_closure, set_of_closures_var, set_of_closures_symbol, + value_set_of_closures) -> + Ok (value_closure, set_of_closures_var, set_of_closures_symbol, + value_set_of_closures) + | Wrong | Unknown | Unresolved _ | Unknown_because_of_unresolved_value _ -> + Wrong + +let approx_for_bound_var value_set_of_closures var = + try + Var_within_closure.Map.find var value_set_of_closures.bound_vars + with + | Not_found -> + Misc.fatal_errorf "The set-of-closures approximation %a@ does not \ + bind the variable %a@.%s@." + print_value_set_of_closures value_set_of_closures + Var_within_closure.print var + (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int)) + +let check_approx_for_float t : float option = + match t.descr with + | Value_float f -> f + | Value_unresolved _ + | Value_unknown _ | Value_string _ | Value_float_array _ + | Value_bottom | Value_block _ | Value_int _ | Value_char _ + | Value_constptr _ | Value_set_of_closures _ | Value_closure _ + | Value_extern _ | Value_boxed_int _ | Value_symbol _ -> + None + +let float_array_as_constant (t:value_float_array) : float list option = + match t.contents with + | Unknown_or_mutable -> None + | Contents contents -> + Array.fold_right (fun elt acc -> + match acc, elt.descr with + | Some acc, Value_float (Some f) -> + Some (f :: acc) + | None, _ + | Some _, + (Value_float None | Value_unresolved _ + | Value_unknown _ | Value_string _ | Value_float_array _ + | Value_bottom | Value_block _ | Value_int _ | Value_char _ + | Value_constptr _ | Value_set_of_closures _ | Value_closure _ + | Value_extern _ | Value_boxed_int _ | Value_symbol _) + -> None) + contents (Some []) + +let check_approx_for_string t : string option = + match t.descr with + | Value_string { contents } -> contents + | Value_float _ + | Value_unresolved _ + | Value_unknown _ | Value_float_array _ + | Value_bottom | Value_block _ | Value_int _ | Value_char _ + | Value_constptr _ | Value_set_of_closures _ | Value_closure _ + | Value_extern _ | Value_boxed_int _ | Value_symbol _ -> + None + +type switch_branch_selection = + | Cannot_be_taken + | Can_be_taken + | Must_be_taken + +let potentially_taken_const_switch_branch t branch = + match t.descr with + | Value_unresolved _ + | Value_unknown _ + | Value_extern _ + | Value_symbol _ -> + (* In theory symbol cannot contain integers but this shouldn't + matter as this will always be an imported approximation *) + Can_be_taken + | Value_constptr i | Value_int i when i = branch -> + Must_be_taken + | Value_char c when Char.code c = branch -> + Must_be_taken + | Value_constptr _ | Value_int _ | Value_char _ -> + Cannot_be_taken + | Value_block _ | Value_float _ | Value_float_array _ + | Value_string _ | Value_closure _ | Value_set_of_closures _ + | Value_boxed_int _ | Value_bottom -> + Cannot_be_taken + +let potentially_taken_block_switch_branch t tag = + match t.descr with + | (Value_unresolved _ + | Value_unknown _ + | Value_extern _ + | Value_symbol _) -> + Can_be_taken + | (Value_constptr _ | Value_int _| Value_char _) -> + Cannot_be_taken + | Value_block (block_tag, _) when Tag.to_int block_tag = tag -> + Must_be_taken + | Value_float _ when tag = Obj.double_tag -> + Must_be_taken + | Value_float_array _ when tag = Obj.double_array_tag -> + Must_be_taken + | Value_string _ when tag = Obj.string_tag -> + Must_be_taken + | (Value_closure _ | Value_set_of_closures _) + when tag = Obj.closure_tag || tag = Obj.infix_tag -> + Can_be_taken + | Value_boxed_int _ when tag = Obj.custom_tag -> + Must_be_taken + | Value_block _ | Value_float _ | Value_set_of_closures _ | Value_closure _ + | Value_string _ | Value_float_array _ | Value_boxed_int _ -> + Cannot_be_taken + | Value_bottom -> + Cannot_be_taken + +let function_arity (fun_decl : function_declaration) = + List.length fun_decl.params + +let function_declaration_approx ~keep_body fun_var + (fun_decl : Flambda.function_declaration) = + let function_body = + if not (keep_body fun_var fun_decl) then None + else begin + Some { body = fun_decl.body; + stub = fun_decl.stub; + inline = fun_decl.inline; + dbg = fun_decl.dbg; + specialise = fun_decl.specialise; + is_a_functor = fun_decl.is_a_functor; + free_variables = fun_decl.free_variables; + free_symbols = fun_decl.free_symbols; } + end + in + { function_body; + params = fun_decl.params; + closure_origin = fun_decl.closure_origin; } + +let function_declarations_approx ~keep_body + (fun_decls : Flambda.function_declarations) = + let funs = + Variable.Map.mapi (function_declaration_approx ~keep_body) fun_decls.funs + in + { funs; + is_classic_mode = fun_decls.is_classic_mode; + set_of_closures_id = fun_decls.set_of_closures_id; + set_of_closures_origin = fun_decls.set_of_closures_origin; } + +let import_function_declarations_for_pack function_decls + import_set_of_closures_id import_set_of_closures_origin = + { set_of_closures_id = + import_set_of_closures_id function_decls.set_of_closures_id; + set_of_closures_origin = + import_set_of_closures_origin function_decls.set_of_closures_origin; + funs = function_decls.funs; + is_classic_mode = function_decls.is_classic_mode; + } + +let update_function_declarations function_decls ~funs = + let compilation_unit = Compilation_unit.get_current_exn () in + let is_classic_mode = function_decls.is_classic_mode in + let set_of_closures_id = Set_of_closures_id.create compilation_unit in + let set_of_closures_origin = function_decls.set_of_closures_origin in + { is_classic_mode; + set_of_closures_id; + set_of_closures_origin; + funs; + } + +let clear_function_bodies (function_decls : function_declarations) = + let funs = + Variable.Map.map (fun (fun_decl : function_declaration) -> + match fun_decl.function_body with + | None | Some { stub = true; _ } -> + fun_decl + | Some _ -> + { fun_decl with function_body = None }) + function_decls.funs + in + { function_decls with funs } + +let update_function_declaration_body + (function_decl : function_declaration) + (f : Flambda.t -> Flambda.t) = + match function_decl.function_body with + | None -> function_decl + | Some function_body -> + let new_function_body = + let body = f function_body.body in + let free_variables = Flambda.free_variables body in + let free_symbols = Flambda.free_symbols body in + { function_body with free_variables; free_symbols; body; } + in + { function_decl with function_body = Some new_function_body } + +let make_closure_map input = + let map = ref Closure_id.Map.empty in + let add_set_of_closures _ (function_decls : function_declarations) = + Variable.Map.iter (fun var _ -> + let closure_id = Closure_id.wrap var in + map := Closure_id.Map.add closure_id function_decls !map) + function_decls.funs + in + Set_of_closures_id.Map.iter add_set_of_closures input; + !map diff --git a/middle_end/flambda/simple_value_approx.mli b/middle_end/flambda/simple_value_approx.mli new file mode 100644 index 00000000..dd38652f --- /dev/null +++ b/middle_end/flambda/simple_value_approx.mli @@ -0,0 +1,501 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Simple approximations to the runtime results of computations. + This pass is designed for speed rather than accuracy; the performance + is important since it is used heavily during inlining. *) + +type 'a boxed_int = + | Int32 : int32 boxed_int + | Int64 : int64 boxed_int + | Nativeint : nativeint boxed_int + +type value_string = { + contents : string option; (* [None] if unknown or mutable *) + size : int; +} + +type unresolved_value = + | Set_of_closures_id of Set_of_closures_id.t + | Symbol of Symbol.t + +type unknown_because_of = + | Unresolved_value of unresolved_value + | Other + +(** A value of type [t] corresponds to an "approximation" of the result of + a computation in the program being compiled. That is to say, it + represents what knowledge we have about such a result at compile time. + The simplification pass exploits this information to partially evaluate + computations. + + At a high level, an approximation for a value [v] has three parts: + - the "description" (for example, "the constant integer 42"); + - an optional variable; + - an optional symbol or symbol field. + If the variable (resp. symbol) is present then that variable (resp. + symbol) may be used to obtain the value [v]. + + The exact semantics of the variable and symbol fields follows. + + Approximations are deduced at particular points in an expression tree, + but may subsequently be propagated to other locations. + + At the point at which an approximation is built for some value [v], we can + construct a set of variables (call the set [S]) that are known to alias the + same value [v]. Each member of [S] will have the same or a more precise + [descr] field in its approximation relative to the approximation for [v]. + (An increase in precision may currently be introduced for pattern + matches.) If [S] is non-empty then it is guaranteed that there is a + unique member of [S] that was declared in a scope further out ("earlier") + than all other members of [S]. If such a member exists then it is + recorded in the [var] field. Otherwise [var] is [None]. + + Analogous to the construction of the set [S], we can construct a set [T] + consisting of all symbols that are known to alias the value whose + approximation is being constructed. If [T] is non-empty then the + [symbol] field is set to some member of [T]; it does not matter which + one. (There is no notion of scope for symbols.) + + Note about mutable blocks: + + Mutable blocks are always represented by [Value_unknown] or + [Value_bottom]. Any other approximation could leave the door open to + a miscompilation. Such bad scenarios are most likely a user using + [Obj.magic] or [Obj.set_field] in an inappropriate situation. + Such a situation might be: + [let x = (1, 1) in + Obj.set_field (Obj.repr x) 0 (Obj.repr 2); + assert(fst x = 2)] + The user would probably expect the assertion to be true, but the + compiler could in fact propagate the value of [x] across the + [Obj.set_field]. + + Insisting that mutable blocks have [Value_unknown] or [Value_bottom] + approximations certainly won't always prevent this kind of error, but + should help catch many of them. + + It is possible that there may be some false positives, with correct + but unreachable code causing this check to fail. However the likelihood + of this seems sufficiently low, especially compared to the advantages + gained by performing the check, that we include it. + + An example of a pattern that might trigger a false positive is: + [type a = { a : int } + type b = { mutable b : int } + type _ t = + | A : a t + | B : b t + let f (type x) (v:x t) (r:x) = + match v with + | A -> r.a + | B -> r.b <- 2; 3 + + let v = + let r = + ref A in + r := A; (* Some pattern that the compiler can't understand *) + f !r { a = 1 }] + When inlining [f], the B branch is unreachable, yet the compiler + cannot prove it and must therefore keep it. +*) +type t = private { + descr : descr; + var : Variable.t option; + symbol : (Symbol.t * int option) option; +} + +and descr = private + | Value_block of Tag.t * t array + | Value_int of int + | Value_char of char + | Value_constptr of int + | Value_float of float option + | Value_boxed_int : 'a boxed_int * 'a -> descr + | Value_set_of_closures of value_set_of_closures + | Value_closure of value_closure + | Value_string of value_string + | Value_float_array of value_float_array + | Value_unknown of unknown_because_of + | Value_bottom + | Value_extern of Export_id.t + | Value_symbol of Symbol.t + | Value_unresolved of unresolved_value + (* No description was found for this value *) + +and value_closure = { + set_of_closures : t; + closure_id : Closure_id.t; +} + +and function_declarations = private { + is_classic_mode: bool; + set_of_closures_id : Set_of_closures_id.t; + set_of_closures_origin : Set_of_closures_origin.t; + funs : function_declaration Variable.Map.t; +} + +and function_body = private { + free_variables : Variable.Set.t; + free_symbols : Symbol.Set.t; + stub : bool; + dbg : Debuginfo.t; + inline : Lambda.inline_attribute; + specialise : Lambda.specialise_attribute; + is_a_functor : bool; + body : Flambda.t; +} + +and function_declaration = private { + closure_origin : Closure_origin.t; + params : Parameter.t list; + function_body : function_body option; +} + + +(* CR-soon mshinwell: add support for the approximations of the results, so we + can do all of the tricky higher-order cases. *) +(* when [is_classic_mode] is [false], functions in [function_declarations] + are guaranteed to have function bodies (ie: + [function_declaration.function_body] will be of the [Some] variant). + + When it [is_classic_mode] is [true], however, no guarantees about the + function_bodies are given. +*) +and value_set_of_closures = private { + function_decls : function_declarations; + bound_vars : t Var_within_closure.Map.t; + free_vars : Flambda.specialised_to Variable.Map.t; + invariant_params : Variable.Set.t Variable.Map.t Lazy.t; + recursive : Variable.Set.t Lazy.t; + size : int option Variable.Map.t Lazy.t; + (** For functions that are very likely to be inlined, the size of the + function's body. *) + specialised_args : Flambda.specialised_to Variable.Map.t; + (* Any freshening that has been applied to [function_decls]. *) + freshening : Freshening.Project_var.t; + direct_call_surrogates : Closure_id.t Closure_id.Map.t; +} + +and value_float_array_contents = + | Contents of t array + | Unknown_or_mutable + +and value_float_array = { + contents : value_float_array_contents; + size : int; +} + +(** Extraction of the description of approximation(s). *) +val descr : t -> descr +val descrs : t list -> descr list + +(** Pretty-printing of approximations to a formatter. *) +val print : Format.formatter -> t -> unit +val print_descr : Format.formatter -> descr -> unit +val print_value_set_of_closures + : Format.formatter + -> value_set_of_closures + -> unit +val print_function_declarations + : Format.formatter + -> function_declarations + -> unit + +val function_declarations_approx + : keep_body:(Variable.t -> Flambda.function_declaration -> bool) + -> Flambda.function_declarations + -> function_declarations + +val create_value_set_of_closures + : function_decls:function_declarations + -> bound_vars:t Var_within_closure.Map.t + -> free_vars:Flambda.specialised_to Variable.Map.t + -> invariant_params:Variable.Set.t Variable.Map.t lazy_t + -> recursive:Variable.Set.t Lazy.t + -> specialised_args:Flambda.specialised_to Variable.Map.t + -> freshening:Freshening.Project_var.t + -> direct_call_surrogates:Closure_id.t Closure_id.Map.t + -> value_set_of_closures + +val update_freshening_of_value_set_of_closures + : value_set_of_closures + -> freshening:Freshening.Project_var.t + -> value_set_of_closures + +(** Basic construction of approximations. *) +val value_unknown : unknown_because_of -> t +val value_int : int -> t +val value_char : char -> t +val value_float : float -> t +val value_any_float : t +val value_mutable_float_array : size:int -> t +val value_immutable_float_array : t array -> t +val value_string : int -> string option -> t +val value_boxed_int : 'i boxed_int -> 'i -> t +val value_constptr : int -> t +val value_block : Tag.t -> t array -> t +val value_extern : Export_id.t -> t +val value_symbol : Symbol.t -> t +val value_bottom : t +val value_unresolved : unresolved_value -> t + +(** Construct a closure approximation given the approximation of the + corresponding set of closures and the closure ID of the closure to + be projected from such set. [closure_var] and/or [set_of_closures_var] + may be specified to augment the approximation with variables that may + be used to access the closure value itself, so long as they are in + scope at the proposed point of use. *) +val value_closure + : ?closure_var:Variable.t + -> ?set_of_closures_var:Variable.t + -> ?set_of_closures_symbol:Symbol.t + -> value_set_of_closures + -> Closure_id.t + -> t + +(** Construct a set of closures approximation. [set_of_closures_var] is as for + the parameter of the same name in [value_closure], above. *) +val value_set_of_closures + : ?set_of_closures_var:Variable.t + -> value_set_of_closures + -> t + +(** Take the given constant and produce an appropriate approximation for it + together with an Flambda expression representing it. *) +val make_const_int : int -> Flambda.t * t +val make_const_char : char -> Flambda.t * t +val make_const_ptr : int -> Flambda.t * t +val make_const_bool : bool -> Flambda.t * t +val make_const_float : float -> Flambda.t * t +val make_const_boxed_int : 'i boxed_int -> 'i -> Flambda.t * t + +val make_const_int_named : int -> Flambda.named * t +val make_const_char_named : char -> Flambda.named * t +val make_const_ptr_named : int -> Flambda.named * t +val make_const_bool_named : bool -> Flambda.named * t +val make_const_float_named : float -> Flambda.named * t +val make_const_boxed_int_named : 'i boxed_int -> 'i -> Flambda.named * t + +(** Augment an approximation with a given variable (see comment above). + If the approximation was already augmented with a variable, the one + passed to this function replaces it within the approximation. *) +val augment_with_variable : t -> Variable.t -> t + +(** Like [augment_with_variable], but for symbol information. *) +val augment_with_symbol : t -> Symbol.t -> t + +(** Like [augment_with_symbol], but for symbol field information. *) +val augment_with_symbol_field : t -> Symbol.t -> int -> t + +(** Replace the description within an approximation. *) +val replace_description : t -> descr -> t + +(** Improve the description by taking the kind into account *) +val augment_with_kind : t -> Lambda.value_kind -> t + +(** Improve the kind by taking the description into account *) +val augment_kind_with_approx : t -> Lambda.value_kind -> Lambda.value_kind + +val equal_boxed_int : 'a boxed_int -> 'a -> 'b boxed_int -> 'b -> bool + +(* CR-soon mshinwell for pchambart: Add comment describing semantics. (Maybe + we should move the comment from the .ml file into here.) *) +val meet : really_import_approx:(t -> t) -> t -> t -> t + +(** An approximation is "known" iff it is not [Value_unknown]. *) +val known : t -> bool + +(** An approximation is "useful" iff it is neither unknown nor bottom. *) +val useful : t -> bool + +(** Whether all approximations in the given list do *not* satisfy [useful]. *) +val all_not_useful : t list -> bool + +(** Whether to warn on attempts to mutate a value. + It must have been resolved (it cannot be [Value_extern] or + [Value_symbol]). (See comment above for further explanation.) *) +val warn_on_mutation : t -> bool + +type simplification_summary = + | Nothing_done + | Replaced_term + +type simplification_result = Flambda.t * simplification_summary * t +type simplification_result_named = Flambda.named * simplification_summary * t + +(** Given an expression and its approximation, attempt to simplify the + expression to a constant (with associated approximation), taking into + account whether the expression has any side effects. *) +val simplify : t -> Flambda.t -> simplification_result + +(** As for [simplify], but also enables us to simplify based on equalities + between variables. The caller must provide a function that tells us + whether, if we simplify to a given variable, the value of that variable + will be accessible in the current environment. *) +val simplify_using_env + : t + -> is_present_in_env:(Variable.t -> bool) + -> Flambda.t + -> simplification_result + +val simplify_named : t -> Flambda.named -> simplification_result_named + +val simplify_named_using_env + : t + -> is_present_in_env:(Variable.t -> bool) + -> Flambda.named + -> simplification_result_named + +(** If the given approximation identifies another variable and + [is_present_in_env] deems it to be in scope, return that variable (wrapped + in a [Some]), otherwise return [None]. *) +val simplify_var_to_var_using_env + : t + -> is_present_in_env:(Variable.t -> bool) + -> Variable.t option + +val simplify_var : t -> (Flambda.named * t) option + +type get_field_result = + | Ok of t + | Unreachable + +(** Given the approximation [t] of a value, expected to correspond to a block + (in the [Pmakeblock] sense of the word), and a field index then return + an appropriate approximation for that field of the block (or + [Unreachable] if the code with the approximation [t] is unreachable). + N.B. Not all cases of unreachable code are returned as [Unreachable]. +*) +val get_field : t -> field_index:int -> get_field_result + +type checked_approx_for_block = + | Wrong + | Ok of Tag.t * t array + +(** Try to prove that a value with the given approximation may be used + as a block. *) +val check_approx_for_block : t -> checked_approx_for_block + +(** Find the approximation for a bound variable in a set-of-closures + approximation. A fatal error is produced if the variable is not bound in + the given approximation. *) +val approx_for_bound_var : value_set_of_closures -> Var_within_closure.t -> t + +(** Given a set-of-closures approximation and a closure ID, apply any + freshening specified by the approximation to the closure ID, and return + the resulting ID. Causes a fatal error if the resulting closure ID does + not correspond to any function declaration in the approximation. *) +val freshen_and_check_closure_id + : value_set_of_closures + -> Closure_id.t + -> Closure_id.t + +type strict_checked_approx_for_set_of_closures = + | Wrong + | Ok of Variable.t option * value_set_of_closures + +val strict_check_approx_for_set_of_closures + : t + -> strict_checked_approx_for_set_of_closures + +type checked_approx_for_set_of_closures = + | Wrong + | Unresolved of unresolved_value + | Unknown + | Unknown_because_of_unresolved_value of unresolved_value + (* In the [Ok] case, there may not be a variable associated with the set of + closures; it might be out of scope. *) + | Ok of Variable.t option * value_set_of_closures + +(** Try to prove that a value with the given approximation may be used as a + set of closures. Values coming from external compilation units with + unresolved approximations are permitted. *) +val check_approx_for_set_of_closures : t -> checked_approx_for_set_of_closures + +type checked_approx_for_closure = + | Wrong + | Ok of value_closure * Variable.t option + * Symbol.t option * value_set_of_closures + +(** Try to prove that a value with the given approximation may be used as a + closure. Values coming from external compilation units with unresolved + approximations are not permitted. *) +(* CR-someday mshinwell: naming is inconsistent: this is as "strict" + as "strict_check_approx_for_set_of_closures" *) +val check_approx_for_closure : t -> checked_approx_for_closure + +type checked_approx_for_closure_allowing_unresolved = + | Wrong + | Unresolved of unresolved_value + | Unknown + | Unknown_because_of_unresolved_value of unresolved_value + | Ok of value_closure * Variable.t option + * Symbol.t option * value_set_of_closures + +(** As for [check_approx_for_closure], but values coming from external + compilation units with unresolved approximations are permitted. *) +val check_approx_for_closure_allowing_unresolved + : t + -> checked_approx_for_closure_allowing_unresolved + +(** Returns the value if it can be proved to be a constant float *) +val check_approx_for_float : t -> float option + +(** Returns the value if it can be proved to be a constant float array *) +val float_array_as_constant : value_float_array -> float list option + +(** Returns the value if it can be proved to be a constant string *) +val check_approx_for_string : t -> string option + +type switch_branch_selection = + | Cannot_be_taken + | Can_be_taken + | Must_be_taken + +(** Check that the branch is compatible with the approximation *) +val potentially_taken_const_switch_branch : t -> int -> switch_branch_selection +val potentially_taken_block_switch_branch : t -> int -> switch_branch_selection + +val function_arity : function_declaration -> int + +(** Create a set of function declarations based on another set of function + declarations. *) +val update_function_declarations + : function_declarations + -> funs:function_declaration Variable.Map.t + -> function_declarations + +val import_function_declarations_for_pack + : function_declarations + -> (Set_of_closures_id.t -> Set_of_closures_id.t) + -> (Set_of_closures_origin.t -> Set_of_closures_origin.t) + -> function_declarations + +val update_function_declaration_body + : function_declaration + -> (Flambda.t -> Flambda.t) + -> function_declaration + +(** Creates a map from closure IDs to function declarations by iterating over + all sets of closures in the given map. *) +val make_closure_map + : function_declarations Set_of_closures_id.Map.t + -> function_declarations Closure_id.Map.t + +val clear_function_bodies : function_declarations -> function_declarations diff --git a/middle_end/flambda/simplify_boxed_integer_ops.ml b/middle_end/flambda/simplify_boxed_integer_ops.ml new file mode 100644 index 00000000..1f95a1ec --- /dev/null +++ b/middle_end/flambda/simplify_boxed_integer_ops.ml @@ -0,0 +1,116 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module S = Simplify_common + +(* Simplification of operations on boxed integers (nativeint, Int32, Int64). *) +module Simplify_boxed_integer_operator (I : sig + type t + val kind : Lambda.boxed_integer + val zero : t + val add : t -> t -> t + val sub : t -> t -> t + val mul : t -> t -> t + val div : t -> t -> t + val rem : t -> t -> t + val logand : t -> t -> t + val logor : t -> t -> t + val logxor : t -> t -> t + val shift_left : t -> int -> t + val shift_right : t -> int -> t + val shift_right_logical : t -> int -> t + val to_int : t -> int + val to_int32 : t -> Int32.t + val to_int64 : t -> Int64.t + val neg : t -> t + val swap : t -> t + val compare : t -> t -> int +end) : Simplify_boxed_integer_ops_intf.S with type t := I.t = struct + module A = Simple_value_approx + module C = Inlining_cost + + let equal_kind = Lambda.equal_boxed_integer + + let simplify_unop (p : Clambda_primitives.primitive) + (kind : I.t A.boxed_int) expr (n : I.t) = + let eval op = S.const_boxed_int_expr expr kind (op n) in + let eval_conv kind op = S.const_boxed_int_expr expr kind (op n) in + let eval_unboxed op = S.const_int_expr expr (op n) in + match p with + | Pintofbint kind when equal_kind kind I.kind -> eval_unboxed I.to_int + | Pcvtbint (kind, Pint32) when equal_kind kind I.kind -> + eval_conv A.Int32 I.to_int32 + | Pcvtbint (kind, Pint64) when equal_kind kind I.kind -> + eval_conv A.Int64 I.to_int64 + | Pnegbint kind when equal_kind kind I.kind -> eval I.neg + | Pbbswap kind when equal_kind kind I.kind -> eval I.swap + | _ -> expr, A.value_unknown Other, C.Benefit.zero + + let simplify_binop (p : Clambda_primitives.primitive) + (kind : I.t A.boxed_int) expr (n1 : I.t) (n2 : I.t) = + let eval op = S.const_boxed_int_expr expr kind (op n1 n2) in + let non_zero n = (I.compare I.zero n) <> 0 in + match p with + | Paddbint kind when equal_kind kind I.kind -> eval I.add + | Psubbint kind when equal_kind kind I.kind -> eval I.sub + | Pmulbint kind when equal_kind kind I.kind -> eval I.mul + | Pdivbint {size=kind} when equal_kind kind I.kind && non_zero n2 -> + eval I.div + | Pmodbint {size=kind} when equal_kind kind I.kind && non_zero n2 -> + eval I.rem + | Pandbint kind when equal_kind kind I.kind -> eval I.logand + | Porbint kind when equal_kind kind I.kind -> eval I.logor + | Pxorbint kind when equal_kind kind I.kind -> eval I.logxor + | Pbintcomp (kind, c) when equal_kind kind I.kind -> + S.const_integer_comparison_expr expr c n1 n2 + | _ -> expr, A.value_unknown Other, C.Benefit.zero + + let simplify_binop_int (p : Clambda_primitives.primitive) + (kind : I.t A.boxed_int) expr (n1 : I.t) (n2 : int) ~size_int = + let eval op = S.const_boxed_int_expr expr kind (op n1 n2) in + let precond = 0 <= n2 && n2 < 8 * size_int in + match p with + | Plslbint kind when equal_kind kind I.kind && precond -> eval I.shift_left + | Plsrbint kind when equal_kind kind I.kind && precond -> + eval I.shift_right_logical + | Pasrbint kind when equal_kind kind I.kind && precond -> eval I.shift_right + | _ -> expr, A.value_unknown Other, C.Benefit.zero +end + +module Simplify_boxed_nativeint = Simplify_boxed_integer_operator (struct + include Nativeint + let to_int64 = Int64.of_nativeint + let swap = S.swapnative + let kind = Lambda.Pnativeint +end) + +module Simplify_boxed_int32 = Simplify_boxed_integer_operator (struct + include Int32 + let to_int32 i = i + let to_int64 = Int64.of_int32 + let swap = S.swap32 + let kind = Lambda.Pint32 +end) + +module Simplify_boxed_int64 = Simplify_boxed_integer_operator (struct + include Int64 + let to_int64 i = i + let swap = S.swap64 + let kind = Lambda.Pint64 +end) diff --git a/middle_end/flambda/simplify_boxed_integer_ops.mli b/middle_end/flambda/simplify_boxed_integer_ops.mli new file mode 100644 index 00000000..f3461043 --- /dev/null +++ b/middle_end/flambda/simplify_boxed_integer_ops.mli @@ -0,0 +1,28 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(* Simplification of operations on boxed integers (nativeint, Int32, Int64). *) + +module Simplify_boxed_nativeint : Simplify_boxed_integer_ops_intf.S + with type t := Nativeint.t + +module Simplify_boxed_int32 : Simplify_boxed_integer_ops_intf.S + with type t := Int32.t + +module Simplify_boxed_int64 : Simplify_boxed_integer_ops_intf.S + with type t := Int64.t diff --git a/middle_end/flambda/simplify_boxed_integer_ops_intf.mli b/middle_end/flambda/simplify_boxed_integer_ops_intf.mli new file mode 100644 index 00000000..f30987ae --- /dev/null +++ b/middle_end/flambda/simplify_boxed_integer_ops_intf.mli @@ -0,0 +1,45 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +module type S = sig + type t + + val simplify_unop + : Clambda_primitives.primitive + -> t Simple_value_approx.boxed_int + -> Flambda.named + -> t + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + + val simplify_binop + : Clambda_primitives.primitive + -> t Simple_value_approx.boxed_int + -> Flambda.named + -> t + -> t + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + + val simplify_binop_int + : Clambda_primitives.primitive + -> t Simple_value_approx.boxed_int + -> Flambda.named + -> t + -> int + -> size_int:int + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t +end diff --git a/middle_end/flambda/simplify_common.ml b/middle_end/flambda/simplify_common.ml new file mode 100644 index 00000000..fcbbcfbc --- /dev/null +++ b/middle_end/flambda/simplify_common.ml @@ -0,0 +1,86 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module A = Simple_value_approx +module C = Inlining_cost + +external swap16 : int -> int = "%bswap16" +external swap32 : int32 -> int32 = "%bswap_int32" +external swap64 : int64 -> int64 = "%bswap_int64" +external swapnative : nativeint -> nativeint = "%bswap_native" + +let const_int_expr expr n = + if Effect_analysis.no_effects_named expr then + let (new_expr, approx) = A.make_const_int_named n in + new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero + else expr, A.value_int n, C.Benefit.zero +let const_char_expr expr c = + if Effect_analysis.no_effects_named expr then + let (new_expr, approx) = A.make_const_char_named c in + new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero + else expr, A.value_char c, C.Benefit.zero +let const_ptr_expr expr n = + if Effect_analysis.no_effects_named expr then + let (new_expr, approx) = A.make_const_ptr_named n in + new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero + else expr, A.value_constptr n, C.Benefit.zero +let const_bool_expr expr b = + const_int_expr expr (if b then 1 else 0) +let const_float_expr expr f = + if Effect_analysis.no_effects_named expr then + let (new_expr, approx) = A.make_const_float_named f in + new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero + else expr, A.value_float f, C.Benefit.zero +let const_boxed_int_expr expr t i = + if Effect_analysis.no_effects_named expr then + let (new_expr, approx) = A.make_const_boxed_int_named t i in + new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero + else expr, A.value_boxed_int t i, C.Benefit.zero + +let const_integer_comparison_expr expr (cmp : Lambda.integer_comparison) x y = + (* Using the [Stdlib] comparison functions here in the compiler + coincides with the definitions of such functions in the code + compiled by the user, and is thus correct. *) + let open! Stdlib in + const_bool_expr expr + (match cmp with + | Ceq -> x = y + | Cne -> x <> y + | Clt -> x < y + | Cgt -> x > y + | Cle -> x <= y + | Cge -> x >= y) + +let const_float_comparison_expr expr (cmp : Lambda.float_comparison) x y = + (* Using the [Stdlib] comparison functions here in the compiler + coincides with the definitions of such functions in the code + compiled by the user, and is thus correct. *) + let open! Stdlib in + const_bool_expr expr + (match cmp with + | CFeq -> x = y + | CFneq -> not (x = y) + | CFlt -> x < y + | CFnlt -> not (x < y) + | CFgt -> x > y + | CFngt -> not (x > y) + | CFle -> x <= y + | CFnle -> not (x <= y) + | CFge -> x >= y + | CFnge -> not (x >= y)) diff --git a/middle_end/flambda/simplify_common.mli b/middle_end/flambda/simplify_common.mli new file mode 100644 index 00000000..c667bfff --- /dev/null +++ b/middle_end/flambda/simplify_common.mli @@ -0,0 +1,80 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** [const_*_expr expr v annot], where the expression [expr] is known to + evaluate to the value [v], attempt to produce a more simple expression + together with its approximation and the benefit gained by replacing [expr] + with this new expression. This simplification is only performed if [expr] + is known to have no side effects. Otherwise, [expr] itself is returned, + with an appropriate approximation but zero benefit. + + [const_boxed_int_expr] takes an additional argument specifying the kind of + boxed integer to which the given expression evaluates. +*) + +val const_int_expr + : Flambda.named + -> int + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + +val const_char_expr + : Flambda.named + -> char + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + +val const_bool_expr + : Flambda.named + -> bool + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + +val const_ptr_expr + : Flambda.named + -> int + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + +val const_float_expr + : Flambda.named + -> float + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + +val const_boxed_int_expr + : Flambda.named + -> 'a Simple_value_approx.boxed_int + -> 'a + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + +val const_integer_comparison_expr + : Flambda.named + -> Lambda.integer_comparison + -> 'a + -> 'a + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + +val const_float_comparison_expr + : Flambda.named + -> Lambda.float_comparison + -> float + -> float + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + +(** Functions for transposing the order of bytes within words of various + sizes. *) +val swap16 : int -> int +val swap32 : int32 -> int32 +val swap64 : int64 -> int64 +val swapnative : nativeint -> nativeint diff --git a/middle_end/flambda/simplify_primitives.ml b/middle_end/flambda/simplify_primitives.ml new file mode 100644 index 00000000..349d2f40 --- /dev/null +++ b/middle_end/flambda/simplify_primitives.ml @@ -0,0 +1,302 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module A = Simple_value_approx +module C = Inlining_cost +module I = Simplify_boxed_integer_ops +module S = Simplify_common + +let phys_equal (approxs:A.t list) = + match approxs with + | [] | [_] | _ :: _ :: _ :: _ -> + Misc.fatal_error "wrong number of arguments for equality" + | [a1; a2] -> + (* N.B. The following would be incorrect if the variables are not + bound in the environment: + match a1.var, a2.var with + | Some v1, Some v2 when Variable.equal v1 v2 -> true + | _ -> ... + *) + match a1.symbol, a2.symbol with + | Some (s1, None), Some (s2, None) -> Symbol.equal s1 s2 + | Some (s1, Some f1), Some (s2, Some f2) -> Symbol.equal s1 s2 && f1 = f2 + | _ -> false + +let is_known_to_be_some_kind_of_int (arg:A.descr) = + match arg with + | Value_int _ | Value_char _ | Value_constptr _ -> true + | Value_block (_, _) | Value_float _ | Value_set_of_closures _ + | Value_closure _ | Value_string _ | Value_float_array _ + | A.Value_boxed_int _ | Value_unknown _ | Value_extern _ + | Value_symbol _ | Value_unresolved _ | Value_bottom -> false + +let is_known_to_be_some_kind_of_block (arg:A.descr) = + match arg with + | Value_block _ | Value_float _ | Value_float_array _ | A.Value_boxed_int _ + | Value_closure _ | Value_string _ -> true + | Value_set_of_closures _ | Value_int _ | Value_char _ | Value_constptr _ + | Value_unknown _ | Value_extern _ | Value_symbol _ + | Value_unresolved _ | Value_bottom -> false + +let rec structurally_different (arg1:A.t) (arg2:A.t) = + match arg1.descr, arg2.descr with + | (Value_int n1 | Value_constptr n1), (Value_int n2 | Value_constptr n2) + when n1 <> n2 -> + true + | Value_block (tag1, fields1), Value_block (tag2, fields2) -> + not (Tag.equal tag1 tag2) + || (Array.length fields1 <> Array.length fields2) + || Misc.Stdlib.Array.exists2 structurally_different fields1 fields2 + | descr1, descr2 -> + (* This is not very precise as this won't allow to distinguish + blocks from strings for instance. This can be improved if it + is deemed valuable. *) + (is_known_to_be_some_kind_of_int descr1 + && is_known_to_be_some_kind_of_block descr2) + || (is_known_to_be_some_kind_of_block descr1 + && is_known_to_be_some_kind_of_int descr2) + +let phys_different (approxs:A.t list) = + match approxs with + | [] | [_] | _ :: _ :: _ :: _ -> + Misc.fatal_error "wrong number of arguments for equality" + | [a1; a2] -> + structurally_different a1 a2 + +let is_empty = function + | [] -> true + | _ :: _ -> false + +let is_pisint = function + | Clambda_primitives.Pisint -> true + | _ -> false + +let is_pstring_length = function + | Clambda_primitives.Pstringlength -> true + | _ -> false + +let is_pbytes_length = function + | Clambda_primitives.Pbyteslength -> true + | _ -> false + +let is_pstringrefs = function + | Clambda_primitives.Pstringrefs -> true + | _ -> false + +let is_pbytesrefs = function + | Clambda_primitives.Pbytesrefs -> true + | _ -> false + +let primitive (p : Clambda_primitives.primitive) (args, approxs) + expr dbg ~size_int + : Flambda.named * A.t * Inlining_cost.Benefit.t = + let fpc = !Clflags.float_const_prop in + match p with + | Pmakeblock(tag_int, Asttypes.Immutable, shape) -> + let tag = Tag.create_exn tag_int in + let shape = match shape with + | None -> List.map (fun _ -> Lambda.Pgenval) args + | Some shape -> shape + in + let approxs = List.map2 A.augment_with_kind approxs shape in + let shape = List.map2 A.augment_kind_with_approx approxs shape in + Prim (Pmakeblock(tag_int, Asttypes.Immutable, Some shape), args, dbg), + A.value_block tag (Array.of_list approxs), C.Benefit.zero + | Praise _ -> + expr, A.value_bottom, C.Benefit.zero + | Pmakearray(_, _) when is_empty approxs -> + Prim (Pmakeblock(0, Asttypes.Immutable, Some []), [], dbg), + A.value_block (Tag.create_exn 0) [||], C.Benefit.zero + | Pmakearray (Pfloatarray, Mutable) -> + let approx = + A.value_mutable_float_array ~size:(List.length args) + in + expr, approx, C.Benefit.zero + | Pmakearray (Pfloatarray, Immutable) -> + let approx = + A.value_immutable_float_array (Array.of_list approxs) + in + expr, approx, C.Benefit.zero + | Pintcomp Ceq when phys_equal approxs -> + S.const_bool_expr expr true + | Pintcomp Cne when phys_equal approxs -> + S.const_bool_expr expr false + (* N.B. Having [not (phys_equal approxs)] would not on its own tell us + anything about whether the two values concerned are unequal. To judge + that, it would be necessary to prove that the approximations are + different, which would in turn entail them being completely known. + + It may seem that in the case where we have two approximations each + annotated with a symbol that we should be able to judge inequality + even if part of the approximation description(s) are unknown. This is + unfortunately not the case. Here is an example: + + let a = f 1 + let b = f 1 + let c = a, a + let d = a, a + + If [Share_constants] is run before [f] is completely inlined (assuming + [f] always generates the same result; effects of [f] aren't in fact + relevant) then [c] and [d] will not be shared. However if [f] is + inlined later, [a] and [b] could be shared and thus [c] and [d] could + be too. As such, any intermediate non-aliasing judgement would be + invalid. *) + | Pintcomp Ceq when phys_different approxs -> + S.const_bool_expr expr false + | Pintcomp Cne when phys_different approxs -> + S.const_bool_expr expr true + (* If two values are structurally different we are certain they can never + be shared*) + | _ -> + match A.descrs approxs with + | [Value_int x] -> + begin match p with + | Pnot -> S.const_bool_expr expr (x = 0) + | Pnegint -> S.const_int_expr expr (-x) + | Pbswap16 -> S.const_int_expr expr (S.swap16 x) + | Poffsetint y -> S.const_int_expr expr (x + y) + | Pfloatofint when fpc -> S.const_float_expr expr (float_of_int x) + | Pbintofint Pnativeint -> + S.const_boxed_int_expr expr Nativeint (Nativeint.of_int x) + | Pbintofint Pint32 -> S.const_boxed_int_expr expr Int32 (Int32.of_int x) + | Pbintofint Pint64 -> S.const_boxed_int_expr expr Int64 (Int64.of_int x) + | _ -> expr, A.value_unknown Other, C.Benefit.zero + end + | [(Value_int x | Value_constptr x); (Value_int y | Value_constptr y)] -> + let shift_precond = 0 <= y && y < 8 * size_int in + begin match p with + | Paddint -> S.const_int_expr expr (x + y) + | Psubint -> S.const_int_expr expr (x - y) + | Pmulint -> S.const_int_expr expr (x * y) + | Pdivint _ when y <> 0 -> S.const_int_expr expr (x / y) + | Pmodint _ when y <> 0 -> S.const_int_expr expr (x mod y) + | Pandint -> S.const_int_expr expr (x land y) + | Porint -> S.const_int_expr expr (x lor y) + | Pxorint -> S.const_int_expr expr (x lxor y) + | Plslint when shift_precond -> S.const_int_expr expr (x lsl y) + | Plsrint when shift_precond -> S.const_int_expr expr (x lsr y) + | Pasrint when shift_precond -> S.const_int_expr expr (x asr y) + | Pintcomp cmp -> S.const_integer_comparison_expr expr cmp x y + | Pisout -> S.const_bool_expr expr (y > x || y < 0) + | _ -> expr, A.value_unknown Other, C.Benefit.zero + end + | [Value_char x; Value_char y] -> + begin match p with + | Pintcomp cmp -> S.const_integer_comparison_expr expr cmp x y + | _ -> expr, A.value_unknown Other, C.Benefit.zero + end + | [Value_constptr x] -> + begin match p with + (* [Pidentity] should probably never appear, but is here for + completeness. *) + | Pnot -> S.const_bool_expr expr (x = 0) + | Pisint -> S.const_bool_expr expr true + | Poffsetint y -> S.const_ptr_expr expr (x + y) + | _ -> expr, A.value_unknown Other, C.Benefit.zero + end + | [Value_float (Some x)] when fpc -> + begin match p with + | Pintoffloat -> S.const_int_expr expr (int_of_float x) + | Pnegfloat -> S.const_float_expr expr (-. x) + | Pabsfloat -> S.const_float_expr expr (abs_float x) + | _ -> expr, A.value_unknown Other, C.Benefit.zero + end + | [Value_float (Some n1); Value_float (Some n2)] when fpc -> + begin match p with + | Paddfloat -> S.const_float_expr expr (n1 +. n2) + | Psubfloat -> S.const_float_expr expr (n1 -. n2) + | Pmulfloat -> S.const_float_expr expr (n1 *. n2) + | Pdivfloat -> S.const_float_expr expr (n1 /. n2) + | Pfloatcomp c -> S.const_float_comparison_expr expr c n1 n2 + | _ -> expr, A.value_unknown Other, C.Benefit.zero + end + | [A.Value_boxed_int(A.Nativeint, n)] -> + I.Simplify_boxed_nativeint.simplify_unop p Nativeint expr n + | [A.Value_boxed_int(A.Int32, n)] -> + I.Simplify_boxed_int32.simplify_unop p Int32 expr n + | [A.Value_boxed_int(A.Int64, n)] -> + I.Simplify_boxed_int64.simplify_unop p Int64 expr n + | [A.Value_boxed_int(A.Nativeint, n1); + A.Value_boxed_int(A.Nativeint, n2)] -> + I.Simplify_boxed_nativeint.simplify_binop p Nativeint expr n1 n2 + | [A.Value_boxed_int(A.Int32, n1); A.Value_boxed_int(A.Int32, n2)] -> + I.Simplify_boxed_int32.simplify_binop p Int32 expr n1 n2 + | [A.Value_boxed_int(A.Int64, n1); A.Value_boxed_int(A.Int64, n2)] -> + I.Simplify_boxed_int64.simplify_binop p Int64 expr n1 n2 + | [A.Value_boxed_int(A.Nativeint, n1); Value_int n2] -> + I.Simplify_boxed_nativeint.simplify_binop_int p Nativeint expr n1 n2 + ~size_int + | [A.Value_boxed_int(A.Int32, n1); Value_int n2] -> + I.Simplify_boxed_int32.simplify_binop_int p Int32 expr n1 n2 + ~size_int + | [A.Value_boxed_int(A.Int64, n1); Value_int n2] -> + I.Simplify_boxed_int64.simplify_binop_int p Int64 expr n1 n2 + ~size_int + | [Value_block _] when is_pisint p -> + S.const_bool_expr expr false + | [Value_string { size }] + when (is_pstring_length p || is_pbytes_length p) -> + S.const_int_expr expr size + | [Value_string { size; contents = Some s }; + (Value_int x | Value_constptr x)] when x >= 0 && x < size -> + begin match p with + | Pstringrefu + | Pstringrefs + | Pbytesrefu + | Pbytesrefs -> + S.const_char_expr (Prim(Pstringrefu, args, dbg)) s.[x] + | _ -> expr, A.value_unknown Other, C.Benefit.zero + end + | [Value_string { size; contents = None }; + (Value_int x | Value_constptr x)] + when x >= 0 && x < size && is_pstringrefs p -> + Flambda.Prim (Pstringrefu, args, dbg), + A.value_unknown Other, + (* we improved it, but there is no way to account for that: *) + C.Benefit.zero + | [Value_string { size; contents = None }; + (Value_int x | Value_constptr x)] + when x >= 0 && x < size && is_pbytesrefs p -> + Flambda.Prim (Pbytesrefu, args, dbg), + A.value_unknown Other, + (* we improved it, but there is no way to account for that: *) + C.Benefit.zero + + | [Value_float_array { size; contents }] -> + begin match p with + | Parraylength _ -> S.const_int_expr expr size + | Pfloatfield i -> + begin match contents with + | A.Contents a when i >= 0 && i < size -> + begin match A.check_approx_for_float a.(i) with + | None -> expr, a.(i), C.Benefit.zero + | Some v -> S.const_float_expr expr v + end + | Contents _ | Unknown_or_mutable -> + expr, A.value_unknown Other, C.Benefit.zero + end + | _ -> expr, A.value_unknown Other, C.Benefit.zero + end + | _ -> + match Semantics_of_primitives.return_type_of_primitive p with + | Float -> + expr, A.value_any_float, C.Benefit.zero + | Other -> + expr, A.value_unknown Other, C.Benefit.zero diff --git a/middle_end/flambda/simplify_primitives.mli b/middle_end/flambda/simplify_primitives.mli new file mode 100644 index 00000000..a6b6330c --- /dev/null +++ b/middle_end/flambda/simplify_primitives.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Simplifies an application of a primitive based on approximation + information. *) +val primitive + : Clambda_primitives.primitive + -> (Variable.t list * (Simple_value_approx.t list)) + -> Flambda.named + -> Debuginfo.t + -> size_int:int + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t diff --git a/middle_end/flambda/traverse_for_exported_symbols.ml b/middle_end/flambda/traverse_for_exported_symbols.ml new file mode 100644 index 00000000..1b7ce57f --- /dev/null +++ b/middle_end/flambda/traverse_for_exported_symbols.ml @@ -0,0 +1,267 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fu Yong Quah, Jane Street Europe *) +(* *) +(* Copyright 2017 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +module A = Simple_value_approx + +type queue_elem = + | Q_symbol of Symbol.t + | Q_set_of_closures_id of Set_of_closures_id.t + | Q_export_id of Export_id.t + +type symbols_to_export = + { symbols : Symbol.Set.t; + export_ids : Export_id.Set.t; + set_of_closure_ids : Set_of_closures_id.Set.t; + set_of_closure_ids_keep_declaration : Set_of_closures_id.Set.t; + relevant_imported_closure_ids : Closure_id.Set.t; + relevant_local_closure_ids : Closure_id.Set.t; + relevant_imported_vars_within_closure : Var_within_closure.Set.t; + relevant_local_vars_within_closure : Var_within_closure.Set.t; + } + +let traverse + ~(sets_of_closures_map : + Flambda.set_of_closures Set_of_closures_id.Map.t) + ~(closure_id_to_set_of_closures_id : + Set_of_closures_id.t Closure_id.Map.t) + ~(function_declarations_map : + A.function_declarations Set_of_closures_id.Map.t) + ~(values : Export_info.descr Export_id.Map.t) + ~(symbol_id : Export_id.t Symbol.Map.t) + ~(root_symbol: Symbol.t) = + let relevant_set_of_closures_declaration_only = + ref Set_of_closures_id.Set.empty + in + let relevant_symbols = ref (Symbol.Set.singleton root_symbol) in + let relevant_set_of_closures = ref Set_of_closures_id.Set.empty in + let relevant_export_ids = ref Export_id.Set.empty in + let relevant_imported_closure_ids = ref Closure_id.Set.empty in + let relevant_local_closure_ids = ref Closure_id.Set.empty in + let relevant_imported_vars_within_closure = + ref Var_within_closure.Set.empty + in + let relevant_local_vars_with_closure = ref Var_within_closure.Set.empty in + let (queue : queue_elem Queue.t) = Queue.create () in + let conditionally_add_symbol symbol = + if not (Symbol.Set.mem symbol !relevant_symbols) then begin + relevant_symbols := + Symbol.Set.add symbol !relevant_symbols; + Queue.add (Q_symbol symbol) queue + end + in + let conditionally_add_set_of_closures_id set_of_closures_id = + if not (Set_of_closures_id.Set.mem + set_of_closures_id !relevant_set_of_closures) then begin + relevant_set_of_closures := + Set_of_closures_id.Set.add set_of_closures_id + !relevant_set_of_closures; + Queue.add (Q_set_of_closures_id set_of_closures_id) queue + end + in + let conditionally_add_export_id export_id = + if not (Export_id.Set.mem export_id !relevant_export_ids) then begin + relevant_export_ids := + Export_id.Set.add export_id !relevant_export_ids; + Queue.add (Q_export_id export_id) queue + end + in + let process_approx (approx : Export_info.approx) = + match approx with + | Value_id export_id -> + conditionally_add_export_id export_id + | Value_symbol symbol -> + conditionally_add_symbol symbol + | Value_unknown -> () + in + let process_value_set_of_closures + (soc : Export_info.value_set_of_closures) = + conditionally_add_set_of_closures_id soc.set_of_closures_id; + Var_within_closure.Map.iter + (fun _ value -> process_approx value) soc.bound_vars; + Closure_id.Map.iter + (fun _ value -> process_approx value) soc.results; + begin match soc.aliased_symbol with + | None -> () + | Some symbol -> conditionally_add_symbol symbol + end + in + let process_function_body (function_body : A.function_body) = + Flambda_iterators.iter + (fun (term : Flambda.t) -> + match term with + | Flambda.Apply { kind ; _ } -> + begin match kind with + | Indirect -> () + | Direct closure_id -> + begin match + Closure_id.Map.find + closure_id + closure_id_to_set_of_closures_id + with + | exception Not_found -> + relevant_imported_closure_ids := + Closure_id.Set.add closure_id + !relevant_imported_closure_ids + | set_of_closures_id -> + relevant_local_closure_ids := + Closure_id.Set.add closure_id + !relevant_local_closure_ids; + conditionally_add_set_of_closures_id + set_of_closures_id + end + end + | _ -> ()) + (fun (named : Flambda.named) -> + let process_closure_id closure_id = + match + Closure_id.Map.find closure_id closure_id_to_set_of_closures_id + with + | exception Not_found -> + relevant_imported_closure_ids := + Closure_id.Set.add closure_id !relevant_imported_closure_ids + | set_of_closure_id -> + relevant_local_closure_ids := + Closure_id.Set.add closure_id !relevant_local_closure_ids; + relevant_set_of_closures_declaration_only := + Set_of_closures_id.Set.add + set_of_closure_id + !relevant_set_of_closures_declaration_only + in + match named with + | Symbol symbol + | Read_symbol_field (symbol, _) -> + conditionally_add_symbol symbol + | Set_of_closures soc -> + conditionally_add_set_of_closures_id + soc.function_decls.set_of_closures_id + | Project_closure { closure_id; _ } -> + process_closure_id closure_id + | Move_within_set_of_closures { start_from; move_to; _ } -> + process_closure_id start_from; + process_closure_id move_to + | Project_var { closure_id ; var; _ } -> + begin match + Closure_id.Map.find + closure_id closure_id_to_set_of_closures_id + with + | exception Not_found -> + relevant_imported_closure_ids := + Closure_id.Set.add closure_id + !relevant_imported_closure_ids; + relevant_imported_vars_within_closure := + Var_within_closure.Set.add var + !relevant_imported_vars_within_closure + | set_of_closure_id -> + relevant_local_closure_ids := + Closure_id.Set.add closure_id + !relevant_local_closure_ids; + relevant_local_vars_with_closure := + Var_within_closure.Set.add var + !relevant_local_vars_with_closure; + relevant_set_of_closures_declaration_only := + Set_of_closures_id.Set.add + set_of_closure_id + !relevant_set_of_closures_declaration_only + end + | Prim _ + | Expr _ + | Const _ + | Allocated_const _ + | Read_mutable _ -> ()) + function_body.body + in + let rec loop () = + if Queue.is_empty queue then + () + else begin + begin match Queue.pop queue with + | Q_export_id export_id -> + begin match Export_id.Map.find export_id values with + | exception Not_found -> () + | Value_block (_, approxes) -> + Array.iter process_approx approxes + | Value_closure value_closure -> + process_value_set_of_closures value_closure.set_of_closures + | Value_set_of_closures soc -> + process_value_set_of_closures soc + | _ -> () + end + | Q_symbol symbol -> + let compilation_unit = Symbol.compilation_unit symbol in + if Compilation_unit.is_current compilation_unit then begin + match Symbol.Map.find symbol symbol_id with + | exception Not_found -> + Misc.fatal_errorf "cannot find symbol's export id %a\n" + Symbol.print symbol + | export_id -> + conditionally_add_export_id export_id + end + | Q_set_of_closures_id set_of_closures_id -> + begin match + Set_of_closures_id.Map.find + set_of_closures_id function_declarations_map + with + | exception Not_found -> () + | function_declarations -> + Variable.Map.iter + (fun (_ : Variable.t) (fun_decl : A.function_declaration) -> + match fun_decl.function_body with + | None -> () + | Some function_body -> process_function_body function_body) + function_declarations.funs + end + end; + loop () + end + in + Queue.add (Q_symbol root_symbol) queue; + loop (); + + Closure_id.Map.iter (fun closure_id set_of_closure_id -> + if Set_of_closures_id.Set.mem + set_of_closure_id !relevant_set_of_closures + then begin + relevant_local_closure_ids := + Closure_id.Set.add closure_id !relevant_local_closure_ids + end) + closure_id_to_set_of_closures_id; + + Set_of_closures_id.Set.iter (fun set_of_closures_id -> + match + Set_of_closures_id.Map.find set_of_closures_id sets_of_closures_map + with + | exception Not_found -> () + | set_of_closures -> + Variable.Map.iter (fun var _ -> + relevant_local_vars_with_closure := + Var_within_closure.Set.add + (Var_within_closure.wrap var) + !relevant_local_vars_with_closure) + set_of_closures.free_vars) + !relevant_set_of_closures; + + { symbols = !relevant_symbols; + export_ids = !relevant_export_ids; + set_of_closure_ids = !relevant_set_of_closures; + set_of_closure_ids_keep_declaration = + !relevant_set_of_closures_declaration_only; + relevant_imported_closure_ids = !relevant_imported_closure_ids; + relevant_local_closure_ids = !relevant_local_closure_ids; + relevant_imported_vars_within_closure = + !relevant_imported_vars_within_closure; + relevant_local_vars_within_closure = + !relevant_local_vars_with_closure; + } diff --git a/middle_end/flambda/traverse_for_exported_symbols.mli b/middle_end/flambda/traverse_for_exported_symbols.mli new file mode 100644 index 00000000..2825a386 --- /dev/null +++ b/middle_end/flambda/traverse_for_exported_symbols.mli @@ -0,0 +1,41 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fu Yong Quah, Jane Street Europe *) +(* *) +(* Copyright 2017 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +type symbols_to_export = + { symbols : Symbol.Set.t; + export_ids : Export_id.Set.t; + set_of_closure_ids : Set_of_closures_id.Set.t; + set_of_closure_ids_keep_declaration : Set_of_closures_id.Set.t; + relevant_imported_closure_ids : Closure_id.Set.t; + relevant_local_closure_ids : Closure_id.Set.t; + relevant_imported_vars_within_closure : Var_within_closure.Set.t; + relevant_local_vars_within_closure : Var_within_closure.Set.t; + } + +(** Computes the transitive closure in [Symbol.t], [Closure_id.t] and + [Set_of_closures_id.t] and determines which ones of those should be + exported (i.e: included in the cmx files). +**) +val traverse + : sets_of_closures_map: Flambda.set_of_closures Set_of_closures_id.Map.t + -> closure_id_to_set_of_closures_id: + Set_of_closures_id.t Closure_id.Map.t + -> function_declarations_map: + Simple_value_approx.function_declarations Set_of_closures_id.Map.t + -> values: Export_info.descr Export_id.Map.t + -> symbol_id: Export_id.t Symbol.Map.t + -> root_symbol: Symbol.t + -> symbols_to_export diff --git a/middle_end/flambda/un_anf.ml b/middle_end/flambda/un_anf.ml new file mode 100644 index 00000000..50f9e7b1 --- /dev/null +++ b/middle_end/flambda/un_anf.ml @@ -0,0 +1,817 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +(* CR-someday vlaviron for mshinwell: I believe that the phantom lets introduced + in un_anf (when the new debug_full flag is enabled) bind mostly variables + that were created in the middle-end. Is it relevant to generate debugging + information for such variables ? I expect later pull requests to refine the + generation of these phantom constructions anyway, but maybe it would already + make sense to restrict the phantom let generation to variables with an actual + provenance. +*) + +module V = Backend_var +module VP = Backend_var.With_provenance + +(* We say that an [V.t] is "linear" iff: + (a) it is used exactly once; + (b) it is never assigned to (using [Uassign]). +*) +type var_info = + { used : V.Set.t; + linear : V.Set.t; + assigned : V.Set.t; + closure_environment : V.Set.t; + let_bound_vars_that_can_be_moved : V.Set.t; + } + +let ignore_uconstant (_ : Clambda.uconstant) = () +let ignore_ulambda (_ : Clambda.ulambda) = () +let ignore_ulambda_list (_ : Clambda.ulambda list) = () +let ignore_uphantom_defining_expr_option + (_ : Clambda.uphantom_defining_expr option) = () +let ignore_function_label (_ : Clambda.function_label) = () +let ignore_debuginfo (_ : Debuginfo.t) = () +let ignore_int (_ : int) = () +let ignore_var (_ : V.t) = () +let ignore_var_option (_ : V.t option) = () +let ignore_primitive (_ : Clambda_primitives.primitive) = () +let ignore_string (_ : string) = () +let ignore_int_array (_ : int array) = () +let ignore_var_with_provenance (_ : VP.t) = () +let ignore_params_with_value_kind (_ : (VP.t * Lambda.value_kind) list) = () +let ignore_direction_flag (_ : Asttypes.direction_flag) = () +let ignore_meth_kind (_ : Lambda.meth_kind) = () +let ignore_value_kind (_ : Lambda.value_kind) = () + +(* CR-soon mshinwell: check we aren't traversing function bodies more than + once (need to analyse exactly what the calls are from Cmmgen into this + module). *) + +let closure_environment_var (ufunction:Clambda.ufunction) = + (* The argument after the arity is the environment *) + if List.length ufunction.params = ufunction.arity + 1 then + let (env_var, _) = List.nth ufunction.params ufunction.arity in + assert (VP.name env_var = "env"); + Some env_var + else + (* closed function, no environment *) + None + +let make_var_info (clam : Clambda.ulambda) : var_info = + let t : int V.Tbl.t = V.Tbl.create 42 in + let assigned_vars = ref V.Set.empty in + let environment_vars = ref V.Set.empty in + let rec loop : Clambda.ulambda -> unit = function + (* No underscores in the pattern match, to reduce the chance of failing + to traverse some subexpression. *) + | Uvar var -> + begin match V.Tbl.find t var with + | n -> V.Tbl.replace t var (n + 1) + | exception Not_found -> V.Tbl.add t var 1 + end + | Uconst const -> + (* The only variables that might occur in [const] are those in constant + closures---and those are all bound by such closures. It follows that + [const] cannot contain any variables that are bound in the current + scope, so we do not need to count them here. (The function bodies + of the closures will be traversed when this function is called from + [Cmmgen.transl_function].) *) + ignore_uconstant const + | Udirect_apply (label, args, dbg) -> + ignore_function_label label; + List.iter loop args; + ignore_debuginfo dbg + | Ugeneric_apply (func, args, dbg) -> + loop func; + List.iter loop args; + ignore_debuginfo dbg + | Uclosure (functions, captured_variables) -> + List.iter loop captured_variables; + List.iter (fun ( + { Clambda. label; arity; params; return; body; dbg; env; } as clos) -> + (match closure_environment_var clos with + | None -> () + | Some env_var -> + environment_vars := + V.Set.add (VP.var env_var) !environment_vars); + ignore_function_label label; + ignore_int arity; + ignore_params_with_value_kind params; + ignore_value_kind return; + loop body; + ignore_debuginfo dbg; + ignore_var_option env) + functions + | Uoffset (expr, offset) -> + loop expr; + ignore_int offset + | Ulet (_let_kind, _value_kind, _var, def, body) -> + loop def; + loop body + | Uphantom_let (var, defining_expr_opt, body) -> + ignore_var_with_provenance var; + ignore_uphantom_defining_expr_option defining_expr_opt; + loop body + | Uletrec (defs, body) -> + List.iter (fun (var, def) -> + ignore_var_with_provenance var; + loop def) + defs; + loop body + | Uprim (prim, args, dbg) -> + ignore_primitive prim; + List.iter loop args; + ignore_debuginfo dbg + | Uswitch (cond, { us_index_consts; us_actions_consts; + us_index_blocks; us_actions_blocks }, dbg) -> + loop cond; + ignore_int_array us_index_consts; + Array.iter loop us_actions_consts; + ignore_int_array us_index_blocks; + Array.iter loop us_actions_blocks; + ignore_debuginfo dbg + | Ustringswitch (cond, branches, default) -> + loop cond; + List.iter (fun (str, branch) -> + ignore_string str; + loop branch) + branches; + Misc.may loop default + | Ustaticfail (static_exn, args) -> + ignore_int static_exn; + List.iter loop args + | Ucatch (static_exn, vars, body, handler) -> + ignore_int static_exn; + ignore_params_with_value_kind vars; + loop body; + loop handler + | Utrywith (body, var, handler) -> + loop body; + ignore_var_with_provenance var; + loop handler + | Uifthenelse (cond, ifso, ifnot) -> + loop cond; + loop ifso; + loop ifnot + | Usequence (e1, e2) -> + loop e1; + loop e2 + | Uwhile (cond, body) -> + loop cond; + loop body + | Ufor (var, low, high, direction_flag, body) -> + ignore_var_with_provenance var; + loop low; + loop high; + ignore_direction_flag direction_flag; + loop body + | Uassign (var, expr) -> + assigned_vars := V.Set.add var !assigned_vars; + loop expr + | Usend (meth_kind, e1, e2, args, dbg) -> + ignore_meth_kind meth_kind; + loop e1; + loop e2; + List.iter loop args; + ignore_debuginfo dbg + | Uunreachable -> + () + in + loop clam; + let linear = + V.Tbl.fold (fun var n acc -> + assert (n >= 1); + if n = 1 && not (V.Set.mem var !assigned_vars) + then V.Set.add var acc + else acc) + t V.Set.empty + in + let assigned = !assigned_vars in + let used = + (* This doesn't work transitively and thus is somewhat restricted. In + particular, it does not allow us to get rid of useless chains of [let]s. + However it should be sufficient to remove the majority of unnecessary + [let] bindings that might hinder [Cmmgen]. *) + V.Tbl.fold (fun var _n acc -> V.Set.add var acc) + t assigned + in + { used; linear; assigned; closure_environment = !environment_vars; + let_bound_vars_that_can_be_moved = V.Set.empty; + } + +(* When sequences of [let]-bindings match the evaluation order in a subsequent + primitive or function application whose arguments are linearly-used + non-assigned variables bound by such lets (possibly interspersed with other + variables that are known to be constant), and it is known that there were no + intervening side-effects during the evaluation of the [let]-bindings, + permit substitution of the variables for their defining expressions. *) +let let_bound_vars_that_can_be_moved var_info (clam : Clambda.ulambda) = + let obviously_constant = ref V.Set.empty in + let can_move = ref V.Set.empty in + let let_stack = ref [] in + let examine_argument_list args = + let rec loop let_bound_vars (args : Clambda.ulambda list) = + match let_bound_vars, args with + | _, [] -> + (* We've matched all arguments and will not substitute (in the + current application being considered) any of the remaining + [let_bound_vars]. As such they may stay on the stack. *) + let_bound_vars + | [], _ -> + (* There are no more [let]-bindings to consider, so the stack + is left empty. *) + [] + | let_bound_vars, (Uvar arg)::args + when V.Set.mem arg !obviously_constant -> + loop let_bound_vars args + | let_bound_var::let_bound_vars, (Uvar arg)::args + when V.same let_bound_var arg + && not (V.Set.mem arg var_info.assigned) -> + assert (V.Set.mem arg var_info.used); + assert (V.Set.mem arg var_info.linear); + can_move := V.Set.add arg !can_move; + loop let_bound_vars args + | _::_, _::_ -> + (* The [let] sequence has ceased to match the evaluation order + or we have encountered some complicated argument. In this case + we empty the stack to ensure that we do not end up moving an + outer [let] across a side effect. *) + [] + in + (* Start at the most recent let binding and the leftmost argument + (the last argument to be evaluated). *) + let_stack := loop !let_stack args + in + let rec loop : Clambda.ulambda -> unit = function + | Uvar var -> + if V.Set.mem var var_info.assigned then begin + let_stack := [] + end + | Uconst const -> + ignore_uconstant const + | Udirect_apply (label, args, dbg) -> + ignore_function_label label; + examine_argument_list args; + (* We don't currently traverse [args]; they should all be variables + anyway. If this is added in the future, take care to traverse [args] + following the evaluation order. *) + ignore_debuginfo dbg + | Ugeneric_apply (func, args, dbg) -> + examine_argument_list (args @ [func]); + ignore_debuginfo dbg + | Uclosure (functions, captured_variables) -> + ignore_ulambda_list captured_variables; + (* Start a new let stack for speed. *) + List.iter (fun {Clambda. label; arity; params; return; body; dbg; env} -> + ignore_function_label label; + ignore_int arity; + ignore_params_with_value_kind params; + ignore_value_kind return; + let_stack := []; + loop body; + let_stack := []; + ignore_debuginfo dbg; + ignore_var_option env) + functions + | Uoffset (expr, offset) -> + (* [expr] should usually be a variable. *) + examine_argument_list [expr]; + ignore_int offset + | Ulet (_let_kind, _value_kind, var, def, body) -> + let var = VP.var var in + begin match def with + | Uconst _ -> + (* The defining expression is obviously constant, so we don't + have to put this [let] on the stack, and we don't have to + traverse the defining expression either. *) + obviously_constant := V.Set.add var !obviously_constant; + loop body + | _ -> + loop def; + if V.Set.mem var var_info.linear then begin + let_stack := var::!let_stack + end else begin + (* If we encounter a non-linear [let]-binding then we must clear + the let stack, since we cannot now move any previous binding + across the non-linear one. *) + let_stack := [] + end; + loop body + end + | Uphantom_let (var, _defining_expr, body) -> + ignore_var_with_provenance var; + loop body + | Uletrec (defs, body) -> + (* Evaluation order for [defs] is not defined, and this case + probably isn't important for [Cmmgen] anyway. *) + let_stack := []; + List.iter (fun (var, def) -> + ignore_var_with_provenance var; + loop def; + let_stack := []) + defs; + loop body + | Uprim (prim, args, dbg) -> + ignore_primitive prim; + examine_argument_list args; + ignore_debuginfo dbg + | Uswitch (cond, { us_index_consts; us_actions_consts; + us_index_blocks; us_actions_blocks }, dbg) -> + examine_argument_list [cond]; + ignore_int_array us_index_consts; + Array.iter (fun action -> + let_stack := []; + loop action) + us_actions_consts; + ignore_int_array us_index_blocks; + Array.iter (fun action -> + let_stack := []; + loop action) + us_actions_blocks; + ignore_debuginfo dbg; + let_stack := [] + | Ustringswitch (cond, branches, default) -> + examine_argument_list [cond]; + List.iter (fun (str, branch) -> + ignore_string str; + let_stack := []; + loop branch) + branches; + let_stack := []; + Misc.may loop default; + let_stack := [] + | Ustaticfail (static_exn, args) -> + ignore_int static_exn; + examine_argument_list args + | Ucatch (static_exn, vars, body, handler) -> + ignore_int static_exn; + ignore_params_with_value_kind vars; + let_stack := []; + loop body; + let_stack := []; + loop handler; + let_stack := [] + | Utrywith (body, var, handler) -> + let_stack := []; + loop body; + let_stack := []; + ignore_var_with_provenance var; + loop handler; + let_stack := [] + | Uifthenelse (cond, ifso, ifnot) -> + examine_argument_list [cond]; + let_stack := []; + loop ifso; + let_stack := []; + loop ifnot; + let_stack := [] + | Usequence (e1, e2) -> + loop e1; + let_stack := []; + loop e2; + let_stack := [] + | Uwhile (cond, body) -> + let_stack := []; + loop cond; + let_stack := []; + loop body; + let_stack := [] + | Ufor (var, low, high, direction_flag, body) -> + ignore_var_with_provenance var; + (* Cmmgen generates code that evaluates low before high, + but we don't do anything here at the moment anyway. *) + ignore_ulambda low; + ignore_ulambda high; + ignore_direction_flag direction_flag; + let_stack := []; + loop body; + let_stack := [] + | Uassign (var, expr) -> + ignore_var var; + ignore_ulambda expr; + let_stack := [] + | Usend (meth_kind, e1, e2, args, dbg) -> + ignore_meth_kind meth_kind; + ignore_ulambda e1; + ignore_ulambda e2; + ignore_ulambda_list args; + let_stack := []; + ignore_debuginfo dbg + | Uunreachable -> + let_stack := [] + in + loop clam; + !can_move + +(* Substitution of an expression for a let-moveable variable can cause the + surrounding expression to become fixed. To avoid confusion, do the + let-moveable substitutions first. *) +let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda) + : Clambda.ulambda = + match clam with + | Uvar var -> + if not (V.Set.mem var is_let_moveable) then + clam + else + begin match V.Map.find var env with + | clam -> clam + | exception Not_found -> + Misc.fatal_errorf "substitute_let_moveable: Unbound variable %a" + V.print var + end + | Uconst _ -> clam + | Udirect_apply (label, args, dbg) -> + let args = substitute_let_moveable_list is_let_moveable env args in + Udirect_apply (label, args, dbg) + | Ugeneric_apply (func, args, dbg) -> + let func = substitute_let_moveable is_let_moveable env func in + let args = substitute_let_moveable_list is_let_moveable env args in + Ugeneric_apply (func, args, dbg) + | Uclosure (functions, variables_bound_by_the_closure) -> + let functions = + List.map (fun (ufunction : Clambda.ufunction) -> + { ufunction with + body = substitute_let_moveable is_let_moveable env ufunction.body; + }) + functions + in + let variables_bound_by_the_closure = + substitute_let_moveable_list is_let_moveable env + variables_bound_by_the_closure + in + Uclosure (functions, variables_bound_by_the_closure) + | Uoffset (clam, n) -> + let clam = substitute_let_moveable is_let_moveable env clam in + Uoffset (clam, n) + | Ulet (let_kind, value_kind, var, def, body) -> + let def = substitute_let_moveable is_let_moveable env def in + if V.Set.mem (VP.var var) is_let_moveable then + let env = V.Map.add (VP.var var) def env in + let body = substitute_let_moveable is_let_moveable env body in + (* If we are about to delete a [let] in debug mode, keep it for the + debugger. *) + (* CR-someday mshinwell: find out why some closure constructions were + not leaving phantom lets behind after substitution. *) + if not !Clflags.debug_full then + body + else + match def with + | Uconst const -> + Uphantom_let (var, Some (Clambda.Uphantom_const const), body) + | Uvar alias_of -> + Uphantom_let (var, Some (Clambda.Uphantom_var alias_of), body) + | _ -> + Uphantom_let (var, None, body) + else + Ulet (let_kind, value_kind, + var, def, substitute_let_moveable is_let_moveable env body) + | Uphantom_let (var, defining_expr, body) -> + let body = substitute_let_moveable is_let_moveable env body in + Uphantom_let (var, defining_expr, body) + | Uletrec (defs, body) -> + let defs = + List.map (fun (var, def) -> + var, substitute_let_moveable is_let_moveable env def) + defs + in + let body = substitute_let_moveable is_let_moveable env body in + Uletrec (defs, body) + | Uprim (prim, args, dbg) -> + let args = substitute_let_moveable_list is_let_moveable env args in + Uprim (prim, args, dbg) + | Uswitch (cond, sw, dbg) -> + let cond = substitute_let_moveable is_let_moveable env cond in + let sw = + { sw with + us_actions_consts = + substitute_let_moveable_array is_let_moveable env + sw.us_actions_consts; + us_actions_blocks = + substitute_let_moveable_array is_let_moveable env + sw.us_actions_blocks; + } + in + Uswitch (cond, sw, dbg) + | Ustringswitch (cond, branches, default) -> + let cond = substitute_let_moveable is_let_moveable env cond in + let branches = + List.map (fun (s, branch) -> + s, substitute_let_moveable is_let_moveable env branch) + branches + in + let default = + Misc.may_map (substitute_let_moveable is_let_moveable env) default + in + Ustringswitch (cond, branches, default) + | Ustaticfail (n, args) -> + let args = substitute_let_moveable_list is_let_moveable env args in + Ustaticfail (n, args) + | Ucatch (n, vars, body, handler) -> + let body = substitute_let_moveable is_let_moveable env body in + let handler = substitute_let_moveable is_let_moveable env handler in + Ucatch (n, vars, body, handler) + | Utrywith (body, var, handler) -> + let body = substitute_let_moveable is_let_moveable env body in + let handler = substitute_let_moveable is_let_moveable env handler in + Utrywith (body, var, handler) + | Uifthenelse (cond, ifso, ifnot) -> + let cond = substitute_let_moveable is_let_moveable env cond in + let ifso = substitute_let_moveable is_let_moveable env ifso in + let ifnot = substitute_let_moveable is_let_moveable env ifnot in + Uifthenelse (cond, ifso, ifnot) + | Usequence (e1, e2) -> + let e1 = substitute_let_moveable is_let_moveable env e1 in + let e2 = substitute_let_moveable is_let_moveable env e2 in + Usequence (e1, e2) + | Uwhile (cond, body) -> + let cond = substitute_let_moveable is_let_moveable env cond in + let body = substitute_let_moveable is_let_moveable env body in + Uwhile (cond, body) + | Ufor (var, low, high, direction, body) -> + let low = substitute_let_moveable is_let_moveable env low in + let high = substitute_let_moveable is_let_moveable env high in + let body = substitute_let_moveable is_let_moveable env body in + Ufor (var, low, high, direction, body) + | Uassign (var, expr) -> + let expr = substitute_let_moveable is_let_moveable env expr in + Uassign (var, expr) + | Usend (kind, e1, e2, args, dbg) -> + let e1 = substitute_let_moveable is_let_moveable env e1 in + let e2 = substitute_let_moveable is_let_moveable env e2 in + let args = substitute_let_moveable_list is_let_moveable env args in + Usend (kind, e1, e2, args, dbg) + | Uunreachable -> + Uunreachable + +and substitute_let_moveable_list is_let_moveable env clams = + List.map (substitute_let_moveable is_let_moveable env) clams + +and substitute_let_moveable_array is_let_moveable env clams = + Array.map (substitute_let_moveable is_let_moveable env) clams + +(* We say that an expression is "moveable" iff it has neither effects nor + coeffects. (See semantics_of_primitives.mli.) +*) +type moveable = Fixed | Constant | Moveable + +let both_moveable a b = + match a, b with + | Constant, Constant -> Constant + | Constant, Moveable + | Moveable, Constant + | Moveable, Moveable -> Moveable + | Constant, Fixed + | Moveable, Fixed + | Fixed, Constant + | Fixed, Moveable + | Fixed, Fixed -> Fixed + +let primitive_moveable (prim : Clambda_primitives.primitive) + (args : Clambda.ulambda list) + (var_info : var_info) = + match prim, args with + | Pfield _, [Uconst (Uconst_ref (_, _))] -> + (* CR-someday mshinwell: Actually, maybe this shouldn't be needed; these + should have been simplified to [Read_symbol_field], which doesn't yield + a Clambda let. This might be fixed when Inline_and_simplify can + turn Pfield into Read_symbol_field. *) + (* Allow field access of symbols to be moveable. (The comment in + flambda.mli on [Read_symbol_field] may be helpful to the reader.) *) + Moveable + | Pfield _, [Uvar var] when V.Set.mem var var_info.closure_environment -> + (* accesses to the function environment is coeffect free: this block + is never mutated *) + Moveable + | _ -> + match Semantics_of_primitives.for_primitive prim with + | No_effects, No_coeffects -> Moveable + | No_effects, Has_coeffects + | Only_generative_effects, No_coeffects + | Only_generative_effects, Has_coeffects + | Arbitrary_effects, No_coeffects + | Arbitrary_effects, Has_coeffects -> Fixed + +type moveable_for_env = Constant | Moveable + +(** Eliminate, through substitution, [let]-bindings of linear variables with + moveable defining expressions. *) +let rec un_anf_and_moveable var_info env (clam : Clambda.ulambda) + : Clambda.ulambda * moveable = + match clam with + | Uvar var -> + begin match V.Map.find var env with + | Constant, def -> def, Constant + | Moveable, def -> def, Moveable + | exception Not_found -> + let moveable : moveable = + if V.Set.mem var var_info.assigned then + Fixed + else + Moveable + in + clam, moveable + end + | Uconst _ -> + (* Constant closures are rewritten separately. *) + clam, Constant + | Udirect_apply (label, args, dbg) -> + let args = un_anf_list var_info env args in + Udirect_apply (label, args, dbg), Fixed + | Ugeneric_apply (func, args, dbg) -> + let func = un_anf var_info env func in + let args = un_anf_list var_info env args in + Ugeneric_apply (func, args, dbg), Fixed + | Uclosure (functions, variables_bound_by_the_closure) -> + let functions = + List.map (fun (ufunction : Clambda.ufunction) -> + { ufunction with + body = un_anf var_info env ufunction.body; + }) + functions + in + let variables_bound_by_the_closure = + un_anf_list var_info env variables_bound_by_the_closure + in + Uclosure (functions, variables_bound_by_the_closure), Fixed + | Uoffset (clam, n) -> + let clam, moveable = un_anf_and_moveable var_info env clam in + Uoffset (clam, n), both_moveable Moveable moveable + | Ulet (_let_kind, _value_kind, var, def, Uvar var') + when V.same (VP.var var) var' -> + un_anf_and_moveable var_info env def + | Ulet (let_kind, value_kind, var, def, body) -> + let def, def_moveable = un_anf_and_moveable var_info env def in + let is_linear = V.Set.mem (VP.var var) var_info.linear in + let is_used = V.Set.mem (VP.var var) var_info.used in + let is_assigned = V.Set.mem (VP.var var) var_info.assigned in + let maybe_for_debugger (body, moveable) : Clambda.ulambda * moveable = + if not !Clflags.debug_full then + body, moveable + else + match def with + | Uconst const -> + Uphantom_let (var, Some (Clambda.Uphantom_const const), + body), moveable + | Uvar alias_of -> + Uphantom_let (var, Some (Clambda.Uphantom_var alias_of), body), + moveable + | _ -> + Uphantom_let (var, None, body), moveable + in + begin match def_moveable, is_linear, is_used, is_assigned with + | (Constant | Moveable), _, false, _ -> + (* A moveable expression that is never used may be eliminated. + However, if in debug mode and the defining expression is + appropriate, keep the let (as a phantom let) for the debugger. *) + maybe_for_debugger (un_anf_and_moveable var_info env body) + | Constant, _, true, false + (* A constant expression bound to an unassigned variable can replace any + occurrences of the variable. The same comment as above concerning + phantom lets applies. *) + | Moveable, true, true, false -> + (* A moveable expression bound to a linear unassigned [V.t] + may replace the single occurrence of the variable. The same comment + as above concerning phantom lets applies. *) + let def_moveable = + match def_moveable with + | Moveable -> Moveable + | Constant -> Constant + | Fixed -> assert false + in + let env = V.Map.add (VP.var var) (def_moveable, def) env in + maybe_for_debugger (un_anf_and_moveable var_info env body) + | (Constant | Moveable), _, _, true + (* Constant or Moveable but assigned. *) + | Moveable, false, _, _ + (* Moveable but not used linearly. *) + | Fixed, _, _, _ -> + let body, body_moveable = un_anf_and_moveable var_info env body in + Ulet (let_kind, value_kind, var, def, body), + both_moveable def_moveable body_moveable + end + | Uphantom_let (var, defining_expr, body) -> + let body, body_moveable = un_anf_and_moveable var_info env body in + Uphantom_let (var, defining_expr, body), body_moveable + | Uletrec (defs, body) -> + let defs = + List.map (fun (var, def) -> var, un_anf var_info env def) defs + in + let body = un_anf var_info env body in + Uletrec (defs, body), Fixed + | Uprim (prim, args, dbg) -> + let args, args_moveable = un_anf_list_and_moveable var_info env args in + let moveable = + both_moveable args_moveable (primitive_moveable prim args var_info) + in + Uprim (prim, args, dbg), moveable + | Uswitch (cond, sw, dbg) -> + let cond = un_anf var_info env cond in + let sw = + { sw with + us_actions_consts = un_anf_array var_info env sw.us_actions_consts; + us_actions_blocks = un_anf_array var_info env sw.us_actions_blocks; + } + in + Uswitch (cond, sw, dbg), Fixed + | Ustringswitch (cond, branches, default) -> + let cond = un_anf var_info env cond in + let branches = + List.map (fun (s, branch) -> s, un_anf var_info env branch) + branches + in + let default = Misc.may_map (un_anf var_info env) default in + Ustringswitch (cond, branches, default), Fixed + | Ustaticfail (n, args) -> + let args = un_anf_list var_info env args in + Ustaticfail (n, args), Fixed + | Ucatch (n, vars, body, handler) -> + let body = un_anf var_info env body in + let handler = un_anf var_info env handler in + Ucatch (n, vars, body, handler), Fixed + | Utrywith (body, var, handler) -> + let body = un_anf var_info env body in + let handler = un_anf var_info env handler in + Utrywith (body, var, handler), Fixed + | Uifthenelse (cond, ifso, ifnot) -> + let cond, cond_moveable = un_anf_and_moveable var_info env cond in + let ifso, ifso_moveable = un_anf_and_moveable var_info env ifso in + let ifnot, ifnot_moveable = un_anf_and_moveable var_info env ifnot in + let moveable = + both_moveable cond_moveable + (both_moveable ifso_moveable ifnot_moveable) + in + Uifthenelse (cond, ifso, ifnot), moveable + | Usequence (e1, e2) -> + let e1 = un_anf var_info env e1 in + let e2 = un_anf var_info env e2 in + Usequence (e1, e2), Fixed + | Uwhile (cond, body) -> + let cond = un_anf var_info env cond in + let body = un_anf var_info env body in + Uwhile (cond, body), Fixed + | Ufor (var, low, high, direction, body) -> + let low = un_anf var_info env low in + let high = un_anf var_info env high in + let body = un_anf var_info env body in + Ufor (var, low, high, direction, body), Fixed + | Uassign (var, expr) -> + let expr = un_anf var_info env expr in + Uassign (var, expr), Fixed + | Usend (kind, e1, e2, args, dbg) -> + let e1 = un_anf var_info env e1 in + let e2 = un_anf var_info env e2 in + let args = un_anf_list var_info env args in + Usend (kind, e1, e2, args, dbg), Fixed + | Uunreachable -> + Uunreachable, Fixed + +and un_anf var_info env clam : Clambda.ulambda = + let clam, _moveable = un_anf_and_moveable var_info env clam in + clam + +and un_anf_list_and_moveable var_info env clams + : Clambda.ulambda list * moveable = + List.fold_right (fun clam (l, acc_moveable) -> + let clam, moveable = un_anf_and_moveable var_info env clam in + clam :: l, both_moveable moveable acc_moveable) + clams ([], (Moveable : moveable)) + +and un_anf_list var_info env clams : Clambda.ulambda list = + let clams, _moveable = un_anf_list_and_moveable var_info env clams in + clams + +and un_anf_array var_info env clams : Clambda.ulambda array = + Array.map (un_anf var_info env) clams + +let apply ~ppf_dump clam ~what = + let var_info = make_var_info clam in + let let_bound_vars_that_can_be_moved = + let_bound_vars_that_can_be_moved var_info clam + in + let clam = + substitute_let_moveable let_bound_vars_that_can_be_moved + V.Map.empty clam + in + let var_info = make_var_info clam in + let clam = un_anf var_info V.Map.empty clam in + if !Clflags.dump_clambda then begin + Format.fprintf ppf_dump + "@.un-anf (%s):@ %a@." what Printclambda.clambda clam + end; + clam diff --git a/middle_end/flambda/un_anf.mli b/middle_end/flambda/un_anf.mli new file mode 100644 index 00000000..92ea06cd --- /dev/null +++ b/middle_end/flambda/un_anf.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Expand ANF-like constructs so that pattern matches in [Cmmgen] will + work correctly. *) +val apply + : ppf_dump:Format.formatter + -> Clambda.ulambda + -> what:string + -> Clambda.ulambda diff --git a/middle_end/flambda/unbox_closures.ml b/middle_end/flambda/unbox_closures.ml new file mode 100644 index 00000000..5c86bed3 --- /dev/null +++ b/middle_end/flambda/unbox_closures.ml @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module ASA = Augment_specialised_args +module W = ASA.What_to_specialise +module E = Inline_and_simplify_aux.Env + +module Transform = struct + let pass_name = "unbox-closures" + + let precondition ~env ~(set_of_closures : Flambda.set_of_closures) = + !Clflags.unbox_closures + && not (E.at_toplevel env) + && not (Variable.Map.is_empty set_of_closures.free_vars) + + let what_to_specialise ~env ~(set_of_closures : Flambda.set_of_closures) = + let what_to_specialise = W.create ~set_of_closures in + if not (precondition ~env ~set_of_closures) then + what_to_specialise + else begin + let round = E.round env in + let num_closure_vars = Variable.Map.cardinal set_of_closures.free_vars in + let module B = Inlining_cost.Benefit in + let saved_by_not_building_closure = + (* For the moment assume that we're going to cause all functions in the + set to become closed. *) + B.remove_prims (B.remove_call B.zero) num_closure_vars + in + Flambda_iterators.fold_function_decls_ignoring_stubs set_of_closures + ~init:what_to_specialise + ~f:(fun ~fun_var ~(function_decl : Flambda.function_declaration) + what_to_specialise -> + let body_size = Inlining_cost.lambda_size function_decl.body in + (* If the function is small enough, make a direct call surrogate + for it, so that indirect calls are not penalised by having to + bounce through the stub. (Making such a surrogate involves + duplicating the function.) *) + let small_enough_to_duplicate = + let module W = Inlining_cost.Whether_sufficient_benefit in + let wsb = + W.create_estimate ~original_size:0 + ~toplevel:false + ~branch_depth:0 + ~new_size:((body_size / !Clflags.unbox_closures_factor) + 1) + ~benefit:saved_by_not_building_closure + ~lifting:false + ~round + in + W.evaluate wsb + in + let what_to_specialise = + if small_enough_to_duplicate then + W.make_direct_call_surrogate_for what_to_specialise ~fun_var + else + what_to_specialise + in + let bound_by_the_closure = + Flambda_utils.variables_bound_by_the_closure + (Closure_id.wrap fun_var) + set_of_closures.function_decls + in + Variable.Set.fold (fun inner_free_var what_to_specialise -> + W.new_specialised_arg what_to_specialise + ~fun_var ~group:inner_free_var + ~definition:(Existing_inner_free_var inner_free_var)) + bound_by_the_closure + what_to_specialise) + end +end + +include ASA.Make (Transform) diff --git a/middle_end/flambda/unbox_closures.mli b/middle_end/flambda/unbox_closures.mli new file mode 100644 index 00000000..fb935a62 --- /dev/null +++ b/middle_end/flambda/unbox_closures.mli @@ -0,0 +1,33 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Turn free variables of closures into specialised arguments. + The aim is to cause the closure to become closed. *) + +val rewrite_set_of_closures + : env:Inline_and_simplify_aux.Env.t + (* CR-soon mshinwell: eliminate superfluous parameter *) + -> duplicate_function:( + env:Inline_and_simplify_aux.Env.t + -> set_of_closures:Flambda.set_of_closures + -> fun_var:Variable.t + -> new_fun_var:Variable.t + -> Flambda.function_declaration + * Flambda.specialised_to Variable.Map.t) + -> set_of_closures:Flambda.set_of_closures + -> (Flambda.expr * Inlining_cost.Benefit.t) option diff --git a/middle_end/flambda/unbox_free_vars_of_closures.ml b/middle_end/flambda/unbox_free_vars_of_closures.ml new file mode 100644 index 00000000..7a4e48ed --- /dev/null +++ b/middle_end/flambda/unbox_free_vars_of_closures.ml @@ -0,0 +1,170 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module B = Inlining_cost.Benefit + +let pass_name = "unbox-free-vars-of-closures" +let () = Pass_wrapper.register ~pass_name + +(* CR-someday mshinwell: Nearly but not quite the same as something that + Augment_specialised_args uses. *) +let add_lifted_projections_around_set_of_closures + ~set_of_closures ~existing_inner_to_outer_vars ~benefit + ~definitions_indexed_by_new_inner_vars = + let body = + Flambda_utils.name_expr (Set_of_closures set_of_closures) + ~name:Internal_variable_names.unbox_free_vars_of_closures + in + Variable.Map.fold (fun new_inner_var (projection : Projection.t) + (expr, benefit) -> + let find_outer_var inner_var = + match + Variable.Map.find inner_var existing_inner_to_outer_vars + with + | (outer_var : Flambda.specialised_to) -> outer_var.var + | exception Not_found -> + Misc.fatal_errorf "(UFV) find_outer_var: expected %a \ + to be in [existing_inner_to_outer_vars], but it is \ + not. (The projection was: %a)" + Variable.print inner_var + Projection.print projection + in + let benefit = B.add_projection projection benefit in + let named : Flambda.named = + (* The lifted projection must be in terms of outer variables, + not inner variables. *) + let projection = + Projection.map_projecting_from projection ~f:find_outer_var + in + Flambda_utils.projection_to_named projection + in + let expr = + Flambda.create_let (find_outer_var new_inner_var) named expr + in + (expr, benefit)) + definitions_indexed_by_new_inner_vars + (body, benefit) + +let run ~env ~(set_of_closures : Flambda.set_of_closures) = + if not !Clflags.unbox_free_vars_of_closures then + None + else + let definitions_indexed_by_new_inner_vars, _, free_vars, done_something = + let all_existing_definitions = + Variable.Map.fold (fun _inner_var (outer_var : Flambda.specialised_to) + all_existing_definitions -> + match outer_var.projection with + | None -> all_existing_definitions + | Some projection -> + Projection.Set.add projection all_existing_definitions) + set_of_closures.free_vars + Projection.Set.empty + in + Flambda_iterators.fold_function_decls_ignoring_stubs set_of_closures + ~init:(Variable.Map.empty, all_existing_definitions, + set_of_closures.free_vars, false) + ~f:(fun ~fun_var:_ ~function_decl result -> + let extracted = + Extract_projections.from_function_decl ~env ~function_decl + ~which_variables:set_of_closures.free_vars + in + Projection.Set.fold (fun projection + ((definitions_indexed_by_new_inner_vars, + all_existing_definitions_including_added_ones, + additional_free_vars, _done_something) as result) -> + (* Don't add a new free variable if there already exists a + free variable with the desired projection. We need to + dedup not only across the existing free variables but + also across newly-added ones (unlike in + [Augment_specialised_args]), since free variables are + not local to a function declaration but rather to a + set of closures. *) + if Projection.Set.mem projection + all_existing_definitions_including_added_ones + then begin + result + end else begin + (* Add a new free variable. This needs both a fresh + "new inner" and a fresh "new outer" var, since we know + the definition is not a duplicate. *) + let projecting_from = Projection.projecting_from projection in + let new_inner_var = Variable.rename projecting_from in + let new_outer_var = Variable.rename projecting_from in + let definitions_indexed_by_new_inner_vars = + Variable.Map.add new_inner_var projection + definitions_indexed_by_new_inner_vars + in + let all_existing_definitions_including_added_ones = + Projection.Set.add projection + all_existing_definitions_including_added_ones + in + let new_outer_var : Flambda.specialised_to = + { var = new_outer_var; + projection = Some projection; + } + in + let additional_free_vars = + Variable.Map.add new_inner_var new_outer_var + additional_free_vars + in + definitions_indexed_by_new_inner_vars, + all_existing_definitions_including_added_ones, + additional_free_vars, + true + end) + extracted + result) + in + if not done_something then + None + else + (* CR-someday mshinwell: could consider doing the grouping thing + similar to Augment_specialised_args *) + let num_free_vars_before = + Variable.Map.cardinal set_of_closures.free_vars + in + let num_free_vars_after = + Variable.Map.cardinal free_vars + in + assert (num_free_vars_after > num_free_vars_before); + (* Don't let the closure grow too large. *) + if num_free_vars_after > 2 * num_free_vars_before then + None + else + let set_of_closures = + Flambda.create_set_of_closures + ~function_decls:set_of_closures.function_decls + ~free_vars + ~specialised_args:set_of_closures.specialised_args + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + in + let expr, benefit = + add_lifted_projections_around_set_of_closures ~set_of_closures + ~benefit:B.zero + ~existing_inner_to_outer_vars:set_of_closures.free_vars + ~definitions_indexed_by_new_inner_vars + in + Some (expr, benefit) + +let run ~env ~set_of_closures = + Pass_wrapper.with_dump ~ppf_dump:(Inline_and_simplify_aux.Env.ppf_dump env) + ~pass_name ~input:set_of_closures + ~print_input:Flambda.print_set_of_closures + ~print_output:(fun ppf (expr, _) -> Flambda.print ppf expr) + ~f:(fun () -> run ~env ~set_of_closures) diff --git a/middle_end/flambda/unbox_free_vars_of_closures.mli b/middle_end/flambda/unbox_free_vars_of_closures.mli new file mode 100644 index 00000000..3ee181ee --- /dev/null +++ b/middle_end/flambda/unbox_free_vars_of_closures.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** When approximations of free variables of closures indicate that they + are closures or blocks, rewrite projections from such blocks to new + variables (which become free in the closures), with the defining + expressions of the projections lifted out of the corresponding sets + of closures. *) + +val run + : env:Inline_and_simplify_aux.Env.t + -> set_of_closures:Flambda.set_of_closures + -> (Flambda.expr * Inlining_cost.Benefit.t) option diff --git a/middle_end/flambda/unbox_specialised_args.ml b/middle_end/flambda/unbox_specialised_args.ml new file mode 100644 index 00000000..70eb8760 --- /dev/null +++ b/middle_end/flambda/unbox_specialised_args.ml @@ -0,0 +1,103 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module ASA = Augment_specialised_args +module W = ASA.What_to_specialise + +module Transform = struct + let pass_name = "unbox-specialised-args" + + let precondition ~env:_ ~(set_of_closures : Flambda.set_of_closures) = + !Clflags.unbox_specialised_args + && not (Variable.Map.is_empty set_of_closures.specialised_args) + + let what_to_specialise ~env ~(set_of_closures : Flambda.set_of_closures) = + let what_to_specialise = W.create ~set_of_closures in + if not (precondition ~env ~set_of_closures) then + what_to_specialise + else + let projections_by_function = + Variable.Map.filter_map set_of_closures.function_decls.funs + ~f:(fun _fun_var (function_decl : Flambda.function_declaration) -> + if function_decl.stub then None + else + Some (Extract_projections.from_function_decl ~env + ~function_decl + ~which_variables:set_of_closures.specialised_args)) + in + (* CR-soon mshinwell: consider caching the Invariant_params *relation* + as well as the "_in_recursion" map *) + let invariant_params_flow = + Invariant_params.invariant_param_sources set_of_closures.function_decls + ~backend:(Inline_and_simplify_aux.Env.backend env) + in + Variable.Map.fold (fun fun_var extractions what_to_specialise -> + Projection.Set.fold (fun (projection : Projection.t) + what_to_specialise -> + let group = Projection.projecting_from projection in + assert (Variable.Map.mem group set_of_closures.specialised_args); + let what_to_specialise = + W.new_specialised_arg what_to_specialise ~fun_var ~group + ~definition:(Projection_from_existing_specialised_arg + projection) + in + match Variable.Map.find group invariant_params_flow with + | exception Not_found -> what_to_specialise + | flow -> + (* If for function [f] we would extract a projection expression + [e] from some specialised argument [x] of [f], and we know + from [Invariant_params] that a specialised argument [y] of + another function [g] flows to [x], we will add [e] with + [y] substituted for [x] throughout as a newly-specialised + argument for [g]. This should help reduce the number of + simplification rounds required for mutually-recursive + functions. *) + Variable.Pair.Set.fold (fun (target_fun_var, target_spec_arg) + what_to_specialise -> + if Variable.equal fun_var target_fun_var + || not (Variable.Map.mem target_spec_arg + set_of_closures.specialised_args) + then begin + what_to_specialise + end else begin + (* Rewrite the projection (that was in terms of an inner + specialised arg of [fun_var]) to be in terms of the + corresponding inner specialised arg of + [target_fun_var]. (The outer vars referenced in the + projection remain unchanged.) *) + let projection = + Projection.map_projecting_from projection + ~f:(fun var -> + assert (Variable.equal var group); + target_spec_arg) + in + W.new_specialised_arg what_to_specialise + ~fun_var:target_fun_var ~group + ~definition: + (Projection_from_existing_specialised_arg projection) + end) + flow + what_to_specialise) + extractions + what_to_specialise) + projections_by_function + what_to_specialise +end + +include ASA.Make (Transform) diff --git a/middle_end/flambda/unbox_specialised_args.mli b/middle_end/flambda/unbox_specialised_args.mli new file mode 100644 index 00000000..f0191764 --- /dev/null +++ b/middle_end/flambda/unbox_specialised_args.mli @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** When approximations of specialised arguments indicate that they are + closures or blocks, add more specialised arguments corresponding to + the projections from such blocks (with definitions of such projections + lifted out), such that the original specialised arguments may later be + eliminated. + + This in particular enables elimination of closure allocations in + examples such as: + + let rec map f = function + | [] -> [] + | a::l -> let r = f a in r :: map f l + + let g x = + map (fun y -> x + y) [1; 2; 3; 4] + + Here, the specialised version of [map] initially has a specialised + argument [f]; and upon inlining there will be a projection of [x] from + the closure of [f]. This pass adds a new specialised argument to carry + that projection, at which point the closure of [f] is redundant. +*) + +val rewrite_set_of_closures + : env:Inline_and_simplify_aux.Env.t + (* CR-soon mshinwell: eliminate superfluous parameter *) + -> duplicate_function:( + env:Inline_and_simplify_aux.Env.t + -> set_of_closures:Flambda.set_of_closures + -> fun_var:Variable.t + -> new_fun_var:Variable.t + -> Flambda.function_declaration + * Flambda.specialised_to Variable.Map.t) + -> set_of_closures:Flambda.set_of_closures + -> (Flambda.expr * Inlining_cost.Benefit.t) option diff --git a/middle_end/flambda_invariants.ml b/middle_end/flambda_invariants.ml deleted file mode 100755 index f236fd08..00000000 --- a/middle_end/flambda_invariants.ml +++ /dev/null @@ -1,828 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type flambda_kind = - | Normal - | Lifted - -(* Explicit "ignore" functions. We name every pattern variable, avoiding - underscores, to try to avoid accidentally failing to handle (for example) - a particular variable. - We also avoid explicit record field access during the checking functions, - preferring instead to use exhaustive record matches. -*) -(* CR-someday pchambart: for sum types, we should probably add an exhaustive - pattern in ignores functions to be reminded if a type change *) -let already_added_bound_variable_to_env (_ : Variable.t) = () -let will_traverse_named_expression_later (_ : Flambda.named) = () -let ignore_variable (_ : Variable.t) = () -let ignore_call_kind (_ : Flambda.call_kind) = () -let ignore_debuginfo (_ : Debuginfo.t) = () -let ignore_meth_kind (_ : Lambda.meth_kind) = () -let ignore_int (_ : int) = () -let ignore_int_set (_ : Numbers.Int.Set.t) = () -let ignore_bool (_ : bool) = () -let ignore_string (_ : string) = () -let ignore_static_exception (_ : Static_exception.t) = () -let ignore_direction_flag (_ : Asttypes.direction_flag) = () -let ignore_primitive ( _ : Lambda.primitive) = () -let ignore_const (_ : Flambda.const) = () -let ignore_allocated_const (_ : Allocated_const.t) = () -let ignore_set_of_closures_id (_ : Set_of_closures_id.t) = () -let ignore_set_of_closures_origin (_ : Set_of_closures_origin.t) = () -let ignore_closure_id (_ : Closure_id.t) = () -let ignore_var_within_closure (_ : Var_within_closure.t) = () -let ignore_tag (_ : Tag.t) = () -let ignore_inline_attribute (_ : Lambda.inline_attribute) = () -let ignore_specialise_attribute (_ : Lambda.specialise_attribute) = () -let ignore_value_kind (_ : Lambda.value_kind) = () - -exception Binding_occurrence_not_from_current_compilation_unit of Variable.t -exception Mutable_binding_occurrence_not_from_current_compilation_unit of - Mutable_variable.t -exception Binding_occurrence_of_variable_already_bound of Variable.t -exception Binding_occurrence_of_mutable_variable_already_bound of - Mutable_variable.t -exception Binding_occurrence_of_symbol_already_bound of Symbol.t -exception Unbound_variable of Variable.t -exception Unbound_mutable_variable of Mutable_variable.t -exception Unbound_symbol of Symbol.t -exception Vars_in_function_body_not_bound_by_closure_or_params of - Variable.Set.t * Flambda.set_of_closures * Variable.t -exception Function_decls_have_overlapping_parameters of Variable.Set.t -exception Specialised_arg_that_is_not_a_parameter of Variable.t -exception Projection_must_be_a_free_var of Projection.t -exception Projection_must_be_a_specialised_arg of Projection.t -exception Free_variables_set_is_lying of - Variable.t * Variable.Set.t * Variable.Set.t * Flambda.function_declaration -exception Set_of_closures_free_vars_map_has_wrong_range of Variable.Set.t -exception Static_exception_not_caught of Static_exception.t -exception Static_exception_caught_in_multiple_places of Static_exception.t -exception Access_to_global_module_identifier of Lambda.primitive -exception Pidentity_should_not_occur -exception Pdirapply_should_be_expanded -exception Prevapply_should_be_expanded -exception Sequential_logical_operator_primitives_must_be_expanded of - Lambda.primitive -exception Var_within_closure_bound_multiple_times of Var_within_closure.t -exception Declared_closure_from_another_unit of Compilation_unit.t -exception Closure_id_is_bound_multiple_times of Closure_id.t -exception Set_of_closures_id_is_bound_multiple_times of Set_of_closures_id.t -exception Unbound_closure_ids of Closure_id.Set.t -exception Unbound_vars_within_closures of Var_within_closure.Set.t -exception Move_to_a_closure_not_in_the_free_variables - of Variable.t * Variable.Set.t - -exception Flambda_invariants_failed - -(* CR-someday mshinwell: We should make "direct applications should not have - overapplication" be an invariant throughout. At the moment I think this is - only true after [Inline_and_simplify] has split overapplications. *) - -(* CR-someday mshinwell: What about checks for shadowed variables and - symbols? *) - -let variable_and_symbol_invariants (program : Flambda.program) = - let all_declared_variables = ref Variable.Set.empty in - let declare_variable var = - if Variable.Set.mem var !all_declared_variables then - raise (Binding_occurrence_of_variable_already_bound var); - all_declared_variables := Variable.Set.add var !all_declared_variables - in - let declare_variables vars = - Variable.Set.iter declare_variable vars - in - let all_declared_mutable_variables = ref Mutable_variable.Set.empty in - let declare_mutable_variable mut_var = - if Mutable_variable.Set.mem mut_var !all_declared_mutable_variables then - raise (Binding_occurrence_of_mutable_variable_already_bound mut_var); - all_declared_mutable_variables := - Mutable_variable.Set.add mut_var !all_declared_mutable_variables - in - let add_binding_occurrence (var_env, mut_var_env, sym_env) var = - let compilation_unit = Compilation_unit.get_current_exn () in - if not (Variable.in_compilation_unit var compilation_unit) then - raise (Binding_occurrence_not_from_current_compilation_unit var); - declare_variable var; - Variable.Set.add var var_env, mut_var_env, sym_env - in - let add_mutable_binding_occurrence (var_env, mut_var_env, sym_env) mut_var = - let compilation_unit = Compilation_unit.get_current_exn () in - if not (Mutable_variable.in_compilation_unit mut_var compilation_unit) then - raise (Mutable_binding_occurrence_not_from_current_compilation_unit - mut_var); - declare_mutable_variable mut_var; - var_env, Mutable_variable.Set.add mut_var mut_var_env, sym_env - in - let add_binding_occurrence_of_symbol (var_env, mut_var_env, sym_env) sym = - if Symbol.Set.mem sym sym_env then - raise (Binding_occurrence_of_symbol_already_bound sym) - else - var_env, mut_var_env, Symbol.Set.add sym sym_env - in - let add_binding_occurrences env vars = - List.fold_left (fun env var -> add_binding_occurrence env var) env vars - in - let check_variable_is_bound (var_env, _, _) var = - if not (Variable.Set.mem var var_env) then raise (Unbound_variable var) - in - let check_symbol_is_bound (_, _, sym_env) sym = - if not (Symbol.Set.mem sym sym_env) then raise (Unbound_symbol sym) - in - let check_variables_are_bound env vars = - List.iter (check_variable_is_bound env) vars - in - let check_mutable_variable_is_bound (_, mut_var_env, _) mut_var = - if not (Mutable_variable.Set.mem mut_var mut_var_env) then begin - raise (Unbound_mutable_variable mut_var) - end - in - let rec loop env (flam : Flambda.t) = - match flam with - (* Expressions that can bind [Variable.t]s: *) - | Let { var; defining_expr; body; _ } -> - loop_named env defining_expr; - loop (add_binding_occurrence env var) body - | Let_mutable { var = mut_var; initial_value = var; - body; contents_kind } -> - ignore_value_kind contents_kind; - check_variable_is_bound env var; - loop (add_mutable_binding_occurrence env mut_var) body - | Let_rec (defs, body) -> - let env = - List.fold_left (fun env (var, def) -> - will_traverse_named_expression_later def; - add_binding_occurrence env var) - env defs - in - List.iter (fun (var, def) -> - already_added_bound_variable_to_env var; - loop_named env def) defs; - loop env body - | For { bound_var; from_value; to_value; direction; body; } -> - ignore_direction_flag direction; - check_variable_is_bound env from_value; - check_variable_is_bound env to_value; - loop (add_binding_occurrence env bound_var) body - | Static_catch (static_exn, vars, body, handler) -> - ignore_static_exception static_exn; - loop env body; - loop (add_binding_occurrences env vars) handler - | Try_with (body, var, handler) -> - loop env body; - loop (add_binding_occurrence env var) handler - (* Everything else: *) - | Var var -> check_variable_is_bound env var - | Apply { func; args; kind; dbg; inline; specialise; } -> - check_variable_is_bound env func; - check_variables_are_bound env args; - ignore_call_kind kind; - ignore_debuginfo dbg; - ignore_inline_attribute inline; - ignore_specialise_attribute specialise - | Assign { being_assigned; new_value; } -> - check_mutable_variable_is_bound env being_assigned; - check_variable_is_bound env new_value - | Send { kind; meth; obj; args; dbg; } -> - ignore_meth_kind kind; - check_variable_is_bound env meth; - check_variable_is_bound env obj; - check_variables_are_bound env args; - ignore_debuginfo dbg - | If_then_else (cond, ifso, ifnot) -> - check_variable_is_bound env cond; - loop env ifso; - loop env ifnot - | Switch (arg, { numconsts; consts; numblocks; blocks; failaction; }) -> - check_variable_is_bound env arg; - ignore_int_set numconsts; - ignore_int_set numblocks; - List.iter (fun (n, e) -> - ignore_int n; - loop env e) - (consts @ blocks); - Misc.may (loop env) failaction - | String_switch (arg, cases, e_opt) -> - check_variable_is_bound env arg; - List.iter (fun (label, case) -> - ignore_string label; - loop env case) - cases; - Misc.may (loop env) e_opt - | Static_raise (static_exn, es) -> - ignore_static_exception static_exn; - List.iter (check_variable_is_bound env) es - | While (e1, e2) -> - loop env e1; - loop env e2 - | Proved_unreachable -> () - and loop_named env (named : Flambda.named) = - match named with - | Symbol symbol -> check_symbol_is_bound env symbol - | Const const -> ignore_const const - | Allocated_const const -> ignore_allocated_const const - | Read_mutable mut_var -> - check_mutable_variable_is_bound env mut_var - | Read_symbol_field (symbol, index) -> - check_symbol_is_bound env symbol; - assert (index >= 0) (* CR-someday mshinwell: add proper error *) - | Set_of_closures set_of_closures -> - loop_set_of_closures env set_of_closures - | Project_closure { set_of_closures; closure_id; } -> - check_variable_is_bound env set_of_closures; - ignore_closure_id closure_id - | Move_within_set_of_closures { closure; start_from; move_to; } -> - check_variable_is_bound env closure; - ignore_closure_id start_from; - ignore_closure_id move_to; - | Project_var { closure; closure_id; var; } -> - check_variable_is_bound env closure; - ignore_closure_id closure_id; - ignore_var_within_closure var - | Prim (prim, args, dbg) -> - ignore_primitive prim; - check_variables_are_bound env args; - ignore_debuginfo dbg - | Expr expr -> - loop env expr - and loop_set_of_closures env - ({ Flambda.function_decls; free_vars; specialised_args; - direct_call_surrogates = _; } as set_of_closures) = - (* CR-soon mshinwell: check [direct_call_surrogates] *) - let { Flambda. is_classic_mode; - set_of_closures_id; set_of_closures_origin; funs; } = - function_decls - in - ignore (is_classic_mode : bool); - ignore_set_of_closures_id set_of_closures_id; - ignore_set_of_closures_origin set_of_closures_origin; - let functions_in_closure = Variable.Map.keys funs in - let variables_in_closure = - Variable.Map.fold (fun var (var_in_closure : Flambda.specialised_to) - variables_in_closure -> - (* [var] may occur in the body, but will effectively be renamed - to [var_in_closure], so the latter is what we check to make - sure it's bound. *) - ignore_variable var; - check_variable_is_bound env var_in_closure.var; - Variable.Set.add var variables_in_closure) - free_vars Variable.Set.empty - in - let all_params, all_free_vars = - Variable.Map.fold (fun fun_var function_decl acc -> - let all_params, all_free_vars = acc in - (* CR-soon mshinwell: check function_decl.all_symbols *) - let { Flambda.params; body; free_variables; stub; dbg; _ } = - function_decl - in - assert (Variable.Set.mem fun_var functions_in_closure); - ignore_bool stub; - ignore_debuginfo dbg; - (* Check that [free_variables], which is only present as an - optimization, is not lying. *) - let free_variables' = Flambda.free_variables body in - if not (Variable.Set.subset free_variables' free_variables) then - raise (Free_variables_set_is_lying (fun_var, - free_variables, free_variables', function_decl)); - (* Check that every variable free in the body of the function is - bound by either the set of closures or the parameter list. *) - let acceptable_free_variables = - Variable.Set.union - (Variable.Set.union variables_in_closure functions_in_closure) - (Parameter.Set.vars params) - in - let bad = - Variable.Set.diff free_variables acceptable_free_variables - in - if not (Variable.Set.is_empty bad) then begin - raise (Vars_in_function_body_not_bound_by_closure_or_params - (bad, set_of_closures, fun_var)) - end; - (* Check that parameters are unique across all functions in the - declaration. *) - let old_all_params_size = Variable.Set.cardinal all_params in - let params = Parameter.Set.vars params in - let params_size = Variable.Set.cardinal params in - let all_params = Variable.Set.union all_params params in - let all_params_size = Variable.Set.cardinal all_params in - if all_params_size <> old_all_params_size + params_size then begin - raise (Function_decls_have_overlapping_parameters all_params) - end; - (* Check that parameters and function variables are not - bound somewhere else in the program *) - declare_variables params; - declare_variable fun_var; - (* Check that the body of the functions is correctly structured *) - let body_env = - let (var_env, _, sym_env) = env in - let var_env = - Variable.Set.fold (fun var -> Variable.Set.add var) - free_variables var_env - in - (* Mutable variables cannot be captured by closures *) - let mut_env = Mutable_variable.Set.empty in - (var_env, mut_env, sym_env) - in - loop body_env body; - all_params, Variable.Set.union free_variables all_free_vars) - funs (Variable.Set.empty, Variable.Set.empty) - in - (* CR-soon pchambart: This is not a property that we can certainly - ensure. - If the function get inlined, it is possible for the inlined version - to still use that variable. To be able to ensure that, we need to - also ensure that the inlined version will certainly be transformed - in a same way that can drop the dependency. - mshinwell: This should get some thought after the first release to - decide for sure what to do. *) - (* Check that the free variables rewriting map in the set of closures - does not contain variables in its domain that are not actually free - variables of any of the function bodies. *) - let bad_free_vars = - Variable.Set.diff (Variable.Map.keys free_vars) all_free_vars - in -(* - if not (Variable.Set.is_empty bad_free_vars) then begin - raise (Set_of_closures_free_vars_map_has_wrong_range bad_free_vars) - end; -*) - (* CR-someday pchambart: Ignore it to avoid the warning: get rid of that - when the case is settled *) - ignore (Set_of_closures_free_vars_map_has_wrong_range bad_free_vars); - (* Check that free variables are not bound somewhere - else in the program *) - declare_variables (Variable.Map.keys free_vars); - (* Check that every "specialised arg" is a parameter of one of the - functions being declared, and that the variable to which the - parameter is being specialised is bound. *) - Variable.Map.iter (fun _inner_var - (specialised_to : Flambda.specialised_to) -> - check_variable_is_bound env specialised_to.var; - match specialised_to.projection with - | None -> () - | Some projection -> - let projecting_from = Projection.projecting_from projection in - if not (Variable.Map.mem projecting_from free_vars) - then begin - raise (Projection_must_be_a_free_var projection) - end) - free_vars; - Variable.Map.iter (fun being_specialised - (specialised_to : Flambda.specialised_to) -> - if not (Variable.Set.mem being_specialised all_params) then begin - raise (Specialised_arg_that_is_not_a_parameter being_specialised) - end; - check_variable_is_bound env specialised_to.var; - match specialised_to.projection with - | None -> () - | Some projection -> - let projecting_from = Projection.projecting_from projection in - if not (Variable.Map.mem projecting_from specialised_args) - then begin - raise (Projection_must_be_a_specialised_arg projection) - end) - specialised_args - in - let loop_constant_defining_value env - (const : Flambda.constant_defining_value) = - match const with - | Flambda.Allocated_const c -> - ignore_allocated_const c - | Flambda.Block (tag,fields) -> - ignore_tag tag; - List.iter (fun (fields : Flambda.constant_defining_value_block_field) -> - match fields with - | Const c -> ignore_const c - | Symbol s -> check_symbol_is_bound env s) - fields - | Flambda.Set_of_closures set_of_closures -> - loop_set_of_closures env set_of_closures; - (* Constant set of closures must not have free variables *) - if not (Variable.Map.is_empty set_of_closures.free_vars) then - assert false; (* TODO: correct error *) - if not (Variable.Map.is_empty set_of_closures.specialised_args) then - assert false; (* TODO: correct error *) - | Flambda.Project_closure (symbol,closure_id) -> - ignore_closure_id closure_id; - check_symbol_is_bound env symbol - in - let rec loop_program_body env (program : Flambda.program_body) = - match program with - | Let_rec_symbol (defs, program) -> - let env = - List.fold_left (fun env (symbol, _) -> - add_binding_occurrence_of_symbol env symbol) - env defs - in - List.iter (fun (_, def) -> - loop_constant_defining_value env def) - defs; - loop_program_body env program - | Let_symbol (symbol, def, program) -> - loop_constant_defining_value env def; - let env = add_binding_occurrence_of_symbol env symbol in - loop_program_body env program - | Initialize_symbol (symbol, _tag, fields, program) -> - List.iter (loop env) fields; - let env = add_binding_occurrence_of_symbol env symbol in - loop_program_body env program - | Effect (expr, program) -> - loop env expr; - loop_program_body env program - | End root -> - check_symbol_is_bound env root - in - let env = - Symbol.Set.fold (fun symbol env -> - add_binding_occurrence_of_symbol env symbol) - program.imported_symbols - (Variable.Set.empty, Mutable_variable.Set.empty, Symbol.Set.empty) - in - loop_program_body env program.program_body - -let primitive_invariants flam ~no_access_to_global_module_identifiers = - Flambda_iterators.iter_named (function - | Prim (prim, _, _) -> - begin match prim with - | Psequand | Psequor -> - raise (Sequential_logical_operator_primitives_must_be_expanded prim) - | Pgetglobal id -> - if no_access_to_global_module_identifiers - && not (Ident.is_predef id) then - begin - raise (Access_to_global_module_identifier prim) - end - | Pidentity -> raise Pidentity_should_not_occur - | Pdirapply -> raise Pdirapply_should_be_expanded - | Prevapply -> raise Prevapply_should_be_expanded - | _ -> () - end - | _ -> ()) - flam - -let declared_var_within_closure (flam:Flambda.program) = - let bound = ref Var_within_closure.Set.empty in - let bound_multiple_times = ref None in - let add_and_check var = - if Var_within_closure.Set.mem var !bound then begin - bound_multiple_times := Some var - end; - bound := Var_within_closure.Set.add var !bound - in - Flambda_iterators.iter_on_set_of_closures_of_program - ~f:(fun ~constant:_ { Flambda. free_vars; _ } -> - Variable.Map.iter (fun id _ -> - let var = Var_within_closure.wrap id in - add_and_check var) - free_vars) - flam; - !bound, !bound_multiple_times - -let no_var_within_closure_is_bound_multiple_times (flam:Flambda.program) = - match declared_var_within_closure flam with - | _, Some var -> raise (Var_within_closure_bound_multiple_times var) - | _, None -> () - -let every_declared_closure_is_from_current_compilation_unit flam = - let current_compilation_unit = Compilation_unit.get_current_exn () in - Flambda_iterators.iter_on_sets_of_closures (fun - { Flambda. function_decls; _ } -> - let compilation_unit = - Set_of_closures_id.get_compilation_unit - function_decls.set_of_closures_id - in - if not (Compilation_unit.equal compilation_unit current_compilation_unit) - then raise (Declared_closure_from_another_unit compilation_unit)) - flam - -let declared_closure_ids program = - let bound = ref Closure_id.Set.empty in - let bound_multiple_times = ref None in - let add_and_check var = - if Closure_id.Set.mem var !bound - then bound_multiple_times := Some var; - bound := Closure_id.Set.add var !bound - in - Flambda_iterators.iter_on_set_of_closures_of_program program - ~f:(fun ~constant:_ { Flambda. function_decls; _; } -> - Variable.Map.iter (fun id _ -> - let var = Closure_id.wrap id in - add_and_check var) - function_decls.funs); - !bound, !bound_multiple_times - -let no_closure_id_is_bound_multiple_times program = - match declared_closure_ids program with - | _, Some closure_id -> - raise (Closure_id_is_bound_multiple_times closure_id) - | _, None -> () - -let declared_set_of_closures_ids program = - let bound = ref Set_of_closures_id.Set.empty in - let bound_multiple_times = ref None in - let add_and_check var = - if Set_of_closures_id.Set.mem var !bound - then bound_multiple_times := Some var; - bound := Set_of_closures_id.Set.add var !bound - in - Flambda_iterators.iter_on_set_of_closures_of_program program - ~f:(fun ~constant:_ { Flambda. function_decls; _; } -> - add_and_check function_decls.set_of_closures_id); - !bound, !bound_multiple_times - -let no_set_of_closures_id_is_bound_multiple_times program = - match declared_set_of_closures_ids program with - | _, Some set_of_closures_id -> - raise (Set_of_closures_id_is_bound_multiple_times set_of_closures_id) - | _, None -> () - -let used_closure_ids (program:Flambda.program) = - let used = ref Closure_id.Set.empty in - let f (flam : Flambda.named) = - match flam with - | Project_closure { closure_id; _} -> - used := Closure_id.Set.add closure_id !used; - | Move_within_set_of_closures { closure = _; start_from; move_to; } -> - used := Closure_id.Set.add start_from !used; - used := Closure_id.Set.add move_to !used - | Project_var { closure = _; closure_id; var = _ } -> - used := Closure_id.Set.add closure_id !used - | Set_of_closures _ | Symbol _ | Const _ | Allocated_const _ - | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _ -> () - in - (* CR-someday pchambart: check closure_ids of constant_defining_values' - project_closures *) - Flambda_iterators.iter_named_of_program ~f program; - !used - -let used_vars_within_closures (flam:Flambda.program) = - let used = ref Var_within_closure.Set.empty in - let f (flam : Flambda.named) = - match flam with - | Project_var { closure = _; closure_id = _; var; } -> - used := Var_within_closure.Set.add var !used - | _ -> () - in - Flambda_iterators.iter_named_of_program ~f flam; - !used - -let every_used_function_from_current_compilation_unit_is_declared - (program:Flambda.program) = - let current_compilation_unit = Compilation_unit.get_current_exn () in - let declared, _ = declared_closure_ids program in - let used = used_closure_ids program in - let used_from_current_unit = - Closure_id.Set.filter (fun cu -> - Closure_id.in_compilation_unit cu current_compilation_unit) - used - in - let counter_examples = - Closure_id.Set.diff used_from_current_unit declared - in - if Closure_id.Set.is_empty counter_examples - then () - else raise (Unbound_closure_ids counter_examples) - -let every_used_var_within_closure_from_current_compilation_unit_is_declared - (flam:Flambda.program) = - let current_compilation_unit = Compilation_unit.get_current_exn () in - let declared, _ = declared_var_within_closure flam in - let used = used_vars_within_closures flam in - let used_from_current_unit = - Var_within_closure.Set.filter (fun cu -> - Var_within_closure.in_compilation_unit cu current_compilation_unit) - used - in - let counter_examples = - Var_within_closure.Set.diff used_from_current_unit declared in - if Var_within_closure.Set.is_empty counter_examples - then () - else raise (Unbound_vars_within_closures counter_examples) - -let every_static_exception_is_caught flam = - let check env (flam : Flambda.t) = - match flam with - | Static_raise (exn, _) -> - if not (Static_exception.Set.mem exn env) - then raise (Static_exception_not_caught exn) - | _ -> () - in - let rec loop env (flam : Flambda.t) = - match flam with - | Static_catch (i, _, body, handler) -> - let env = Static_exception.Set.add i env in - loop env handler; - loop env body - | exp -> - check env exp; - Flambda_iterators.apply_on_subexpressions (loop env) - (fun (_ : Flambda.named) -> ()) exp - in - loop Static_exception.Set.empty flam - -let every_static_exception_is_caught_at_a_single_position flam = - let caught = ref Static_exception.Set.empty in - let f (flam : Flambda.t) = - match flam with - | Static_catch (i, _, _body, _handler) -> - if Static_exception.Set.mem i !caught then - raise (Static_exception_caught_in_multiple_places i); - caught := Static_exception.Set.add i !caught - | _ -> () - in - Flambda_iterators.iter f (fun (_ : Flambda.named) -> ()) flam - -let _every_move_within_set_of_closures_is_to_a_function_in_the_free_vars - program = - let moves = ref Closure_id.Map.empty in - Flambda_iterators.iter_named_of_program program - ~f:(function - | Move_within_set_of_closures { start_from; move_to; _ } -> - let moved_to = - try Closure_id.Map.find start_from !moves with - | Not_found -> Closure_id.Set.empty - in - moves := - Closure_id.Map.add start_from - (Closure_id.Set.add move_to moved_to) - !moves - | _ -> ()); - Flambda_iterators.iter_on_set_of_closures_of_program program - ~f:(fun ~constant:_ { Flambda.function_decls = { funs; _ }; _ } -> - Variable.Map.iter (fun fun_var { Flambda.free_variables; _ } -> - match Closure_id.Map.find (Closure_id.wrap fun_var) !moves with - | exception Not_found -> () - | moved_to -> - let missing_dependencies = - Variable.Set.diff (Closure_id.unwrap_set moved_to) - free_variables - in - if not (Variable.Set.is_empty missing_dependencies) then - raise (Move_to_a_closure_not_in_the_free_variables - (fun_var, missing_dependencies))) - funs) - -let check_exn ?(kind=Normal) ?(cmxfile=false) (flam:Flambda.program) = - ignore kind; - try - variable_and_symbol_invariants flam; - no_closure_id_is_bound_multiple_times flam; - no_set_of_closures_id_is_bound_multiple_times flam; - every_used_function_from_current_compilation_unit_is_declared flam; - no_var_within_closure_is_bound_multiple_times flam; - every_used_var_within_closure_from_current_compilation_unit_is_declared - flam; - (* CR-soon pchambart: This invariant is not maintained. It should be - either relaxed or reformulated. Currently, it is safe to disable it as - the potential related errors would result in fatal errors, not in - miscompilations *) - (* every_move_within_set_of_closures_is_to_a_function_in_the_free_vars - flam; *) - Flambda_iterators.iter_exprs_at_toplevel_of_program flam ~f:(fun flam -> - primitive_invariants flam ~no_access_to_global_module_identifiers:cmxfile; - every_static_exception_is_caught flam; - every_static_exception_is_caught_at_a_single_position flam; - every_declared_closure_is_from_current_compilation_unit flam) - with exn -> begin - (* CR-someday split printing code into its own function *) - begin match exn with - | Binding_occurrence_not_from_current_compilation_unit var -> - Format.eprintf ">> Binding occurrence of variable marked as not being \ - from the current compilation unit: %a" - Variable.print var - | Mutable_binding_occurrence_not_from_current_compilation_unit mut_var -> - Format.eprintf ">> Binding occurrence of mutable variable marked as not \ - being from the current compilation unit: %a" - Mutable_variable.print mut_var - | Binding_occurrence_of_variable_already_bound var -> - Format.eprintf ">> Binding occurrence of variable that was already \ - bound: %a" - Variable.print var - | Binding_occurrence_of_mutable_variable_already_bound mut_var -> - Format.eprintf ">> Binding occurrence of mutable variable that was \ - already bound: %a" - Mutable_variable.print mut_var - | Binding_occurrence_of_symbol_already_bound sym -> - Format.eprintf ">> Binding occurrence of symbol that was already \ - bound: %a" - Symbol.print sym - | Unbound_variable var -> - Format.eprintf ">> Unbound variable: %a" Variable.print var - | Unbound_mutable_variable mut_var -> - Format.eprintf ">> Unbound mutable variable: %a" - Mutable_variable.print mut_var - | Unbound_symbol sym -> - Format.eprintf ">> Unbound symbol: %a %s" - Symbol.print sym - (Printexc.raw_backtrace_to_string (Printexc.get_callstack 100)) - | Vars_in_function_body_not_bound_by_closure_or_params - (vars, set_of_closures, fun_var) -> - Format.eprintf ">> Variable(s) (%a) in the body of a function \ - declaration (fun_var = %a) that is not bound by either the closure \ - or the function's parameter list. Set of closures: %a" - Variable.Set.print vars - Variable.print fun_var - Flambda.print_set_of_closures set_of_closures - | Function_decls_have_overlapping_parameters vars -> - Format.eprintf ">> Function declarations whose parameters overlap: \ - %a" - Variable.Set.print vars - | Specialised_arg_that_is_not_a_parameter var -> - Format.eprintf ">> Variable in [specialised_args] that is not a \ - parameter of any of the function(s) in the corresponding \ - declaration(s): %a" - Variable.print var - | Projection_must_be_a_free_var var -> - Format.eprintf ">> Projection %a in [free_vars] from a variable that is \ - not a (inner) free variable of the set of closures" - Projection.print var - | Projection_must_be_a_specialised_arg var -> - Format.eprintf ">> Projection %a in [specialised_args] from a variable \ - that is not a (inner) specialised argument variable of the set of \ - closures" - Projection.print var - | Free_variables_set_is_lying (var, claimed, calculated, function_decl) -> - Format.eprintf ">> Function declaration whose [free_variables] set (%a) \ - is not a superset of the result of [Flambda.free_variables] \ - applied to the body of the function (%a). Declaration: %a" - Variable.Set.print claimed - Variable.Set.print calculated - Flambda.print_function_declaration (var, function_decl) - | Set_of_closures_free_vars_map_has_wrong_range vars -> - Format.eprintf ">> [free_vars] map in set of closures has in its range \ - variables that are not free variables of the corresponding \ - functions: %a" - Variable.Set.print vars - | Sequential_logical_operator_primitives_must_be_expanded prim -> - Format.eprintf ">> Sequential logical operator primitives must be \ - expanded (see closure_conversion.ml): %a" - Printlambda.primitive prim - | Var_within_closure_bound_multiple_times var -> - Format.eprintf ">> Variable within a closure is bound multiple times: \ - %a" - Var_within_closure.print var - | Closure_id_is_bound_multiple_times closure_id -> - Format.eprintf ">> Closure ID is bound multiple times: %a" - Closure_id.print closure_id - | Set_of_closures_id_is_bound_multiple_times set_of_closures_id -> - Format.eprintf ">> Set of closures ID is bound multiple times: %a" - Set_of_closures_id.print set_of_closures_id - | Declared_closure_from_another_unit compilation_unit -> - Format.eprintf ">> Closure declared as being from another compilation \ - unit: %a" - Compilation_unit.print compilation_unit - | Unbound_closure_ids closure_ids -> - Format.eprintf ">> Unbound closure ID(s) from the current compilation \ - unit: %a" - Closure_id.Set.print closure_ids - | Unbound_vars_within_closures vars_within_closures -> - Format.eprintf ">> Unbound variable(s) within closure(s) from the \ - current compilation_unit: %a" - Var_within_closure.Set.print vars_within_closures - | Static_exception_not_caught static_exn -> - Format.eprintf ">> Uncaught static exception: %a" - Static_exception.print static_exn - | Static_exception_caught_in_multiple_places static_exn -> - Format.eprintf ">> Static exception caught in multiple places: %a" - Static_exception.print static_exn - | Access_to_global_module_identifier prim -> - (* CR-someday mshinwell: backend-specific checks should move to another - module, in the asmcomp/ directory. *) - Format.eprintf ">> Forbidden access to a global module identifier (not \ - allowed in Flambda that will be exported to a .cmx file): %a" - Printlambda.primitive prim - | Pidentity_should_not_occur -> - Format.eprintf ">> The Pidentity primitive should never occur in an \ - Flambda expression (see closure_conversion.ml)" - | Pdirapply_should_be_expanded -> - Format.eprintf ">> The Pdirapply primitive should never occur in an \ - Flambda expression (see simplif.ml); use Apply instead" - | Prevapply_should_be_expanded -> - Format.eprintf ">> The Prevapply primitive should never occur in an \ - Flambda expression (see simplif.ml); use Apply instead" - | Move_to_a_closure_not_in_the_free_variables (start_from, move_to) -> - Format.eprintf ">> A Move_within_set_of_closures from the closure %a \ - to closures that are not parts of its free variables: %a" - Variable.print start_from - Variable.Set.print move_to - | exn -> raise exn - end; - Format.eprintf "\n@?"; - raise Flambda_invariants_failed - end diff --git a/middle_end/flambda_invariants.mli b/middle_end/flambda_invariants.mli deleted file mode 100644 index 6a24ef30..00000000 --- a/middle_end/flambda_invariants.mli +++ /dev/null @@ -1,29 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -type flambda_kind = - | Normal - | Lifted - -(** Checking of invariants on Flambda expressions. Raises an exception if - a check fails. *) -val check_exn - : ?kind:flambda_kind - -> ?cmxfile:bool - -> Flambda.program - -> unit diff --git a/middle_end/flambda_iterators.ml b/middle_end/flambda_iterators.ml deleted file mode 100644 index a69575da..00000000 --- a/middle_end/flambda_iterators.ml +++ /dev/null @@ -1,808 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let apply_on_subexpressions f f_named (flam : Flambda.t) = - match flam with - | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable - | Static_raise _ -> () - | Let { defining_expr; body; _ } -> - f_named defining_expr; - f body - | Let_mutable { body; _ } -> - f body - | Let_rec (defs, body) -> - List.iter (fun (_,l) -> f_named l) defs; - f body - | Switch (_, sw) -> - List.iter (fun (_,l) -> f l) sw.consts; - List.iter (fun (_,l) -> f l) sw.blocks; - Misc.may f sw.failaction - | String_switch (_, sw, def) -> - List.iter (fun (_,l) -> f l) sw; - Misc.may f def - | Static_catch (_,_,f1,f2) -> - f f1; f f2; - | Try_with (f1,_,f2) -> - f f1; f f2 - | If_then_else (_,f1, f2) -> - f f1;f f2 - | While (f1,f2) -> - f f1; f f2 - | For { body; _ } -> f body - -let rec list_map_sharing f l = - match l with - | [] -> l - | h :: t -> - let new_t = list_map_sharing f t in - let new_h = f h in - if h == new_h && t == new_t then - l - else - new_h :: new_t - -let may_map_sharing f v = - match v with - | None -> v - | Some s -> - let new_s = f s in - if s == new_s then - v - else - Some new_s - -let map_snd_sharing f ((a, b) as cpl) = - let new_b = f a b in - if b == new_b then - cpl - else - (a, new_b) - -let map_subexpressions f f_named (tree:Flambda.t) : Flambda.t = - match tree with - | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable - | Static_raise _ -> tree - | Let { var; defining_expr; body; _ } -> - let new_named = f_named var defining_expr in - let new_body = f body in - if new_named == defining_expr && new_body == body then - tree - else - Flambda.create_let var new_named new_body - | Let_rec (defs, body) -> - let new_defs = - list_map_sharing (map_snd_sharing f_named) defs - in - let new_body = f body in - if new_defs == defs && new_body == body then - tree - else - Let_rec (new_defs, new_body) - | Let_mutable mutable_let -> - let new_body = f mutable_let.body in - if new_body == mutable_let.body then - tree - else - Let_mutable { mutable_let with body = new_body } - | Switch (arg, sw) -> - let aux = map_snd_sharing (fun _ v -> f v) in - let new_consts = list_map_sharing aux sw.consts in - let new_blocks = list_map_sharing aux sw.blocks in - let new_failaction = may_map_sharing f sw.failaction in - if sw.failaction == new_failaction && - new_consts == sw.consts && - new_blocks == sw.blocks then - tree - else - let sw = - { sw with - failaction = new_failaction; - consts = new_consts; - blocks = new_blocks; - } - in - Switch (arg, sw) - | String_switch (arg, sw, def) -> - let new_sw = list_map_sharing (map_snd_sharing (fun _ v -> f v)) sw in - let new_def = may_map_sharing f def in - if sw == new_sw && def == new_def then - tree - else - String_switch(arg, new_sw, new_def) - | Static_catch (i, vars, body, handler) -> - let new_body = f body in - let new_handler = f handler in - if new_body == body && new_handler == handler then - tree - else - Static_catch (i, vars, new_body, new_handler) - | Try_with(body, id, handler) -> - let new_body = f body in - let new_handler = f handler in - if body == new_body && handler == new_handler then - tree - else - Try_with(new_body, id, new_handler) - | If_then_else(arg, ifso, ifnot) -> - let new_ifso = f ifso in - let new_ifnot = f ifnot in - if new_ifso == ifso && new_ifnot == ifnot then - tree - else - If_then_else(arg, new_ifso, new_ifnot) - | While(cond, body) -> - let new_cond = f cond in - let new_body = f body in - if new_cond == cond && new_body == body then - tree - else - While(new_cond, new_body) - | For { bound_var; from_value; to_value; direction; body; } -> - let new_body = f body in - if new_body == body then - tree - else - For { bound_var; from_value; to_value; direction; body = new_body; } - -let iter_general = Flambda.iter_general - -let iter f f_named t = iter_general ~toplevel:false f f_named (Is_expr t) -let iter_expr f t = iter f (fun _ -> ()) t -let iter_on_named f f_named t = - iter_general ~toplevel:false f f_named (Is_named t) -let iter_named f_named t = iter (fun (_ : Flambda.t) -> ()) f_named t -let iter_named_on_named f_named named = - iter_general ~toplevel:false (fun (_ : Flambda.t) -> ()) f_named - (Is_named named) - -let iter_toplevel f f_named t = - iter_general ~toplevel:true f f_named (Is_expr t) -let iter_named_toplevel f f_named named = - iter_general ~toplevel:true f f_named (Is_named named) - -let iter_all_immutable_let_and_let_rec_bindings t ~f = - iter_expr (function - | Let { var; defining_expr; _ } -> f var defining_expr - | Let_rec (defs, _) -> List.iter (fun (var, named) -> f var named) defs - | _ -> ()) - t - -let iter_all_toplevel_immutable_let_and_let_rec_bindings t ~f = - iter_general ~toplevel:true - (function - | Let { var; defining_expr; _ } -> f var defining_expr - | Let_rec (defs, _) -> List.iter (fun (var, named) -> f var named) defs - | _ -> ()) - (fun _ -> ()) - (Is_expr t) - -let iter_on_sets_of_closures f t = - iter_named (function - | Set_of_closures clos -> f clos - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ - | Project_closure _ | Move_within_set_of_closures _ | Project_var _ - | Prim _ | Expr _ -> ()) - t - -let iter_exprs_at_toplevel_of_program (program : Flambda.program) ~f = - let rec loop (program : Flambda.program_body) = - match program with - | Let_symbol (_, Set_of_closures set_of_closures, program) -> - Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) -> - f function_decl.body) - set_of_closures.function_decls.funs; - loop program - | Let_rec_symbol (defs, program) -> - List.iter (function - | (_, Flambda.Set_of_closures set_of_closures) -> - Variable.Map.iter - (fun _ (function_decl : Flambda.function_declaration) -> - f function_decl.body) - set_of_closures.function_decls.funs - | _ -> ()) defs; - loop program - | Let_symbol (_, _, program) -> - loop program - | Initialize_symbol (_, _, fields, program) -> - List.iter f fields; - loop program - | Effect (expr, program) -> - f expr; - loop program - | End _ -> () - in - loop program.program_body - -let iter_named_of_program program ~f = - iter_exprs_at_toplevel_of_program program ~f:(iter_named f) - -let iter_on_set_of_closures_of_program (program : Flambda.program) ~f = - let rec loop (program : Flambda.program_body) = - match program with - | Let_symbol (_, Set_of_closures set_of_closures, program) -> - f ~constant:true set_of_closures; - Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) -> - iter_on_sets_of_closures (f ~constant:false) function_decl.body) - set_of_closures.function_decls.funs; - loop program - | Let_rec_symbol (defs, program) -> - List.iter (function - | (_, Flambda.Set_of_closures set_of_closures) -> - f ~constant:true set_of_closures; - Variable.Map.iter - (fun _ (function_decl : Flambda.function_declaration) -> - iter_on_sets_of_closures (f ~constant:false) function_decl.body) - set_of_closures.function_decls.funs - | _ -> ()) defs; - loop program - | Let_symbol (_, _, program) -> - loop program - | Initialize_symbol (_, _, fields, program) -> - List.iter (iter_on_sets_of_closures (f ~constant:false)) fields; - loop program - | Effect (expr, program) -> - iter_on_sets_of_closures (f ~constant:false) expr; - loop program - | End _ -> () - in - loop program.program_body - -let iter_constant_defining_values_on_program (program : Flambda.program) ~f = - let rec loop (program : Flambda.program_body) = - match program with - | Let_symbol (_, const, program) -> - f const; - loop program - | Let_rec_symbol (defs, program) -> - List.iter (fun (_, const) -> f const) defs; - loop program - | Initialize_symbol (_, _, _, program) -> - loop program - | Effect (_, program) -> - loop program - | End _ -> () - in - loop program.program_body - -let map_general ~toplevel f f_named tree = - let rec aux (tree : Flambda.t) = - match tree with - | Let _ -> - Flambda.map_lets tree ~for_defining_expr:aux_named ~for_last_body:aux - ~after_rebuild:f - | _ -> - let exp : Flambda.t = - match tree with - | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable - | Static_raise _ -> tree - | Let _ -> assert false - | Let_mutable mutable_let -> - let new_body = aux mutable_let.body in - if new_body == mutable_let.body then - tree - else - Let_mutable { mutable_let with body = new_body } - | Let_rec (defs, body) -> - let done_something = ref false in - let defs = - List.map (fun (id, lam) -> - id, aux_named_done_something id lam done_something) - defs - in - let body = aux_done_something body done_something in - if not !done_something then - tree - else - Let_rec (defs, body) - | Switch (arg, sw) -> - let done_something = ref false in - let sw = - { sw with - failaction = - begin match sw.failaction with - | None -> None - | Some failaction -> - Some (aux_done_something failaction done_something) - end; - consts = - List.map (fun (i, v) -> - i, aux_done_something v done_something) - sw.consts; - blocks = - List.map (fun (i, v) -> - i, aux_done_something v done_something) - sw.blocks; - } - in - if not !done_something then - tree - else - Switch (arg, sw) - | String_switch (arg, sw, def) -> - let done_something = ref false in - let sw = - List.map (fun (i, v) -> i, aux_done_something v done_something) sw - in - let def = - match def with - | None -> None - | Some def -> Some (aux_done_something def done_something) - in - if not !done_something then - tree - else - String_switch(arg, sw, def) - | Static_catch (i, vars, body, handler) -> - let new_body = aux body in - let new_handler = aux handler in - if new_body == body && new_handler == handler then - tree - else - Static_catch (i, vars, new_body, new_handler) - | Try_with(body, id, handler) -> - let new_body = aux body in - let new_handler = aux handler in - if new_body == body && new_handler == handler then - tree - else - Try_with (new_body, id, new_handler) - | If_then_else (arg, ifso, ifnot) -> - let new_ifso = aux ifso in - let new_ifnot = aux ifnot in - if new_ifso == ifso && new_ifnot == ifnot then - tree - else - If_then_else (arg, new_ifso, new_ifnot) - | While (cond, body) -> - let new_cond = aux cond in - let new_body = aux body in - if new_cond == cond && new_body == body then - tree - else - While (new_cond, new_body) - | For { bound_var; from_value; to_value; direction; body; } -> - let new_body = aux body in - if new_body == body then - tree - else - For { bound_var; from_value; to_value; direction; - body = new_body; } - in - f exp - and aux_done_something expr done_something = - let new_expr = aux expr in - if not (new_expr == expr) then begin - done_something := true - end; - new_expr - and aux_named (id : Variable.t) (named : Flambda.named) = - let named : Flambda.named = - match named with - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Project_closure _ | Move_within_set_of_closures _ | Project_var _ - | Prim _ | Read_symbol_field _ -> named - | Set_of_closures ({ function_decls; free_vars; specialised_args; - direct_call_surrogates }) -> - if toplevel then named - else begin - let done_something = ref false in - let funs = - Variable.Map.map (fun (func_decl : Flambda.function_declaration) -> - let new_body = aux func_decl.body in - if new_body == func_decl.body then begin - func_decl - end else begin - done_something := true; - Flambda.update_function_declaration func_decl - ~params:func_decl.params ~body:new_body - end) - function_decls.funs - in - if not !done_something then - named - else - let function_decls = - Flambda.update_function_declarations function_decls ~funs - in - let set_of_closures = - Flambda.create_set_of_closures ~function_decls ~free_vars - ~specialised_args ~direct_call_surrogates - in - Set_of_closures set_of_closures - end - | Expr expr -> - let new_expr = aux expr in - if new_expr == expr then named - else Expr new_expr - in - f_named id named - and aux_named_done_something id named done_something = - let new_named = aux_named id named in - if not (new_named == named) then begin - done_something := true - end; - new_named - in - aux tree - -let iter_apply_on_program program ~f = - iter_exprs_at_toplevel_of_program program ~f:(fun expr -> - iter (function - | Apply apply -> f apply - | _ -> ()) - (fun _ -> ()) - expr) - -let map f f_named tree = - map_general ~toplevel:false f (fun _ n -> f_named n) tree -let map_expr f tree = map f (fun named -> named) tree -let map_named f_named tree = map (fun expr -> expr) f_named tree -let map_named_with_id f_named tree = - map_general ~toplevel:false (fun expr -> expr) f_named tree -let map_toplevel f f_named tree = - map_general ~toplevel:true f (fun _ n -> f_named n) tree -let map_toplevel_expr f_expr tree = - map_toplevel f_expr (fun named -> named) tree -let map_toplevel_named f_named tree = - map_toplevel (fun tree -> tree) f_named tree - -let map_symbols tree ~f = - map_named (function - | (Symbol sym) as named -> - let new_sym = f sym in - if new_sym == sym then - named - else - Symbol new_sym - | ((Read_symbol_field (sym, field)) as named) -> - let new_sym = f sym in - if new_sym == sym then - named - else - Read_symbol_field (new_sym, field) - | (Const _ | Allocated_const _ | Set_of_closures _ | Read_mutable _ - | Project_closure _ | Move_within_set_of_closures _ | Project_var _ - | Prim _ | Expr _) as named -> named) - tree - -let map_symbols_on_set_of_closures - ({ Flambda.function_decls; free_vars; specialised_args; - direct_call_surrogates; } as - set_of_closures) - ~f = - let done_something = ref false in - let funs = - Variable.Map.map (fun (func_decl : Flambda.function_declaration) -> - let body = map_symbols func_decl.body ~f in - if not (body == func_decl.body) then begin - done_something := true; - end; - Flambda.update_function_declaration func_decl - ~params:func_decl.params ~body) - function_decls.funs - in - if not !done_something then - set_of_closures - else - let function_decls = - Flambda.update_function_declarations function_decls ~funs - in - Flambda.create_set_of_closures ~function_decls ~free_vars - ~specialised_args ~direct_call_surrogates - -let map_toplevel_sets_of_closures tree ~f = - map_toplevel_named (function - | (Set_of_closures set_of_closures) as named -> - let new_set_of_closures = f set_of_closures in - if new_set_of_closures == set_of_closures then - named - else - Set_of_closures new_set_of_closures - | (Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ - | Project_closure _ | Move_within_set_of_closures _ | Project_var _ - | Prim _ | Expr _) as named -> named) - tree - -let map_apply tree ~f = - map (function - | (Apply apply) as expr -> - let new_apply = f apply in - if new_apply == apply then - expr - else - Apply new_apply - | expr -> expr) - (fun named -> named) - tree - -let map_sets_of_closures tree ~f = - map_named (function - | (Set_of_closures set_of_closures) as named -> - let new_set_of_closures = f set_of_closures in - if new_set_of_closures == set_of_closures then - named - else - Set_of_closures new_set_of_closures - | (Symbol _ | Const _ | Allocated_const _ | Project_closure _ - | Move_within_set_of_closures _ | Project_var _ - | Prim _ | Expr _ | Read_mutable _ - | Read_symbol_field _) as named -> named) - tree - -let map_project_var_to_expr_opt tree ~f = - map_named (function - | (Project_var project_var) as named -> - begin match f project_var with - | None -> named - | Some expr -> Expr expr - end - | (Symbol _ | Const _ | Allocated_const _ - | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ - | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _) - as named -> named) - tree - -let map_project_var_to_named_opt tree ~f = - map_named (function - | (Project_var project_var) as named -> - begin match f project_var with - | None -> named - | Some named -> named - end - | (Symbol _ | Const _ | Allocated_const _ - | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ - | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _) - as named -> named) - tree - -let map_function_bodies (set_of_closures : Flambda.set_of_closures) ~f = - let done_something = ref false in - let funs = - Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> - let new_body = f function_decl.body in - if new_body == function_decl.body then - function_decl - else begin - done_something := true; - Flambda.update_function_declaration function_decl - ~body:new_body ~params:function_decl.params - end) - set_of_closures.function_decls.funs - in - if not !done_something then - set_of_closures - else - let function_decls = - Flambda.update_function_declarations set_of_closures.function_decls ~funs - in - Flambda.create_set_of_closures - ~function_decls - ~free_vars:set_of_closures.free_vars - ~specialised_args:set_of_closures.specialised_args - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - -let map_sets_of_closures_of_program (program : Flambda.program) - ~(f : Flambda.set_of_closures -> Flambda.set_of_closures) = - let rec loop (program : Flambda.program_body) : Flambda.program_body = - let map_constant_set_of_closures (set_of_closures:Flambda.set_of_closures) = - let done_something = ref false in - let function_decls = - let funs = - Variable.Map.map (fun - (function_decl : Flambda.function_declaration) -> - let body = map_sets_of_closures ~f function_decl.body in - if body == function_decl.body then - function_decl - else begin - done_something := true; - Flambda.update_function_declaration function_decl - ~body ~params:function_decl.params - end) - set_of_closures.function_decls.funs - in - if not !done_something then - set_of_closures.function_decls - else - Flambda.update_function_declarations set_of_closures.function_decls - ~funs - in - let new_set_of_closures = f set_of_closures in - if new_set_of_closures == set_of_closures then - set_of_closures - else - Flambda.create_set_of_closures ~function_decls - ~free_vars:set_of_closures.free_vars - ~specialised_args:set_of_closures.specialised_args - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - match program with - | Let_symbol (symbol, Set_of_closures set_of_closures, program') -> - let new_set_of_closures = map_constant_set_of_closures set_of_closures in - let new_program' = loop program' in - if new_set_of_closures == set_of_closures - && new_program' == program' then - program - else - Let_symbol (symbol, Set_of_closures new_set_of_closures, new_program') - | Let_symbol (symbol, const, program') -> - let new_program' = loop program' in - if new_program' == program' then - program - else - Let_symbol (symbol, const, new_program') - | Let_rec_symbol (defs, program') -> - let done_something = ref false in - let defs = - List.map (function - | (var, Flambda.Set_of_closures set_of_closures) -> - let new_set_of_closures = - map_constant_set_of_closures set_of_closures - in - if not (new_set_of_closures == set_of_closures) then begin - done_something := true - end; - var, Flambda.Set_of_closures new_set_of_closures - | def -> def) - defs - in - let new_program' = loop program' in - if new_program' == program' && not !done_something then - program - else - Let_rec_symbol (defs, loop program') - | Initialize_symbol (symbol, tag, fields, program') -> - let done_something = ref false in - let fields = - List.map (fun field -> - let new_field = map_sets_of_closures field ~f in - if not (new_field == field) then begin - done_something := true - end; - new_field) - fields - in - let new_program' = loop program' in - if new_program' == program' && not !done_something then - program - else - Initialize_symbol (symbol, tag, fields, new_program') - | Effect (expr, program') -> - let new_expr = map_sets_of_closures expr ~f in - let new_program' = loop program' in - if new_expr == expr && new_program' == program' then - program - else - Effect (new_expr, new_program') - | End _ -> program - in - { program with - program_body = loop program.program_body; - } - -let map_exprs_at_toplevel_of_program (program : Flambda.program) - ~(f : Flambda.t -> Flambda.t) = - let rec loop (program : Flambda.program_body) : Flambda.program_body = - let map_constant_set_of_closures (set_of_closures:Flambda.set_of_closures) = - let done_something = ref false in - let funs = - Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> - let body = f function_decl.body in - if body == function_decl.body then - function_decl - else begin - done_something := true; - Flambda.update_function_declaration function_decl - ~body ~params:function_decl.params - end) - set_of_closures.function_decls.funs - in - if not !done_something then - set_of_closures - else - let function_decls = - Flambda.update_function_declarations set_of_closures.function_decls - ~funs - in - Flambda.create_set_of_closures ~function_decls - ~free_vars:set_of_closures.free_vars - ~specialised_args:set_of_closures.specialised_args - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - (* CR-soon mshinwell: code very similar to the above function *) - match program with - | Let_symbol (symbol, Set_of_closures set_of_closures, program') -> - let new_set_of_closures = map_constant_set_of_closures set_of_closures in - let new_program' = loop program' in - if new_set_of_closures == set_of_closures - && new_program' == program' then - program - else - Let_symbol (symbol, Set_of_closures new_set_of_closures, new_program') - | Let_symbol (symbol, const, program') -> - let new_program' = loop program' in - if new_program' == program' then - program - else - Let_symbol (symbol, const, new_program') - | Let_rec_symbol (defs, program') -> - let done_something = ref false in - let defs = - List.map (function - | (var, Flambda.Set_of_closures set_of_closures) -> - let new_set_of_closures = - map_constant_set_of_closures set_of_closures - in - if not (new_set_of_closures == set_of_closures) then begin - done_something := true - end; - var, Flambda.Set_of_closures new_set_of_closures - | def -> def) - defs - in - let new_program' = loop program' in - if new_program' == program' && not !done_something then - program - else - Let_rec_symbol (defs, new_program') - | Initialize_symbol (symbol, tag, fields, program') -> - let done_something = ref false in - let fields = - List.map (fun field -> - let new_field = f field in - if not (new_field == field) then begin - done_something := true - end; - new_field) - fields - in - let new_program' = loop program' in - if new_program' == program' && not !done_something then - program - else - Initialize_symbol (symbol, tag, fields, new_program') - | Effect (expr, program') -> - let new_expr = f expr in - let new_program' = loop program' in - if new_expr == expr && new_program' == program' then - program - else - Effect (new_expr, new_program') - | End _ -> program - in - { program with - program_body = loop program.program_body; - } - -let map_named_of_program (program : Flambda.program) - ~(f : Variable.t -> Flambda.named -> Flambda.named) : Flambda.program = - map_exprs_at_toplevel_of_program program - ~f:(fun expr -> map_named_with_id f expr) - -let map_all_immutable_let_and_let_rec_bindings (expr : Flambda.t) - ~(f : Variable.t -> Flambda.named -> Flambda.named) : Flambda.t = - map_named_with_id f expr - -let fold_function_decls_ignoring_stubs - (set_of_closures : Flambda.set_of_closures) ~init ~f = - Variable.Map.fold (fun fun_var function_decl acc -> - f ~fun_var ~function_decl acc) - set_of_closures.function_decls.funs - init diff --git a/middle_end/flambda_iterators.mli b/middle_end/flambda_iterators.mli deleted file mode 100644 index 02fe6850..00000000 --- a/middle_end/flambda_iterators.mli +++ /dev/null @@ -1,227 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(* CR-soon mshinwell: we need to document whether these iterators follow any - particular order. *) - -(** Apply the given functions to the immediate subexpressions of the given - Flambda expression. For avoidance of doubt, if a subexpression is - [Expr], it is passed to the function taking [Flambda.named], rather - than being followed and passed to the function taking [Flambda.t]. *) -val apply_on_subexpressions - : (Flambda.t -> unit) - -> (Flambda.named -> unit) - -> Flambda.t - -> unit - -val map_subexpressions - : (Flambda.t -> Flambda.t) - -> (Variable.t -> Flambda.named -> Flambda.named) - -> Flambda.t - -> Flambda.t - -(* CR-soon lwhite: add comment to clarify that these recurse unlike the - ones above *) -val iter - : (Flambda.t -> unit) - -> (Flambda.named -> unit) - -> Flambda.t - -> unit - -val iter_expr - : (Flambda.t -> unit) - -> Flambda.t - -> unit - -val iter_on_named - : (Flambda.t -> unit) - -> (Flambda.named -> unit) - -> Flambda.named - -> unit - -(* CR-someday mshinwell: we might need to add the corresponding variable to - the parameters of the user function for [iter_named] *) -val iter_named - : (Flambda.named -> unit) - -> Flambda.t - -> unit - -(* CR-someday lwhite: These names are pretty indecipherable, perhaps - create submodules for the normal and "on_named" variants of each - function. *) - -val iter_named_on_named - : (Flambda.named -> unit) - -> Flambda.named - -> unit - -(** [iter_toplevel f t] applies [f] on every toplevel subexpression of [t]. - In particular, it never applies [f] to the body of a function (which - will always be contained within an [Set_of_closures] expression). *) -val iter_toplevel - : (Flambda.t -> unit) - -> (Flambda.named -> unit) - -> Flambda.t - -> unit - -val iter_named_toplevel - : (Flambda.t -> unit) - -> (Flambda.named -> unit) - -> Flambda.named - -> unit - -val iter_on_sets_of_closures - : (Flambda.set_of_closures -> unit) - -> Flambda.t - -> unit - -val iter_on_set_of_closures_of_program - : Flambda.program - -> f:(constant:bool -> Flambda.set_of_closures -> unit) - -> unit - -val iter_all_immutable_let_and_let_rec_bindings - : Flambda.t - -> f:(Variable.t -> Flambda.named -> unit) - -> unit - -val iter_all_toplevel_immutable_let_and_let_rec_bindings - : Flambda.t - -> f:(Variable.t -> Flambda.named -> unit) - -> unit - -val iter_exprs_at_toplevel_of_program - : Flambda.program - -> f:(Flambda.t -> unit) - -> unit - -val iter_named_of_program - : Flambda.program - -> f:(Flambda.named -> unit) - -> unit - -val iter_constant_defining_values_on_program - : Flambda.program - -> f:(Flambda.constant_defining_value -> unit) - -> unit - -val iter_apply_on_program - : Flambda.program - -> f:(Flambda.apply -> unit) - -> unit - -val map - : (Flambda.t -> Flambda.t) - -> (Flambda.named -> Flambda.named) - -> Flambda.t - -> Flambda.t - -val map_expr - : (Flambda.t -> Flambda.t) - -> Flambda.t - -> Flambda.t - -val map_named - : (Flambda.named -> Flambda.named) - -> Flambda.t - -> Flambda.t - -val map_toplevel - : (Flambda.t -> Flambda.t) - -> (Flambda.named -> Flambda.named) - -> Flambda.t - -> Flambda.t - -val map_toplevel_expr - : (Flambda.t -> Flambda.t) - -> Flambda.t - -> Flambda.t - -val map_toplevel_named - : (Flambda.named -> Flambda.named) - -> Flambda.t - -> Flambda.t - -val map_symbols - : Flambda.t - -> f:(Symbol.t -> Symbol.t) - -> Flambda.t - -val map_symbols_on_set_of_closures - : Flambda.set_of_closures - -> f:(Symbol.t -> Symbol.t) - -> Flambda.set_of_closures - -val map_toplevel_sets_of_closures - : Flambda.t - -> f:(Flambda.set_of_closures -> Flambda.set_of_closures) - -> Flambda.t - -val map_apply - : Flambda.t - -> f:(Flambda.apply -> Flambda.apply) - -> Flambda.t - -val map_function_bodies - : Flambda.set_of_closures - -> f:(Flambda.t -> Flambda.t) - -> Flambda.set_of_closures - -val map_sets_of_closures - : Flambda.t - -> f:(Flambda.set_of_closures -> Flambda.set_of_closures) - -> Flambda.t - -val map_sets_of_closures_of_program - : Flambda.program - -> f:(Flambda.set_of_closures -> Flambda.set_of_closures) - -> Flambda.program - -val map_project_var_to_expr_opt - : Flambda.t - -> f:(Flambda.project_var -> Flambda.t option) - -> Flambda.t - -val map_project_var_to_named_opt - : Flambda.t - -> f:(Flambda.project_var -> Flambda.named option) - -> Flambda.t - -val map_exprs_at_toplevel_of_program - : Flambda.program - -> f:(Flambda.t -> Flambda.t) - -> Flambda.program - -val map_named_of_program - : Flambda.program - -> f:(Variable.t -> Flambda.named -> Flambda.named) - -> Flambda.program - -val map_all_immutable_let_and_let_rec_bindings - : Flambda.t - -> f:(Variable.t -> Flambda.named -> Flambda.named) - -> Flambda.t - -val fold_function_decls_ignoring_stubs - : Flambda.set_of_closures - -> init:'a - -> f:(fun_var:Variable.t - -> function_decl:Flambda.function_declaration - -> 'a - -> 'a) - -> 'a diff --git a/middle_end/flambda_utils.ml b/middle_end/flambda_utils.ml deleted file mode 100644 index 1bb3a2a8..00000000 --- a/middle_end/flambda_utils.ml +++ /dev/null @@ -1,929 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let name_expr ~name (named : Flambda.named) : Flambda.t = - let var = - Variable.create - ~current_compilation_unit:(Compilation_unit.get_current_exn ()) - name - in - Flambda.create_let var named (Var var) - -let name_expr_from_var ~var (named : Flambda.named) : Flambda.t = - let var = - Variable.rename - ~current_compilation_unit:(Compilation_unit.get_current_exn ()) - var - in - Flambda.create_let var named (Var var) - -let find_declaration cf ({ funs } : Flambda.function_declarations) = - Variable.Map.find (Closure_id.unwrap cf) funs - -let find_declaration_variable cf ({ funs } : Flambda.function_declarations) = - let var = Closure_id.unwrap cf in - if not (Variable.Map.mem var funs) - then raise Not_found - else var - -let find_free_variable cv ({ free_vars } : Flambda.set_of_closures) = - let var : Flambda.specialised_to = - Variable.Map.find (Var_within_closure.unwrap cv) free_vars - in - var.var - -let function_arity (f : Flambda.function_declaration) = List.length f.params - -let variables_bound_by_the_closure cf - (decls : Flambda.function_declarations) = - let func = find_declaration cf decls in - let params = Parameter.Set.vars func.params in - let functions = Variable.Map.keys decls.funs in - Variable.Set.diff - (Variable.Set.diff func.free_variables params) - functions - -let description_of_toplevel_node (expr : Flambda.t) = - match expr with - | Var id -> Format.asprintf "var %a" Variable.print id - | Apply _ -> "apply" - | Assign _ -> "assign" - | Send _ -> "send" - | Proved_unreachable -> "unreachable" - | Let { var; _ } -> Format.asprintf "let %a" Variable.print var - | Let_mutable _ -> "let_mutable" - | Let_rec _ -> "letrec" - | If_then_else _ -> "if" - | Switch _ -> "switch" - | String_switch _ -> "stringswitch" - | Static_raise _ -> "staticraise" - | Static_catch _ -> "catch" - | Try_with _ -> "trywith" - | While _ -> "while" - | For _ -> "for" - -let equal_direction_flag - (x : Asttypes.direction_flag) - (y : Asttypes.direction_flag) = - match x, y with - | Upto, Upto -> true - | Downto, Downto -> true - | (Upto | Downto), _ -> false - -let rec same (l1 : Flambda.t) (l2 : Flambda.t) = - l1 == l2 || (* it is ok for the string case: if they are physically the same, - it is the same original branch *) - match (l1, l2) with - | Var v1 , Var v2 -> Variable.equal v1 v2 - | Var _, _ | _, Var _ -> false - | Apply a1 , Apply a2 -> - Flambda.equal_call_kind a1.kind a2.kind - && Variable.equal a1.func a2.func - && Misc.Stdlib.List.equal Variable.equal a1.args a2.args - | Apply _, _ | _, Apply _ -> false - | Let { var = var1; defining_expr = defining_expr1; body = body1; _ }, - Let { var = var2; defining_expr = defining_expr2; body = body2; _ } -> - Variable.equal var1 var2 && same_named defining_expr1 defining_expr2 - && same body1 body2 - | Let _, _ | _, Let _ -> false - | Let_mutable {var = mv1; initial_value = v1; contents_kind = ck1; body = b1}, - Let_mutable {var = mv2; initial_value = v2; contents_kind = ck2; body = b2} - -> - Mutable_variable.equal mv1 mv2 - && Variable.equal v1 v2 - && Lambda.equal_value_kind ck1 ck2 - && same b1 b2 - | Let_mutable _, _ | _, Let_mutable _ -> false - | Let_rec (bl1, a1), Let_rec (bl2, a2) -> - Misc.Stdlib.List.equal samebinding bl1 bl2 && same a1 a2 - | Let_rec _, _ | _, Let_rec _ -> false - | Switch (a1, s1), Switch (a2, s2) -> - Variable.equal a1 a2 && sameswitch s1 s2 - | Switch _, _ | _, Switch _ -> false - | String_switch (a1, s1, d1), String_switch (a2, s2, d2) -> - Variable.equal a1 a2 - && Misc.Stdlib.List.equal - (fun (s1, e1) (s2, e2) -> String.equal s1 s2 && same e1 e2) s1 s2 - && Misc.Stdlib.Option.equal same d1 d2 - | String_switch _, _ | _, String_switch _ -> false - | Static_raise (e1, a1), Static_raise (e2, a2) -> - Static_exception.equal e1 e2 && Misc.Stdlib.List.equal Variable.equal a1 a2 - | Static_raise _, _ | _, Static_raise _ -> false - | Static_catch (s1, v1, a1, b1), Static_catch (s2, v2, a2, b2) -> - Static_exception.equal s1 s2 - && Misc.Stdlib.List.equal Variable.equal v1 v2 - && same a1 a2 - && same b1 b2 - | Static_catch _, _ | _, Static_catch _ -> false - | Try_with (a1, v1, b1), Try_with (a2, v2, b2) -> - same a1 a2 && Variable.equal v1 v2 && same b1 b2 - | Try_with _, _ | _, Try_with _ -> false - | If_then_else (a1, b1, c1), If_then_else (a2, b2, c2) -> - Variable.equal a1 a2 && same b1 b2 && same c1 c2 - | If_then_else _, _ | _, If_then_else _ -> false - | While (a1, b1), While (a2, b2) -> - same a1 a2 && same b1 b2 - | While _, _ | _, While _ -> false - | For { bound_var = bound_var1; from_value = from_value1; - to_value = to_value1; direction = direction1; body = body1; }, - For { bound_var = bound_var2; from_value = from_value2; - to_value = to_value2; direction = direction2; body = body2; } -> - Variable.equal bound_var1 bound_var2 - && Variable.equal from_value1 from_value2 - && Variable.equal to_value1 to_value2 - && equal_direction_flag direction1 direction2 - && same body1 body2 - | For _, _ | _, For _ -> false - | Assign { being_assigned = being_assigned1; new_value = new_value1; }, - Assign { being_assigned = being_assigned2; new_value = new_value2; } -> - Mutable_variable.equal being_assigned1 being_assigned2 - && Variable.equal new_value1 new_value2 - | Assign _, _ | _, Assign _ -> false - | Send { kind = kind1; meth = meth1; obj = obj1; args = args1; dbg = _; }, - Send { kind = kind2; meth = meth2; obj = obj2; args = args2; dbg = _; } -> - Lambda.equal_meth_kind kind1 kind2 - && Variable.equal meth1 meth2 - && Variable.equal obj1 obj2 - && Misc.Stdlib.List.equal Variable.equal args1 args2 - | Send _, _ | _, Send _ -> false - | Proved_unreachable, Proved_unreachable -> true - -and same_named (named1 : Flambda.named) (named2 : Flambda.named) = - match named1, named2 with - | Symbol s1 , Symbol s2 -> Symbol.equal s1 s2 - | Symbol _, _ | _, Symbol _ -> false - | Const c1, Const c2 -> Flambda.compare_const c1 c2 = 0 - | Const _, _ | _, Const _ -> false - | Allocated_const c1, Allocated_const c2 -> - Allocated_const.compare c1 c2 = 0 - | Allocated_const _, _ | _, Allocated_const _ -> false - | Read_mutable mv1, Read_mutable mv2 -> Mutable_variable.equal mv1 mv2 - | Read_mutable _, _ | _, Read_mutable _ -> false - | Read_symbol_field (s1, i1), Read_symbol_field (s2, i2) -> - Symbol.equal s1 s2 && i1 = i2 - | Read_symbol_field _, _ | _, Read_symbol_field _ -> false - | Set_of_closures s1, Set_of_closures s2 -> same_set_of_closures s1 s2 - | Set_of_closures _, _ | _, Set_of_closures _ -> false - | Project_closure f1, Project_closure f2 -> same_project_closure f1 f2 - | Project_closure _, _ | _, Project_closure _ -> false - | Project_var v1, Project_var v2 -> - Variable.equal v1.closure v2.closure - && Closure_id.equal v1.closure_id v2.closure_id - && Var_within_closure.equal v1.var v2.var - | Project_var _, _ | _, Project_var _ -> false - | Move_within_set_of_closures m1, Move_within_set_of_closures m2 -> - same_move_within_set_of_closures m1 m2 - | Move_within_set_of_closures _, _ | _, Move_within_set_of_closures _ -> - false - | Prim (p1, al1, _), Prim (p2, al2, _) -> - Lambda.equal_primitive p1 p2 - && Misc.Stdlib.List.equal Variable.equal al1 al2 - | Prim _, _ | _, Prim _ -> false - | Expr e1, Expr e2 -> same e1 e2 - -and sameclosure (c1 : Flambda.function_declaration) - (c2 : Flambda.function_declaration) = - Misc.Stdlib.List.equal Parameter.equal c1.params c2.params - && same c1.body c2.body - -and same_set_of_closures (c1 : Flambda.set_of_closures) - (c2 : Flambda.set_of_closures) = - Variable.Map.equal sameclosure c1.function_decls.funs c2.function_decls.funs - && Variable.Map.equal Flambda.equal_specialised_to - c1.free_vars c2.free_vars - && Variable.Map.equal Flambda.equal_specialised_to c1.specialised_args - c2.specialised_args - -and same_project_closure (s1 : Flambda.project_closure) - (s2 : Flambda.project_closure) = - Variable.equal s1.set_of_closures s2.set_of_closures - && Closure_id.equal s1.closure_id s2.closure_id - -and same_move_within_set_of_closures (m1 : Flambda.move_within_set_of_closures) - (m2 : Flambda.move_within_set_of_closures) = - Variable.equal m1.closure m2.closure - && Closure_id.equal m1.start_from m2.start_from - && Closure_id.equal m1.move_to m2.move_to - -and samebinding (v1, n1) (v2, n2) = - Variable.equal v1 v2 && same_named n1 n2 - -and sameswitch (fs1 : Flambda.switch) (fs2 : Flambda.switch) = - let samecase (n1, a1) (n2, a2) = n1 = n2 && same a1 a2 in - Numbers.Int.Set.equal fs1.numconsts fs2.numconsts - && Numbers.Int.Set.equal fs1.numblocks fs2.numblocks - && Misc.Stdlib.List.equal samecase fs1.consts fs2.consts - && Misc.Stdlib.List.equal samecase fs1.blocks fs2.blocks - && Misc.Stdlib.Option.equal same fs1.failaction fs2.failaction - -let can_be_merged = same - -(* CR-soon mshinwell: this should use the explicit ignore functions *) -let toplevel_substitution sb tree = - let sb' = sb in - let sb v = try Variable.Map.find v sb with Not_found -> v in - let aux (flam : Flambda.t) : Flambda.t = - match flam with - | Var var -> - let var = sb var in - Var var - | Let_mutable mutable_let -> - let initial_value = sb mutable_let.initial_value in - Let_mutable { mutable_let with initial_value } - | Assign { being_assigned; new_value; } -> - let new_value = sb new_value in - Assign { being_assigned; new_value; } - | Apply { func; args; kind; dbg; inline; specialise; } -> - let func = sb func in - let args = List.map sb args in - Apply { func; args; kind; dbg; inline; specialise; } - | If_then_else (cond, e1, e2) -> - let cond = sb cond in - If_then_else (cond, e1, e2) - | Switch (cond, sw) -> - let cond = sb cond in - Switch (cond, sw) - | String_switch (cond, branches, def) -> - let cond = sb cond in - String_switch (cond, branches, def) - | Send { kind; meth; obj; args; dbg } -> - let meth = sb meth in - let obj = sb obj in - let args = List.map sb args in - Send { kind; meth; obj; args; dbg } - | For { bound_var; from_value; to_value; direction; body } -> - let from_value = sb from_value in - let to_value = sb to_value in - For { bound_var; from_value; to_value; direction; body } - | Static_raise (static_exn, args) -> - let args = List.map sb args in - Static_raise (static_exn, args) - | Static_catch _ | Try_with _ | While _ - | Let _ | Let_rec _ | Proved_unreachable -> flam - in - let aux_named (named : Flambda.named) : Flambda.named = - match named with - | Symbol _ | Const _ | Expr _ -> named - | Allocated_const _ | Read_mutable _ -> named - | Read_symbol_field _ -> named - | Set_of_closures set_of_closures -> - let set_of_closures = - Flambda.create_set_of_closures - ~function_decls:set_of_closures.function_decls - ~free_vars: - (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - { spec_to with var = sb spec_to.var; }) - set_of_closures.free_vars) - ~specialised_args: - (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - { spec_to with var = sb spec_to.var; }) - set_of_closures.specialised_args) - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - Set_of_closures set_of_closures - | Project_closure project_closure -> - Project_closure { - project_closure with - set_of_closures = sb project_closure.set_of_closures; - } - | Move_within_set_of_closures move_within_set_of_closures -> - Move_within_set_of_closures { - move_within_set_of_closures with - closure = sb move_within_set_of_closures.closure; - } - | Project_var project_var -> - Project_var { - project_var with - closure = sb project_var.closure; - } - | Prim (prim, args, dbg) -> - Prim (prim, List.map sb args, dbg) - in - if Variable.Map.is_empty sb' then tree - else Flambda_iterators.map_toplevel aux aux_named tree - -(* CR-someday mshinwell: Fix [Flambda_iterators] so this can be implemented - properly. *) -let toplevel_substitution_named sb named = - let name = Internal_variable_names.toplevel_substitution_named in - let expr = name_expr named ~name in - match toplevel_substitution sb expr with - | Let let_expr -> let_expr.defining_expr - | _ -> assert false - -let make_closure_declaration - ~is_classic_mode ~id ~body ~params ~stub : Flambda.t = - let free_variables = Flambda.free_variables body in - let param_set = Parameter.Set.vars params in - if not (Variable.Set.subset param_set free_variables) then begin - Misc.fatal_error "Flambda_utils.make_closure_declaration" - end; - let sb = - Variable.Set.fold - (fun id sb -> Variable.Map.add id (Variable.rename id) sb) - free_variables Variable.Map.empty - in - (* CR-soon mshinwell: try to eliminate this [toplevel_substitution]. This - function is only called from [Inline_and_simplify], so we should be able - to do something similar to what happens in [Inlining_transforms] now. *) - let body = toplevel_substitution sb body in - let subst id = Variable.Map.find id sb in - let subst_param param = Parameter.map_var subst param in - let function_declaration = - Flambda.create_function_declaration ~params:(List.map subst_param params) - ~body ~stub ~dbg:Debuginfo.none ~inline:Default_inline - ~specialise:Default_specialise ~is_a_functor:false - ~closure_origin:(Closure_origin.create (Closure_id.wrap id)) - in - assert (Variable.Set.equal (Variable.Set.map subst free_variables) - function_declaration.free_variables); - let free_vars = - Variable.Map.fold (fun id id' fv' -> - let spec_to : Flambda.specialised_to = - { var = id; - projection = None; - } - in - Variable.Map.add id' spec_to fv') - (Variable.Map.filter - (fun id _ -> not (Variable.Set.mem id param_set)) - sb) - Variable.Map.empty - in - let compilation_unit = Compilation_unit.get_current_exn () in - let set_of_closures_var = - Variable.create Internal_variable_names.set_of_closures - ~current_compilation_unit:compilation_unit - in - let set_of_closures = - let function_decls = - Flambda.create_function_declarations - ~is_classic_mode - ~funs:(Variable.Map.singleton id function_declaration) - in - Flambda.create_set_of_closures ~function_decls ~free_vars - ~specialised_args:Variable.Map.empty - ~direct_call_surrogates:Variable.Map.empty - in - let project_closure : Flambda.named = - Project_closure { - set_of_closures = set_of_closures_var; - closure_id = Closure_id.wrap id; - } - in - let project_closure_var = - Variable.create Internal_variable_names.project_closure - ~current_compilation_unit:compilation_unit - in - Flambda.create_let set_of_closures_var (Set_of_closures set_of_closures) - (Flambda.create_let project_closure_var project_closure - (Var (project_closure_var))) - -let bind ~bindings ~body = - List.fold_left (fun expr (var, var_def) -> - Flambda.create_let var var_def expr) - body bindings - -let all_lifted_constants (program : Flambda.program) = - let rec loop (program : Flambda.program_body) = - match program with - | Let_symbol (symbol, decl, program) -> (symbol, decl) :: (loop program) - | Let_rec_symbol (decls, program) -> - List.fold_left (fun l (symbol, decl) -> (symbol, decl) :: l) - (loop program) - decls - | Initialize_symbol (_, _, _, program) - | Effect (_, program) -> loop program - | End _ -> [] - in - loop program.program_body - -let all_lifted_constants_as_map program = - Symbol.Map.of_list (all_lifted_constants program) - -let initialize_symbols (program : Flambda.program) = - let rec loop (program : Flambda.program_body) = - match program with - | Initialize_symbol (symbol, tag, fields, program) -> - (symbol, tag, fields) :: (loop program) - | Effect (_, program) - | Let_symbol (_, _, program) - | Let_rec_symbol (_, program) -> loop program - | End _ -> [] - in - loop program.program_body - -let imported_symbols (program : Flambda.program) = - program.imported_symbols - -let needed_import_symbols (program : Flambda.program) = - let dependencies = Flambda.free_symbols_program program in - let defined_symbol = - Symbol.Set.union - (Symbol.Set.of_list - (List.map fst (all_lifted_constants program))) - (Symbol.Set.of_list - (List.map (fun (s, _, _) -> s) (initialize_symbols program))) - in - Symbol.Set.diff dependencies defined_symbol - -let introduce_needed_import_symbols program : Flambda.program = - { program with - imported_symbols = needed_import_symbols program; - } - -let root_symbol (program : Flambda.program) = - let rec loop (program : Flambda.program_body) = - match program with - | Effect (_, program) - | Let_symbol (_, _, program) - | Let_rec_symbol (_, program) - | Initialize_symbol (_, _, _, program) -> loop program - | End root -> - root - in - loop program.program_body - -let might_raise_static_exn flam stexn = - try - Flambda_iterators.iter_on_named - (function - | Flambda.Static_raise (ex, _) when Static_exception.equal ex stexn -> - raise Exit - | _ -> ()) - (fun _ -> ()) - flam; - false - with Exit -> true - -let make_closure_map program = - let map = ref Closure_id.Map.empty in - let add_set_of_closures ~constant:_ : Flambda.set_of_closures -> unit = fun - { function_decls } -> - Variable.Map.iter (fun var _ -> - let closure_id = Closure_id.wrap var in - let set_of_closures_id = function_decls.set_of_closures_id in - map := Closure_id.Map.add closure_id set_of_closures_id !map) - function_decls.funs - in - Flambda_iterators.iter_on_set_of_closures_of_program - program - ~f:add_set_of_closures; - !map - -let all_lifted_constant_closures program = - List.fold_left (fun unchanged flambda -> - match flambda with - | (_, Flambda.Set_of_closures { function_decls = { funs } }) -> - Variable.Map.fold - (fun key (_ : Flambda.function_declaration) acc -> - Closure_id.Set.add (Closure_id.wrap key) acc) - funs - unchanged - | _ -> unchanged) - Closure_id.Set.empty - (all_lifted_constants program) - -let all_lifted_constant_sets_of_closures program = - let set = ref Set_of_closures_id.Set.empty in - List.iter (function - | (_, Flambda.Set_of_closures { - function_decls = { set_of_closures_id } }) -> - set := Set_of_closures_id.Set.add set_of_closures_id !set - | _ -> ()) - (all_lifted_constants program); - !set - -let all_sets_of_closures program = - let list = ref [] in - Flambda_iterators.iter_on_set_of_closures_of_program program - ~f:(fun ~constant:_ set_of_closures -> - list := set_of_closures :: !list); - !list - -let all_sets_of_closures_map program = - let r = ref Set_of_closures_id.Map.empty in - Flambda_iterators.iter_on_set_of_closures_of_program program - ~f:(fun ~constant:_ set_of_closures -> - r := Set_of_closures_id.Map.add - set_of_closures.function_decls.set_of_closures_id - set_of_closures !r); - !r - -let substitute_read_symbol_field_for_variables - (substitution : (Symbol.t * int list) Variable.Map.t) - (expr : Flambda.t) = - let bind var fresh_var (expr:Flambda.t) : Flambda.t = - let symbol, path = Variable.Map.find var substitution in - let rec make_named (path:int list) : Flambda.named = - match path with - | [] -> Symbol symbol - | [i] -> Read_symbol_field (symbol, i) - | h :: t -> - let block_name = Internal_variable_names.symbol_field_block in - let block = Variable.create block_name in - let field_name = Internal_variable_names.get_symbol_field in - let field = Variable.create field_name in - Expr ( - Flambda.create_let block (make_named t) - (Flambda.create_let field - (Prim (Pfield h, [block], Debuginfo.none)) - (Var field))) - in - Flambda.create_let fresh_var (make_named path) expr - in - let substitute_named bindings (named:Flambda.named) : Flambda.named = - let sb to_substitute = - try Variable.Map.find to_substitute bindings with - | Not_found -> - to_substitute - in - match named with - | Symbol _ | Const _ | Expr _ -> named - | Allocated_const _ | Read_mutable _ -> named - | Read_symbol_field _ -> named - | Set_of_closures set_of_closures -> - let set_of_closures = - Flambda.create_set_of_closures - ~function_decls:set_of_closures.function_decls - ~free_vars: - (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - { spec_to with var = sb spec_to.var; }) - set_of_closures.free_vars) - ~specialised_args: - (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - { spec_to with var = sb spec_to.var; }) - set_of_closures.specialised_args) - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - Set_of_closures set_of_closures - | Project_closure project_closure -> - Project_closure { - project_closure with - set_of_closures = sb project_closure.set_of_closures; - } - | Move_within_set_of_closures move_within_set_of_closures -> - Move_within_set_of_closures { - move_within_set_of_closures with - closure = sb move_within_set_of_closures.closure; - } - | Project_var project_var -> - Project_var { - project_var with - closure = sb project_var.closure; - } - | Prim (prim, args, dbg) -> - Prim (prim, List.map sb args, dbg) - in - let make_var_subst var = - if Variable.Map.mem var substitution then - let fresh = Variable.rename var in - fresh, (fun expr -> bind var fresh expr) - else - var, (fun x -> x) - in - let f (expr:Flambda.t) : Flambda.t = - match expr with - | Var v when Variable.Map.mem v substitution -> - let fresh = Variable.rename v in - bind v fresh (Var fresh) - | Var _ -> expr - | Let ({ var = v; defining_expr = named; _ } as let_expr) -> - let to_substitute = - Variable.Set.filter - (fun v -> Variable.Map.mem v substitution) - (Flambda.free_variables_named named) - in - if Variable.Set.is_empty to_substitute then - expr - else - let bindings = - Variable.Map.of_set (fun var -> Variable.rename var) to_substitute - in - let named = - substitute_named bindings named - in - let expr = - let module W = Flambda.With_free_variables in - W.create_let_reusing_body v named (W.of_body_of_let let_expr) - in - Variable.Map.fold (fun to_substitute fresh expr -> - bind to_substitute fresh expr) - bindings expr - | Let_mutable let_mutable when - Variable.Map.mem let_mutable.initial_value substitution -> - let fresh = Variable.rename let_mutable.initial_value in - bind let_mutable.initial_value fresh - (Let_mutable { let_mutable with initial_value = fresh }) - | Let_mutable _ -> - expr - | Let_rec (defs, body) -> - let free_variables_of_defs = - List.fold_left (fun set (_, named) -> - Variable.Set.union set (Flambda.free_variables_named named)) - Variable.Set.empty defs - in - let to_substitute = - Variable.Set.filter - (fun v -> Variable.Map.mem v substitution) - free_variables_of_defs - in - if Variable.Set.is_empty to_substitute then - expr - else begin - let bindings = - Variable.Map.of_set (fun var -> Variable.rename var) to_substitute - in - let defs = - List.map (fun (var, named) -> - var, substitute_named bindings named) - defs - in - let expr = - Flambda.Let_rec (defs, body) - in - Variable.Map.fold (fun to_substitute fresh expr -> - bind to_substitute fresh expr) - bindings expr - end - | If_then_else (cond, ifso, ifnot) - when Variable.Map.mem cond substitution -> - let fresh = Variable.rename cond in - bind cond fresh (If_then_else (fresh, ifso, ifnot)) - | If_then_else _ -> - expr - | Switch (cond, sw) when Variable.Map.mem cond substitution -> - let fresh = Variable.rename cond in - bind cond fresh (Switch (fresh, sw)) - | Switch _ -> - expr - | String_switch (cond, sw, def) when Variable.Map.mem cond substitution -> - let fresh = Variable.rename cond in - bind cond fresh (String_switch (fresh, sw, def)) - | String_switch _ -> - expr - | Assign { being_assigned; new_value } - when Variable.Map.mem new_value substitution -> - let fresh = Variable.rename new_value in - bind new_value fresh (Assign { being_assigned; new_value = fresh }) - | Assign _ -> - expr - | Static_raise (exn, args) -> - let args, bind_args = - List.split (List.map make_var_subst args) - in - List.fold_right (fun f expr -> f expr) bind_args @@ - Flambda.Static_raise (exn, args) - | For { bound_var; from_value; to_value; direction; body } -> - let from_value, bind_from_value = make_var_subst from_value in - let to_value, bind_to_value = make_var_subst to_value in - bind_from_value @@ - bind_to_value @@ - Flambda.For { bound_var; from_value; to_value; direction; body } - | Apply { func; args; kind; dbg; inline; specialise } -> - let func, bind_func = make_var_subst func in - let args, bind_args = - List.split (List.map make_var_subst args) - in - bind_func @@ - List.fold_right (fun f expr -> f expr) bind_args @@ - Flambda.Apply { func; args; kind; dbg; inline; specialise } - | Send { kind; meth; obj; args; dbg } -> - let meth, bind_meth = make_var_subst meth in - let obj, bind_obj = make_var_subst obj in - let args, bind_args = - List.split (List.map make_var_subst args) - in - bind_meth @@ - bind_obj @@ - List.fold_right (fun f expr -> f expr) bind_args @@ - Flambda.Send { kind; meth; obj; args; dbg } - | Proved_unreachable - | While _ - | Try_with _ - | Static_catch _ -> - (* No variables directly used in those expressions *) - expr - in - Flambda_iterators.map_toplevel f (fun v -> v) expr - -module Switch_storer = Switch.Store (struct - type t = Flambda.t - - (* An easily-comparable subset of [Flambda.t]: currently this only - supports that required to share switch branches. *) - type key = - | Var of Variable.t - | Let of Variable.t * key_named * key - | Static_raise of Static_exception.t * Variable.t list - and key_named = - | Symbol of Symbol.t - | Const of Flambda.const - | Prim of Lambda.primitive * Variable.t list - | Expr of key - - exception Not_comparable - - let rec make_expr_key (expr : Flambda.t) : key = - match expr with - | Var v -> Var v - | Let { var; defining_expr; body; } -> - Let (var, make_named_key defining_expr, make_expr_key body) - | Static_raise (e, args) -> Static_raise (e, args) - | _ -> raise Not_comparable - and make_named_key (named:Flambda.named) : key_named = - match named with - | Symbol s -> Symbol s - | Const c -> Const c - | Expr e -> Expr (make_expr_key e) - | Prim (prim, args, _dbg) -> Prim (prim, args) - | _ -> raise Not_comparable - - let make_key expr = - match make_expr_key expr with - | exception Not_comparable -> None - | key -> Some key - - let compare_key e1 e2 = - (* The environment [env] maps variables bound in [e2] to the corresponding - bound variables in [e1]. Every variable to compare in [e2] must have an - equivalent in [e1], otherwise the comparison wouldn't have gone - past the [Let] binding. Hence [Variable.Map.find] is safe here. *) - let compare_var env v1 v2 = - match Variable.Map.find v2 env with - | exception Not_found -> - (* The variable is free in the expression [e2], hence we can - compare it with [v1] directly. *) - Variable.compare v1 v2 - | bound -> - Variable.compare v1 bound - in - let rec compare_expr env (e1 : key) (e2 : key) : int = - match e1, e2 with - | Var v1, Var v2 -> - compare_var env v1 v2 - | Var _, (Let _| Static_raise _) -> -1 - | (Let _| Static_raise _), Var _ -> 1 - | Let (v1, n1, b1), Let (v2, n2, b2) -> - let comp_named = compare_named env n1 n2 in - if comp_named <> 0 then comp_named - else - let env = Variable.Map.add v2 v1 env in - compare_expr env b1 b2 - | Let _, Static_raise _ -> -1 - | Static_raise _, Let _ -> 1 - | Static_raise (sexn1, args1), Static_raise (sexn2, args2) -> - let comp_sexn = Static_exception.compare sexn1 sexn2 in - if comp_sexn <> 0 then comp_sexn - else Misc.Stdlib.List.compare (compare_var env) args1 args2 - and compare_named env (n1:key_named) (n2:key_named) : int = - match n1, n2 with - | Symbol s1, Symbol s2 -> Symbol.compare s1 s2 - | Symbol _, (Const _ | Expr _ | Prim _) -> -1 - | (Const _ | Expr _ | Prim _), Symbol _ -> 1 - | Const c1, Const c2 -> Flambda.compare_const c1 c2 - | Const _, (Expr _ | Prim _) -> -1 - | (Expr _ | Prim _), Const _ -> 1 - | Expr e1, Expr e2 -> compare_expr env e1 e2 - | Expr _, Prim _ -> -1 - | Prim _, Expr _ -> 1 - | Prim (prim1, args1), Prim (prim2, args2) -> - let comp_prim = Stdlib.compare prim1 prim2 in - if comp_prim <> 0 then comp_prim - else Misc.Stdlib.List.compare (compare_var env) args1 args2 - in - compare_expr Variable.Map.empty e1 e2 -end) - -let fun_vars_referenced_in_decls - (function_decls : Flambda.function_declarations) ~closure_symbol = - let fun_vars = Variable.Map.keys function_decls.funs in - let symbols_to_fun_vars = - Variable.Set.fold (fun fun_var symbols_to_fun_vars -> - let closure_id = Closure_id.wrap fun_var in - let symbol = closure_symbol closure_id in - Symbol.Map.add symbol fun_var symbols_to_fun_vars) - fun_vars - Symbol.Map.empty - in - Variable.Map.map (fun (func_decl : Flambda.function_declaration) -> - let from_symbols = - Symbol.Set.fold (fun symbol fun_vars' -> - match Symbol.Map.find symbol symbols_to_fun_vars with - | exception Not_found -> fun_vars' - | fun_var -> - assert (Variable.Set.mem fun_var fun_vars); - Variable.Set.add fun_var fun_vars') - func_decl.free_symbols - Variable.Set.empty - in - let from_variables = - Variable.Set.inter func_decl.free_variables fun_vars - in - Variable.Set.union from_symbols from_variables) - function_decls.funs - -let closures_required_by_entry_point ~(entry_point : Closure_id.t) - ~closure_symbol (function_decls : Flambda.function_declarations) = - let dependencies = - fun_vars_referenced_in_decls function_decls ~closure_symbol - in - let set = ref Variable.Set.empty in - let queue = Queue.create () in - let add v = - if not (Variable.Set.mem v !set) then begin - set := Variable.Set.add v !set; - Queue.push v queue - end - in - add (Closure_id.unwrap entry_point); - while not (Queue.is_empty queue) do - let fun_var = Queue.pop queue in - match Variable.Map.find fun_var dependencies with - | exception Not_found -> () - | fun_dependencies -> - Variable.Set.iter (fun dep -> - if Variable.Map.mem dep function_decls.funs then - add dep) - fun_dependencies - done; - !set - -let all_functions_parameters (function_decls : Flambda.function_declarations) = - Variable.Map.fold (fun _ ({ params } : Flambda.function_declaration) set -> - Variable.Set.union set (Parameter.Set.vars params)) - function_decls.funs Variable.Set.empty - -let all_free_symbols (function_decls : Flambda.function_declarations) = - Variable.Map.fold (fun _ (function_decl : Flambda.function_declaration) - syms -> - Symbol.Set.union syms function_decl.free_symbols) - function_decls.funs Symbol.Set.empty - -let contains_stub (fun_decls : Flambda.function_declarations) = - let number_of_stub_functions = - Variable.Map.cardinal - (Variable.Map.filter (fun _ { Flambda.stub } -> stub) - fun_decls.funs) - in - number_of_stub_functions > 0 - -let clean_projections ~which_variables = - Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - match spec_to.projection with - | None -> spec_to - | Some projection -> - let from = Projection.projecting_from projection in - if Variable.Map.mem from which_variables then - spec_to - else - ({ spec_to with projection = None; } : Flambda.specialised_to)) - which_variables - -let projection_to_named (projection : Projection.t) : Flambda.named = - match projection with - | Project_var project_var -> Project_var project_var - | Project_closure project_closure -> Project_closure project_closure - | Move_within_set_of_closures move -> Move_within_set_of_closures move - | Field (field_index, var) -> - Prim (Pfield field_index, [var], Debuginfo.none) - -type specialised_to_same_as = - | Not_specialised - | Specialised_and_aliased_to of Variable.Set.t - -let parameters_specialised_to_the_same_variable - ~(function_decls : Flambda.function_declarations) - ~(specialised_args : Flambda.specialised_to Variable.Map.t) = - let specialised_arg_aliasing = - (* For each external variable involved in a specialisation, which - internal variable(s) it maps to via that specialisation. *) - Variable.Map.transpose_keys_and_data_set - (Variable.Map.map (fun ({ var; _ } : Flambda.specialised_to) -> var) - specialised_args) - in - Variable.Map.map (fun ({ params; _ } : Flambda.function_declaration) -> - List.map (fun param -> - match Variable.Map.find (Parameter.var param) specialised_args with - | exception Not_found -> Not_specialised - | { var; _ } -> - Specialised_and_aliased_to - (Variable.Map.find var specialised_arg_aliasing)) - params) - function_decls.funs diff --git a/middle_end/flambda_utils.mli b/middle_end/flambda_utils.mli deleted file mode 100644 index 0f7b3186..00000000 --- a/middle_end/flambda_utils.mli +++ /dev/null @@ -1,220 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Utility functions for the Flambda intermediate language. *) - -(** Access functions *) - -(** [find_declaration f decl] raises [Not_found] if [f] is not in [decl]. *) -val find_declaration : - Closure_id.t -> Flambda.function_declarations -> Flambda.function_declaration - -(** [find_declaration_variable f decl] raises [Not_found] if [f] is not in - [decl]. *) -val find_declaration_variable : - Closure_id.t -> Flambda.function_declarations -> Variable.t - -(** [find_free_variable v clos] raises [Not_found] if [c] is not in [clos]. *) -val find_free_variable : - Var_within_closure.t -> Flambda.set_of_closures -> Variable.t - -(** Utility functions *) - -val function_arity : Flambda.function_declaration -> int - -(** Variables "bound by a closure" are those variables free in the - corresponding function's body that are neither: - - bound as parameters of that function; nor - - bound by the [let] binding that introduces the function declaration(s). - In particular, if [f], [g] and [h] are being introduced by a - simultaneous, possibly mutually-recursive [let] binding then none of - [f], [g] or [h] are bound in any of the closures for [f], [g] and [h]. -*) -val variables_bound_by_the_closure : - Closure_id.t -> Flambda.function_declarations -> Variable.Set.t - -(** If [can_be_merged f1 f2] is [true], it is safe to merge switch - branches containing [f1] and [f2]. *) -val can_be_merged : Flambda.t -> Flambda.t -> bool - -val description_of_toplevel_node : Flambda.t -> string - -(* Given an expression, freshen all variables within it, and form a function - whose body is the resulting expression. The variables specified by - [params] will become the parameters of the function; the closure will be - identified by [id]. [params] must only reference variables that are - free variables of [body]. *) -(* CR-soon mshinwell: consider improving name and names of arguments - lwhite: the params restriction seems odd, perhaps give a reason - in the comment. *) -val make_closure_declaration - : is_classic_mode:bool - -> id:Variable.t - -> body:Flambda.t - -> params:Parameter.t list - -> stub:bool - -> Flambda.t - -val toplevel_substitution - : Variable.t Variable.Map.t - -> Flambda.expr - -> Flambda.expr - -val toplevel_substitution_named - : Variable.t Variable.Map.t - -> Flambda.named - -> Flambda.named - -(** [bind [var1, expr1; ...; varN, exprN] body] binds using - [Immutable] [Let] expressions the given [(var, expr)] pairs around the - body. *) -val bind - : bindings:(Variable.t * Flambda.named) list - -> body:Flambda.t - -> Flambda.t - -val name_expr - : name:Internal_variable_names.t - -> Flambda.named - -> Flambda.t - -val name_expr_from_var - : var:Variable.t - -> Flambda.named - -> Flambda.t - -val initialize_symbols - : Flambda.program - -> (Symbol.t * Tag.t * Flambda.t list) list - -val imported_symbols : Flambda.program -> Symbol.Set.t - -val needed_import_symbols : Flambda.program -> Symbol.Set.t - -val introduce_needed_import_symbols : Flambda.program -> Flambda.program - -val root_symbol : Flambda.program -> Symbol.t - -(** Returns [true] iff the given term might raise the given static - exception. *) -val might_raise_static_exn : Flambda.named -> Static_exception.t -> bool - -(** Creates a map from closure IDs to set_of_closure IDs by iterating over - all sets of closures in the given program. *) -val make_closure_map - : Flambda.program - -> Set_of_closures_id.t Closure_id.Map.t - -(** The definitions of all constants that have been lifted out to [Let_symbol] - or [Let_rec_symbol] constructions. *) -val all_lifted_constants - : Flambda.program - -> (Symbol.t * Flambda.constant_defining_value) list - -(** Like [all_lifted_constant_symbols], but returns a map instead of a list. *) -val all_lifted_constants_as_map - : Flambda.program - -> Flambda.constant_defining_value Symbol.Map.t - -(** The identifiers of all constant sets of closures that have been lifted out - to [Let_symbol] or [Let_rec_symbol] constructions. *) -val all_lifted_constant_sets_of_closures - : Flambda.program - -> Set_of_closures_id.Set.t - -val all_lifted_constant_closures : Flambda.program -> Closure_id.Set.t - -(** All sets of closures in the given program (whether or not bound to a - symbol.) *) -val all_sets_of_closures : Flambda.program -> Flambda.set_of_closures list - -val all_sets_of_closures_map - : Flambda.program - -> Flambda.set_of_closures Set_of_closures_id.Map.t - - -(* CR-someday pchambart: A more general version of this function might - take a [named] instead of a symbol and be called with - [Read_symbol_field (symbol, 0)]. *) -val substitute_read_symbol_field_for_variables - : (Symbol.t * int list) Variable.Map.t - -> Flambda.t - -> Flambda.t - -(** For the compilation of switch statements. *) -module Switch_storer : sig - val mk_store : unit -> (Flambda.t, unit) Switch.t_store -end - -(** Within a set of function declarations there is a set of function bodies, - each of which may (or may not) reference one of the other functions in - the same set. Initially such intra-set references are by [Var]s (known - as "fun_var"s) but if the function is lifted by [Lift_constants] then the - references will be translated to [Symbol]s. This means that optimization - passes that need to identify whether a given "fun_var" (i.e. a key in the - [funs] map in a value of type [function_declarations]) is used in one of - the function bodies need to examine the [free_symbols] as well as the - [free_variables] members of [function_declarations]. This function makes - that process easier by computing all used "fun_var"s in the bodies of - the given set of function declarations, including the cases where the - references are [Symbol]s. The returned value is a map from "fun_var"s - to the "fun_var"s (if any) used in the body of the function associated - with that "fun_var". -*) -val fun_vars_referenced_in_decls - : Flambda.function_declarations - -> closure_symbol:(Closure_id.t -> Symbol.t) - -> Variable.Set.t Variable.Map.t - -(** Computes the set of closure_id in the set of closures that are - required used (transitively) the entry_point *) -val closures_required_by_entry_point - : entry_point:Closure_id.t - -> closure_symbol:(Closure_id.t -> Symbol.t) - -> Flambda.function_declarations - -> Variable.Set.t - -val all_functions_parameters : Flambda.function_declarations -> Variable.Set.t - -val all_free_symbols : Flambda.function_declarations -> Symbol.Set.t - -val contains_stub : Flambda.function_declarations -> bool - -(* Ensure that projection information is suitably erased from - free_vars and specialised_args if we have deleted the variable being - projected from. *) -val clean_projections - : which_variables : Flambda.specialised_to Variable.Map.t - -> Flambda.specialised_to Variable.Map.t - -val projection_to_named : Projection.t -> Flambda.named - -type specialised_to_same_as = - | Not_specialised - | Specialised_and_aliased_to of Variable.Set.t - -(** For each parameter in a given set of function declarations and the usual - specialised-args mapping, determine which other parameters are specialised - to the same variable as that parameter. - The result is presented as a map from [fun_vars] to lists, corresponding - componentwise to the usual [params] list in the corresponding function - declaration. *) -val parameters_specialised_to_the_same_variable - : function_decls:Flambda.function_declarations - -> specialised_args:Flambda.specialised_to Variable.Map.t - -> specialised_to_same_as list Variable.Map.t diff --git a/middle_end/freshening.ml b/middle_end/freshening.ml deleted file mode 100644 index 891861a3..00000000 --- a/middle_end/freshening.ml +++ /dev/null @@ -1,458 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type tbl = { - sb_var : Variable.t Variable.Map.t; - sb_mutable_var : Mutable_variable.t Mutable_variable.Map.t; - sb_exn : Static_exception.t Static_exception.Map.t; - (* Used to handle substitution sequences: we cannot call the substitution - recursively because there can be name clashes. *) - back_var : Variable.t list Variable.Map.t; - back_mutable_var : Mutable_variable.t list Mutable_variable.Map.t; -} - -type t = - | Inactive - | Active of tbl - -type subst = t - -let empty_tbl = { - sb_var = Variable.Map.empty; - sb_mutable_var = Mutable_variable.Map.empty; - sb_exn = Static_exception.Map.empty; - back_var = Variable.Map.empty; - back_mutable_var = Mutable_variable.Map.empty; -} - -let print ppf = function - | Inactive -> Format.fprintf ppf "Inactive" - | Active tbl -> - Format.fprintf ppf "Active:@ "; - Variable.Map.iter (fun var1 var2 -> - Format.fprintf ppf "%a -> %a@ " - Variable.print var1 - Variable.print var2) - tbl.sb_var; - Mutable_variable.Map.iter (fun mut_var1 mut_var2 -> - Format.fprintf ppf "(mutable) %a -> %a@ " - Mutable_variable.print mut_var1 - Mutable_variable.print mut_var2) - tbl.sb_mutable_var; - Variable.Map.iter (fun var vars -> - Format.fprintf ppf "%a -> %a@ " - Variable.print var - Variable.Set.print (Variable.Set.of_list vars)) - tbl.back_var; - Mutable_variable.Map.iter (fun mut_var mut_vars -> - Format.fprintf ppf "(mutable) %a -> %a@ " - Mutable_variable.print mut_var - Mutable_variable.Set.print (Mutable_variable.Set.of_list mut_vars)) - tbl.back_mutable_var - -let empty = Inactive - -let is_empty = function - | Inactive -> true - | Active _ -> false - -let empty_preserving_activation_state = function - | Inactive -> Inactive - | Active _ -> Active empty_tbl - -let activate = function - | Inactive -> Active empty_tbl - | Active _ as t -> t - -let rec add_sb_var sb id id' = - let sb = { sb with sb_var = Variable.Map.add id id' sb.sb_var } in - let sb = - try let pre_vars = Variable.Map.find id sb.back_var in - List.fold_left (fun sb pre_id -> add_sb_var sb pre_id id') sb pre_vars - with Not_found -> sb in - let back_var = - let l = try Variable.Map.find id' sb.back_var with Not_found -> [] in - Variable.Map.add id' (id :: l) sb.back_var in - { sb with back_var } - -let rec add_sb_mutable_var sb id id' = - let sb = - { sb with - sb_mutable_var = Mutable_variable.Map.add id id' sb.sb_mutable_var; - } - in - let sb = - try - let pre_vars = Mutable_variable.Map.find id sb.back_mutable_var in - List.fold_left (fun sb pre_id -> add_sb_mutable_var sb pre_id id') - sb pre_vars - with Not_found -> sb in - let back_mutable_var = - let l = - try Mutable_variable.Map.find id' sb.back_mutable_var - with Not_found -> [] - in - Mutable_variable.Map.add id' (id :: l) sb.back_mutable_var - in - { sb with back_mutable_var } - -let apply_static_exception t i = - match t with - | Inactive -> - i - | Active t -> - try Static_exception.Map.find i t.sb_exn - with Not_found -> i - -let add_static_exception t i = - match t with - | Inactive -> i, t - | Active t -> - let i' = Static_exception.create () in - let sb_exn = - Static_exception.Map.add i i' t.sb_exn - in - i', Active { t with sb_exn; } - -let active_add_variable t id = - let id' = Variable.rename id in - let t = add_sb_var t id id' in - id', t - -let active_add_parameter t param = - let param' = Parameter.rename param in - let t = add_sb_var t (Parameter.var param) (Parameter.var param') in - param', t - -let add_variable t id = - match t with - | Inactive -> id, t - | Active t -> - let id', t = active_add_variable t id in - id', Active t - -let active_add_parameters' t (params:Parameter.t list) = - List.fold_right (fun param (params, t) -> - let param', t = active_add_parameter t param in - param' :: params, t) - params ([], t) - -let add_variables t defs = - List.fold_right (fun (id, data) (defs, t) -> - let id', t = add_variable t id in - (id', data) :: defs, t) defs ([], t) - -let add_variables' t ids = - List.fold_right (fun id (ids, t) -> - let id', t = add_variable t id in - id' :: ids, t) ids ([], t) - -let active_add_mutable_variable t id = - let id' = Mutable_variable.rename id in - let t = add_sb_mutable_var t id id' in - id', t - -let add_mutable_variable t id = - match t with - | Inactive -> id, t - | Active t -> - let id', t = active_add_mutable_variable t id in - id', Active t - -let active_find_var_exn t id = - try Variable.Map.find id t.sb_var with - | Not_found -> - Misc.fatal_error (Format.asprintf "find_var: can't find %a@." - Variable.print id) - -let apply_variable t var = - match t with - | Inactive -> var - | Active t -> - try Variable.Map.find var t.sb_var with - | Not_found -> var - -let apply_mutable_variable t mut_var = - match t with - | Inactive -> mut_var - | Active t -> - try Mutable_variable.Map.find mut_var t.sb_mutable_var with - | Not_found -> mut_var - -let rewrite_recursive_calls_with_symbols t - (function_declarations : Flambda.function_declarations) - ~make_closure_symbol = - match t with - | Inactive -> function_declarations - | Active _ -> - let all_free_symbols = - Variable.Map.fold - (fun _ (function_decl : Flambda.function_declaration) - syms -> - Symbol.Set.union syms function_decl.free_symbols) - function_declarations.funs Symbol.Set.empty - in - let closure_symbols_used = ref false in - let closure_symbols = - Variable.Map.fold (fun var _ map -> - let closure_id = Closure_id.wrap var in - let sym = make_closure_symbol closure_id in - if Symbol.Set.mem sym all_free_symbols then begin - closure_symbols_used := true; - Symbol.Map.add sym var map - end else begin - map - end) - function_declarations.funs Symbol.Map.empty - in - if not !closure_symbols_used then begin - (* Don't waste time rewriting the function declaration(s) if there - are no occurrences of any of the closure symbols. *) - function_declarations - end else begin - let funs = - Variable.Map.map (fun (ffun : Flambda.function_declaration) -> - let body = - Flambda_iterators.map_toplevel_named - (* CR-someday pchambart: This may be worth deep substituting - below the closures, but that means that we need to take care - of functions' free variables. *) - (function - | Symbol sym when Symbol.Map.mem sym closure_symbols -> - Expr (Var (Symbol.Map.find sym closure_symbols)) - | e -> e) - ffun.body - in - Flambda.update_body_of_function_declaration ffun ~body) - function_declarations.funs - in - Flambda.update_function_declarations function_declarations ~funs - end - -module Project_var = struct - type t = - { vars_within_closure : Var_within_closure.t Var_within_closure.Map.t; - closure_id : Closure_id.t Closure_id.Map.t } - - let empty = - { vars_within_closure = Var_within_closure.Map.empty; - closure_id = Closure_id.Map.empty; - } - - let print ppf t = - Format.fprintf ppf "{ vars_within_closure %a, closure_id %a }" - (Var_within_closure.Map.print Var_within_closure.print) - t.vars_within_closure - (Closure_id.Map.print Closure_id.print) - t.closure_id - - let new_subst_fv t id subst = - match subst with - | Inactive -> id, subst, t - | Active subst -> - let id' = Variable.rename id in - let subst = add_sb_var subst id id' in - let off = Var_within_closure.wrap id in - let off' = Var_within_closure.wrap id' in - let off_sb = Var_within_closure.Map.add off off' t.vars_within_closure in - id', Active subst, { t with vars_within_closure = off_sb; } - - let new_subst_fun t id subst = - let id' = Variable.rename id in - let subst = add_sb_var subst id id' in - let off = Closure_id.wrap id in - let off' = Closure_id.wrap id' in - let off_sb = Closure_id.Map.add off off' t.closure_id in - id', subst, { t with closure_id = off_sb; } - - (** Returns : - * The map of new_identifiers -> expression - * The new environment with added substitution - * a fresh ffunction_subst with only the substitution of free variables - *) - let subst_free_vars fv subst ~only_freshen_parameters - : (Flambda.specialised_to * _) Variable.Map.t * _ * _ = - Variable.Map.fold (fun id lam (fv, subst, t) -> - let id, subst, t = - if only_freshen_parameters then - id, subst, t - else - new_subst_fv t id subst - in - Variable.Map.add id lam fv, subst, t) - fv - (Variable.Map.empty, subst, empty) - - (** Returns : - * The function_declaration with renamed function identifiers - * The new environment with added substitution - * The ffunction_subst completed with function substitution - - subst_free_vars must have been used to build off_sb - *) - let func_decls_subst t (subst : subst) - (func_decls : Flambda.function_declarations) - ~only_freshen_parameters = - match subst with - | Inactive -> func_decls, subst, t - | Active subst -> - let subst_func_decl _fun_id (func_decl : Flambda.function_declaration) - subst = - let params, subst = active_add_parameters' subst func_decl.params in - (* Since all parameters are distinct, even between functions, we can - just use a single substitution. *) - let body = - Flambda_utils.toplevel_substitution subst.sb_var func_decl.body - in - let function_decl = - Flambda.create_function_declaration ~params ~body - ~stub:func_decl.stub ~dbg:func_decl.dbg - ~inline:func_decl.inline ~specialise:func_decl.specialise - ~is_a_functor:func_decl.is_a_functor - ~closure_origin:func_decl.closure_origin - in - function_decl, subst - in - let subst, t = - if only_freshen_parameters then - subst, t - else - Variable.Map.fold (fun orig_id _func_decl (subst, t) -> - let _id, subst, t = new_subst_fun t orig_id subst in - subst, t) - func_decls.funs - (subst, t) - in - let funs, subst = - Variable.Map.fold (fun orig_id func_decl (funs, subst) -> - let func_decl, subst = subst_func_decl orig_id func_decl subst in - let id = - if only_freshen_parameters then orig_id - else active_find_var_exn subst orig_id - in - let funs = Variable.Map.add id func_decl funs in - funs, subst) - func_decls.funs - (Variable.Map.empty, subst) - in - let function_decls = - Flambda.update_function_declarations func_decls ~funs - in - function_decls, Active subst, t - - let apply_closure_id t closure_id = - try Closure_id.Map.find closure_id t.closure_id - with Not_found -> closure_id - - let apply_var_within_closure t var_in_closure = - try Var_within_closure.Map.find var_in_closure t.vars_within_closure - with Not_found -> var_in_closure - - module Compose (T : Identifiable.S) = struct - let compose ~earlier ~later = - if (T.Map.equal T.equal) earlier later - || T.Map.cardinal later = 0 - then - earlier - else - T.Map.mapi (fun src_var var -> - if T.Map.mem src_var later then begin - Misc.fatal_errorf "Freshening.Project_var.compose: domains \ - of substitutions must be disjoint. earlier=%a later=%a" - (T.Map.print T.print) earlier - (T.Map.print T.print) later - end; - match T.Map.find var later with - | exception Not_found -> var - | var -> var) - earlier - end - - module V = Compose (Var_within_closure) - module C = Compose (Closure_id) - - let compose ~earlier ~later : t = - { vars_within_closure = - V.compose ~earlier:earlier.vars_within_closure - ~later:later.vars_within_closure; - closure_id = - C.compose ~earlier:earlier.closure_id - ~later:later.closure_id; - } -end - -let apply_function_decls_and_free_vars t fv func_decls - ~only_freshen_parameters = - let module I = Project_var in - let fv, t, of_closures = I.subst_free_vars fv t ~only_freshen_parameters in - let func_decls, t, of_closures = - I.func_decls_subst of_closures t func_decls ~only_freshen_parameters - in - fv, func_decls, t, of_closures - -let does_not_freshen t vars = - match t with - | Inactive -> true - | Active subst -> - not (List.exists (fun var -> Variable.Map.mem var subst.sb_var) vars) - -let freshen_projection (projection : Projection.t) ~freshening - ~closure_freshening : Projection.t = - match projection with - | Project_var { closure; closure_id; var; } -> - Project_var { - closure = apply_variable freshening closure; - closure_id = Project_var.apply_closure_id closure_freshening closure_id; - var = Project_var.apply_var_within_closure closure_freshening var; - } - | Project_closure { set_of_closures; closure_id; } -> - Project_closure { - set_of_closures = apply_variable freshening set_of_closures; - closure_id = Project_var.apply_closure_id closure_freshening closure_id; - } - | Move_within_set_of_closures { closure; start_from; move_to; } -> - Move_within_set_of_closures { - closure = apply_variable freshening closure; - start_from = Project_var.apply_closure_id closure_freshening start_from; - move_to = Project_var.apply_closure_id closure_freshening move_to; - } - | Field (field_index, var) -> - Field (field_index, apply_variable freshening var) - -let freshen_projection_relation relation ~freshening ~closure_freshening = - Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - let projection = - match spec_to.projection with - | None -> None - | Some projection -> - Some (freshen_projection projection ~freshening ~closure_freshening) - in - { spec_to with projection; }) - relation - -let freshen_projection_relation' relation ~freshening ~closure_freshening = - Variable.Map.map (fun ((spec_to : Flambda.specialised_to), data) -> - let projection = - match spec_to.projection with - | None -> None - | Some projection -> - Some (freshen_projection projection ~freshening ~closure_freshening) - in - { spec_to with projection; }, data) - relation diff --git a/middle_end/freshening.mli b/middle_end/freshening.mli deleted file mode 100644 index 1550797a..00000000 --- a/middle_end/freshening.mli +++ /dev/null @@ -1,167 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Freshening of various identifiers. *) - -(** A table used for freshening variables and static exception identifiers. *) -type t -type subst = t - -(** The freshening that does nothing. This is the unique inactive - freshening. *) -val empty : t - -val is_empty : t -> bool - -(** Activate the freshening. Without activation, operations to request - freshenings have no effect (cf. the documentation below for - [add_variable]). As such, the inactive renaming is unique. *) -val activate : t -> t - -(** Given the inactive freshening, return the same; otherwise, return an - empty active freshening. *) -val empty_preserving_activation_state : t -> t - -(** [add_variable t var] - If [t] is active: - It returns a fresh variable [new_var] and adds [var] -> [new_var] - to the freshening. - If a renaming [other_var] -> [var] or [symbol] -> [var] was already - present in [t], it will also add [other_var] -> [new_var] and - [symbol] -> [new_var]. - If [t] is inactive, this is the identity. -*) -val add_variable : t -> Variable.t -> Variable.t * t - -(** Like [add_variable], but for multiple variables, each freshened - separately. *) -val add_variables' - : t - -> Variable.t list - -> Variable.t list * t - -(** Like [add_variables'], but passes through the second component of the - input list unchanged. *) -val add_variables - : t - -> (Variable.t * 'a) list - -> (Variable.t * 'a) list * t - -(** Like [add_variable], but for mutable variables. *) -val add_mutable_variable : t -> Mutable_variable.t -> Mutable_variable.t * t - -(** As for [add_variable], but for static exception identifiers. *) -val add_static_exception : t -> Static_exception.t -> Static_exception.t * t - -(** [apply_variable t var] applies the freshening [t] to [var]. - If no renaming is specified in [t] for [var] it is returned unchanged. *) -val apply_variable : t -> Variable.t -> Variable.t - -(** As for [apply_variable], but for mutable variables. *) -val apply_mutable_variable : t -> Mutable_variable.t -> Mutable_variable.t - -(** As for [apply_variable], but for static exception identifiers. *) -val apply_static_exception : t -> Static_exception.t -> Static_exception.t - -(** Replace recursive accesses to the closures in the set through - [Symbol] by the corresponding [Var]. This is used to recover - the recursive call when importing code from another compilation unit. - - If the renaming is inactive, this is the identity. -*) -val rewrite_recursive_calls_with_symbols - : t - -> Flambda.function_declarations - -> make_closure_symbol:(Closure_id.t -> Symbol.t) - -> Flambda.function_declarations - -(* CR-soon mshinwell for mshinwell: maybe inaccurate module name, it freshens - closure IDs as well. Check use points though *) -module Project_var : sig - (** A table used for freshening of identifiers in [Project_closure] and - [Move_within_set_of_closures] ("ids of closures"); and [Project_var] - ("bound vars of closures") expressions. - - This information is propagated bottom up and populated when inlining a - function containing a closure declaration. - - For instance, - [let f x = - let g y = ... x ... in - ... g.x ... (Project_var x) - ... g 1 ... (Apply (Project_closure g ...)) - ] - - If f is inlined, g is renamed. The approximation of g will carry this - table such that later the access to the field x of g and selection of - g in the closure can be substituted. - *) - type t - - (* The freshening that does nothing. *) - val empty : t - - (** Composition of two freshenings. *) - val compose : earlier:t -> later:t -> t - - (** Freshen a closure ID based on the given renaming. The same ID is - returned if the renaming does not affect it. - If dealing with approximations, you probably want to use - [Simple_value_approx.freshen_and_check_closure_id] instead of this - function. - *) - val apply_closure_id : t -> Closure_id.t -> Closure_id.t - - (** Like [apply_closure_id], but for variables within closures. *) - val apply_var_within_closure - : t - -> Var_within_closure.t - -> Var_within_closure.t - - val print : Format.formatter -> t -> unit -end - -(* CR-soon mshinwell for mshinwell: add comment *) -val apply_function_decls_and_free_vars - : t - -> (Flambda.specialised_to * 'a) Variable.Map.t - -> Flambda.function_declarations - -> only_freshen_parameters:bool - -> (Flambda.specialised_to * 'a) Variable.Map.t - * Flambda.function_declarations - * t - * Project_var.t - -val does_not_freshen : t -> Variable.t list -> bool - -val print : Format.formatter -> t -> unit - -(** N.B. This does not freshen the domain of the supplied map, only the - range. *) -(* CR-someday mshinwell: consider fixing that *) -val freshen_projection_relation - : Flambda.specialised_to Variable.Map.t - -> freshening:t - -> closure_freshening:Project_var.t - -> Flambda.specialised_to Variable.Map.t - -val freshen_projection_relation' - : (Flambda.specialised_to * 'a) Variable.Map.t - -> freshening:t - -> closure_freshening:Project_var.t - -> (Flambda.specialised_to * 'a) Variable.Map.t diff --git a/middle_end/inconstant_idents.ml b/middle_end/inconstant_idents.ml deleted file mode 100755 index 3d8ba904..00000000 --- a/middle_end/inconstant_idents.ml +++ /dev/null @@ -1,504 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -(* This cannot be done in a single simple pass due to expressions like: - - let rec ... = - ... - let rec f1 x = - let f2 y = - f1 rec_list - in - f2 v - and rec_list = f1 :: rec_list in - ... - - and v = ... - - f1, f2 and rec_list are constants iff v is a constant. - - To handle this we populate both a 'not constant' set NC and a set of - implications between variables. - - For example, the above code would generate the implications: - - f1 in NC => rec_list in NC - f2 in NC => f1 in NC - rec_list in NC => f2 in NC - v in NC => f1 in NC - - then if v is found to be in NC this will be propagated to place - f1, f2 and rec_list in NC as well. - -*) - -(* CR-someday lwhite: I think this pass could be combined with - alias_analysis and other parts of lift_constants into a single - type-based analysis which infers a "type" for each variable that is - either an allocated_constant expression or "not constant". Recursion - would be handled with unification variables. *) - -module Int = Numbers.Int -module Symbol_field = struct - type t = Symbol.t * Int.t - include Identifiable.Make (Identifiable.Pair (Symbol) (Int)) -end - -type dep = - | Closure of Set_of_closures_id.t - | Var of Variable.t - | Symbol of Symbol.t - | Symbol_field of Symbol_field.t - -type state = - | Not_constant - | Implication of dep list - -type result = { - id : state Variable.Tbl.t; - closure : state Set_of_closures_id.Tbl.t; -} - -module type Param = sig - val program : Flambda.program - val compilation_unit : Compilation_unit.t -end - -(* CR-soon mshinwell: consider removing functor *) -module Inconstants (P:Param) (Backend:Backend_intf.S) = struct - let program = P.program - let compilation_unit = P.compilation_unit - let imported_symbols = Flambda_utils.imported_symbols program - - (* Sets representing NC *) - let variables : state Variable.Tbl.t = Variable.Tbl.create 42 - let closures : state Set_of_closures_id.Tbl.t = - Set_of_closures_id.Tbl.create 42 - let symbols : state Symbol.Tbl.t = Symbol.Tbl.create 42 - let symbol_fields : state Symbol_field.Tbl.t = Symbol_field.Tbl.create 42 - - let mark_queue = Queue.create () - - (* CR-soon pchambart: We could probably improve that quite a lot by adding - (the future annotation) [@unrolled] at the right call sites. Or more - directly mark mark_dep as [@inline] and call it instead of mark_curr in - some situations. - *) - - (* adds 'dep in NC' *) - let rec mark_dep = function - | Var id -> begin - match Variable.Tbl.find variables id with - | Not_constant -> () - | Implication deps -> - Variable.Tbl.replace variables id Not_constant; - Queue.push deps mark_queue - | exception Not_found -> - Variable.Tbl.add variables id Not_constant - end - | Closure cl -> begin - match Set_of_closures_id.Tbl.find closures cl with - | Not_constant -> () - | Implication deps -> - Set_of_closures_id.Tbl.replace closures cl Not_constant; - Queue.push deps mark_queue - | exception Not_found -> - Set_of_closures_id.Tbl.add closures cl Not_constant - end - | Symbol s -> begin - match Symbol.Tbl.find symbols s with - | Not_constant -> () - | Implication deps -> - Symbol.Tbl.replace symbols s Not_constant; - Queue.push deps mark_queue - | exception Not_found -> - Symbol.Tbl.add symbols s Not_constant - end - | Symbol_field s -> begin - match Symbol_field.Tbl.find symbol_fields s with - | Not_constant -> () - | Implication deps -> - Symbol_field.Tbl.replace symbol_fields s Not_constant; - Queue.push deps mark_queue - | exception Not_found -> - Symbol_field.Tbl.add symbol_fields s Not_constant - end - - and mark_deps deps = - List.iter mark_dep deps - - and complete_marking () = - while not (Queue.is_empty mark_queue) do - let deps = - try - Queue.take mark_queue - with Not_found -> [] - in - mark_deps deps; - done - - (* adds 'curr in NC' *) - let mark_curr curr = - mark_deps curr; - complete_marking () - - (* adds in the tables 'dep in NC => curr in NC' *) - let register_implication ~in_nc:dep ~implies_in_nc:curr = - match dep with - | Var id -> begin - match Variable.Tbl.find variables id with - | Not_constant -> - mark_deps curr; - complete_marking (); - | Implication deps -> - let deps = List.rev_append curr deps in - Variable.Tbl.replace variables id (Implication deps) - | exception Not_found -> - Variable.Tbl.add variables id (Implication curr); - end - | Closure cl -> begin - match Set_of_closures_id.Tbl.find closures cl with - | Not_constant -> - mark_deps curr; - complete_marking (); - | Implication deps -> - let deps = List.rev_append curr deps in - Set_of_closures_id.Tbl.replace closures cl (Implication deps) - | exception Not_found -> - Set_of_closures_id.Tbl.add closures cl (Implication curr); - end - | Symbol symbol -> begin - match Symbol.Tbl.find symbols symbol with - | Not_constant -> - mark_deps curr; - complete_marking (); - | Implication deps -> - let deps = List.rev_append curr deps in - Symbol.Tbl.replace symbols symbol (Implication deps) - | exception Not_found -> - Symbol.Tbl.add symbols symbol (Implication curr); - end - | Symbol_field ((symbol, _) as field) -> begin - match Symbol_field.Tbl.find symbol_fields field with - | Not_constant -> - mark_deps curr; - complete_marking (); - | Implication deps -> - let deps = List.rev_append curr deps in - Symbol_field.Tbl.replace symbol_fields field (Implication deps) - | exception Not_found -> - (* There is no information available about the contents of imported - symbols, so we must consider all their fields as inconstant. *) - (* CR-someday pchambart: recover that from the cmx information *) - if Symbol.Set.mem symbol imported_symbols then begin - Symbol_field.Tbl.add symbol_fields field Not_constant; - mark_deps curr; - complete_marking (); - end else begin - Symbol_field.Tbl.add symbol_fields field (Implication curr) - end - end - - (* First loop: iterates on the tree to mark dependencies. - - curr is the variables or closures to which we add constraints like - '... in NC => curr in NC' or 'curr in NC' - - It can be empty when no constraint can be added like in the toplevel - expression or in the body of a function. - *) - let rec mark_loop ~toplevel (curr : dep list) (flam : Flambda.t) = - match flam with - | Let { var; defining_expr = lam; body; _ } -> - mark_named ~toplevel [Var var] lam; - (* adds 'var in NC => curr in NC' - This is not really necessary, but compiling this correctly is - trickier than eliminating that earlier. *) - mark_var var curr; - mark_loop ~toplevel curr body - | Let_mutable { initial_value = var; body } -> - mark_var var curr; - mark_loop ~toplevel curr body - | Let_rec(defs, body) -> - List.iter (fun (var, def) -> - mark_named ~toplevel [Var var] def; - (* adds 'var in NC => curr in NC' same remark as let case *) - mark_var var curr) - defs; - mark_loop ~toplevel curr body - | Var var -> mark_var var curr - (* Not constant cases: we mark directly 'curr in NC' and mark - bound variables as in NC also *) - | Assign _ -> - mark_curr curr - | Try_with (f1,id,f2) -> - mark_curr [Var id]; - mark_curr curr; - mark_loop ~toplevel [] f1; - mark_loop ~toplevel [] f2 - | Static_catch (_,ids,f1,f2) -> - List.iter (fun id -> mark_curr [Var id]) ids; - mark_curr curr; - mark_loop ~toplevel [] f1; - mark_loop ~toplevel [] f2 - (* CR-someday pchambart: If recursive staticcatch is introduced: - this becomes ~toplevel:false *) - | For { bound_var; from_value; to_value; direction = _; body; } -> - mark_curr [Var bound_var]; - mark_var from_value curr; - mark_var to_value curr; - mark_curr curr; - mark_loop ~toplevel:false [] body - | While (f1,body) -> - mark_curr curr; - mark_loop ~toplevel [] f1; - mark_loop ~toplevel:false [] body - | If_then_else (f1,f2,f3) -> - mark_curr curr; - mark_curr [Var f1]; - mark_loop ~toplevel [] f2; - mark_loop ~toplevel [] f3 - | Static_raise (_,l) -> - mark_curr curr; - List.iter (fun v -> mark_var v curr) l - | Apply ({func; args; _ }) -> - mark_curr curr; - mark_var func curr; - mark_vars args curr; - | Switch (arg,sw) -> - mark_curr curr; - mark_var arg curr; - List.iter (fun (_,l) -> mark_loop ~toplevel [] l) sw.consts; - List.iter (fun (_,l) -> mark_loop ~toplevel [] l) sw.blocks; - Misc.may (fun l -> mark_loop ~toplevel [] l) sw.failaction - | String_switch (arg,sw,def) -> - mark_curr curr; - mark_var arg curr; - List.iter (fun (_,l) -> mark_loop ~toplevel [] l) sw; - Misc.may (fun l -> mark_loop ~toplevel [] l) def - | Send { kind = _; meth; obj; args; dbg = _; } -> - mark_curr curr; - mark_var meth curr; - mark_var obj curr; - List.iter (fun arg -> mark_var arg curr) args - | Proved_unreachable -> - mark_curr curr - - and mark_named ~toplevel curr (named : Flambda.named) = - match named with - | Set_of_closures (set_of_closures) -> - mark_loop_set_of_closures ~toplevel curr set_of_closures - | Const _ | Allocated_const _ -> () - | Read_mutable _ -> mark_curr curr - | Symbol symbol -> begin - let current_unit = Compilation_unit.get_current_exn () in - if Compilation_unit.equal current_unit (Symbol.compilation_unit symbol) - then - () - else - match (Backend.import_symbol symbol).descr with - | Value_unresolved _ -> - (* Constant when 'for_clambda' means: can be a symbol (which is - obviously the case here) with a known approximation. If this - condition is not satisfied we mark as inconstant to reflect - the fact that the symbol's contents are unknown and thus - prevent attempts to examine it. (This is a bit of a hack.) *) - mark_curr curr - | _ -> - () - end - | Read_symbol_field (symbol, index) -> - register_implication ~in_nc:(Symbol_field (symbol, index)) - ~implies_in_nc:curr - (* Globals are symbols: handle like symbols *) - | Prim (Lambda.Pgetglobal _id, [], _) -> () - (* Constant constructors: those expressions are constant if all their - parameters are: - - makeblock is compiled to a constant block - - offset is compiled to a pointer inside a constant closure. - See Cmmgen for the details - - makeblock(Mutable) can be a 'constant' if it is allocated at - toplevel: if this expression is evaluated only once. - *) - | Prim (Lambda.Pmakeblock (_tag, Asttypes.Immutable, _value_kind), args, - _dbg) -> - mark_vars args curr -(* (* CR-someday pchambart: If global mutables are allowed: *) - | Prim(Lambda.Pmakeblock(_tag, Asttypes.Mutable), args, _dbg, _) - when toplevel -> - List.iter (mark_loop ~toplevel curr) args -*) - | Prim (Pmakearray (Pfloatarray, Immutable), args, _) -> - mark_vars args curr - | Prim (Pmakearray (Pfloatarray, Mutable), args, _) -> - (* CR-someday pchambart: Toplevel float arrays could always be - statically allocated using an equivalent of the - Initialize_symbol construction. - Toplevel non-float arrays could also be turned into an - Initialize_symbol, but only when declared as immutable since - preallocated symbols does not allow mutation after - initialisation - *) - if toplevel then mark_vars args curr - else mark_curr curr - | Prim (Pduparray (Pfloatarray, Immutable), [arg], _) -> - mark_var arg curr - | Prim (Pduparray (Pfloatarray, Mutable), [arg], _) -> - if toplevel then mark_var arg curr - else mark_curr curr - | Prim (Pduparray _, _, _) -> - (* See Lift_constants *) - mark_curr curr - | Project_closure ({ set_of_closures; closure_id; }) -> - if Closure_id.in_compilation_unit closure_id compilation_unit then - mark_var set_of_closures curr - else - mark_curr curr - | Move_within_set_of_closures ({ closure; start_from; move_to; }) -> - (* CR-someday mshinwell: We should be able to deem these projections - (same for the cases below) as constant when from another - compilation unit, but there isn't code to handle this yet. (Note - that for Project_var we cannot yet generate a projection from a - closure in another compilation unit, since we only lift closed - closures.) *) - if Closure_id.in_compilation_unit start_from compilation_unit then begin - assert (Closure_id.in_compilation_unit move_to compilation_unit); - mark_var closure curr - end else begin - mark_curr curr - end - | Project_var ({ closure; closure_id; var = _ }) -> - if Closure_id.in_compilation_unit closure_id compilation_unit then - mark_var closure curr - else - mark_curr curr - | Prim (Lambda.Pfield _, [f1], _) -> - mark_curr curr; - mark_var f1 curr - | Prim (_, args, _) -> - mark_curr curr; - mark_vars args curr - | Expr flam -> - mark_loop ~toplevel curr flam - - and mark_var var curr = - (* adds 'id in NC => curr in NC' *) - register_implication ~in_nc:(Var var) ~implies_in_nc:curr - - and mark_vars vars curr = - (* adds 'id in NC => curr in NC' *) - List.iter (fun var -> mark_var var curr) vars - - (* [toplevel] is intended for allowing static allocations of mutable - blocks. This feature should be available in a future release once the - necessary GC changes have been merged. (See GPR#178.) *) - and mark_loop_set_of_closures ~toplevel:_ curr - { Flambda. function_decls; free_vars; specialised_args } = - (* If a function in the set of closures is specialised, do not consider - it constant, unless all specialised args are also constant. *) - Variable.Map.iter (fun _ (spec_arg : Flambda.specialised_to) -> - register_implication - ~in_nc:(Var spec_arg.var) - ~implies_in_nc:[Closure function_decls.set_of_closures_id]) - specialised_args; - (* adds 'function_decls in NC => curr in NC' *) - register_implication ~in_nc:(Closure function_decls.set_of_closures_id) - ~implies_in_nc:curr; - (* a closure is constant if its free variables are constants. *) - Variable.Map.iter (fun inner_id (var : Flambda.specialised_to) -> - register_implication ~in_nc:(Var var.var) - ~implies_in_nc:[ - Var inner_id; - Closure function_decls.set_of_closures_id - ]) - free_vars; - Variable.Map.iter (fun fun_id (ffunc : Flambda.function_declaration) -> - (* for each function f in a closure c 'c in NC => f' *) - register_implication ~in_nc:(Closure function_decls.set_of_closures_id) - ~implies_in_nc:[Var fun_id]; - (* function parameters are in NC unless specialised *) - List.iter (fun param -> - match Variable.Map.find param specialised_args with - | exception Not_found -> mark_curr [Var param] - | outer_var -> - register_implication ~in_nc:(Var outer_var.var) - ~implies_in_nc:[Var param]) - (Parameter.List.vars ffunc.params); - mark_loop ~toplevel:false [] ffunc.body) - function_decls.funs - - let mark_constant_defining_value (const:Flambda.constant_defining_value) = - match const with - | Allocated_const _ - | Block _ - | Project_closure _ -> () - | Set_of_closures set_of_closure -> - mark_loop_set_of_closures ~toplevel:true [] set_of_closure - - let mark_program (program : Flambda.program) = - let rec loop (program : Flambda.program_body) = - match program with - | End _ -> () - | Initialize_symbol (symbol,_tag,fields,program) -> - List.iteri (fun i field -> - mark_loop ~toplevel:true - [Symbol symbol; Symbol_field (symbol,i)] field) - fields; - loop program - | Effect (expr, program) -> - mark_loop ~toplevel:true [] expr; - loop program - | Let_symbol (_, def, program) -> - mark_constant_defining_value def; - loop program - | Let_rec_symbol (defs, program) -> - List.iter (fun (_, def) -> mark_constant_defining_value def) defs; - loop program - in - loop program.program_body - - let res = - mark_program program; - { id = variables; - closure = closures; - } -end - -let inconstants_on_program ~compilation_unit ~backend - (program : Flambda.program) = - let module P = struct - let program = program - let compilation_unit = compilation_unit - end in - let module Backend = (val backend : Backend_intf.S) in - let module I = Inconstants (P) (Backend) in - I.res - -let variable var { id; _ } = - match Variable.Tbl.find id var with - | Not_constant -> true - | Implication _ -> false - | exception Not_found -> false - -let closure cl { closure; _ } = - match Set_of_closures_id.Tbl.find closure cl with - | Not_constant -> true - | Implication _ -> false - | exception Not_found -> false diff --git a/middle_end/inconstant_idents.mli b/middle_end/inconstant_idents.mli deleted file mode 100644 index 2c5309e0..00000000 --- a/middle_end/inconstant_idents.mli +++ /dev/null @@ -1,36 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -type result - -(** [inconstants_on_program] finds those variables and set-of-closures - identifiers that cannot be compiled to constants by [Flambda_to_clambda]. -*) -val inconstants_on_program - : compilation_unit:Compilation_unit.t - -> backend:(module Backend_intf.S) - -> Flambda.program - -> result - -(** [variable var res] returns [true] if [var] is marked as inconstant - in [res]. *) -val variable : Variable.t -> result -> bool - -(** [closure cl res] returns [true] if [cl] is marked as inconstant - in [res]. *) -val closure : Set_of_closures_id.t -> result -> bool diff --git a/middle_end/initialize_symbol_to_let_symbol.ml b/middle_end/initialize_symbol_to_let_symbol.ml deleted file mode 100644 index 31246b0d..00000000 --- a/middle_end/initialize_symbol_to_let_symbol.ml +++ /dev/null @@ -1,57 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let constant_field (expr:Flambda.t) - : Flambda.constant_defining_value_block_field option = - match expr with - | Let { var; defining_expr = Const c; body = Var var' ; _ } -> - assert(Variable.equal var var'); - (* This must be true since var is the only variable in scope *) - Some (Flambda.Const c) - | Let { var; defining_expr = Symbol s; body = Var var' ; _ } -> - assert(Variable.equal var var'); - Some (Flambda.Symbol s) - | _ -> - None - -let rec loop (program : Flambda.program_body) : Flambda.program_body = - match program with - | Initialize_symbol (symbol, tag, fields, program) -> - let constant_fields = List.map constant_field fields in - begin - match Misc.Stdlib.List.some_if_all_elements_are_some constant_fields - with - | None -> - Initialize_symbol (symbol, tag, fields, loop program) - | Some fields -> - Let_symbol (symbol, Block (tag, fields), loop program) - end - | Let_symbol (symbol, const, program) -> - Let_symbol (symbol, const, loop program) - | Let_rec_symbol (defs, program) -> - Let_rec_symbol (defs, loop program) - | Effect (expr, program) -> - Effect (expr, loop program) - | End symbol -> - End symbol - -let run (program : Flambda.program) = - { program with - program_body = loop program.program_body; - } diff --git a/middle_end/initialize_symbol_to_let_symbol.mli b/middle_end/initialize_symbol_to_let_symbol.mli deleted file mode 100644 index fc54f760..00000000 --- a/middle_end/initialize_symbol_to_let_symbol.mli +++ /dev/null @@ -1,25 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -val constant_field - : Flambda.t - -> Flambda.constant_defining_value_block_field option - -(** Transform Initialize_symbol with only constant fields to - let_symbol construction. *) -val run : Flambda.program -> Flambda.program diff --git a/middle_end/inline_and_simplify.ml b/middle_end/inline_and_simplify.ml deleted file mode 100755 index c1e6ff56..00000000 --- a/middle_end/inline_and_simplify.ml +++ /dev/null @@ -1,1705 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module A = Simple_value_approx -module B = Inlining_cost.Benefit -module E = Inline_and_simplify_aux.Env -module R = Inline_and_simplify_aux.Result - -(** Values of two types hold the information propagated during simplification: - - [E.t] "environments", top-down, almost always called "env"; - - [R.t] "results", bottom-up approximately following the evaluation order, - almost always called "r". These results come along with rewritten - Flambda terms. - The environments map variables to approximations, which enable various - simplifications to be performed; for example, some variable may be known - to always hold a particular constant. -*) - -let ret = R.set_approx - -type simplify_variable_result = - | No_binding of Variable.t - | Binding of Variable.t * (Flambda.named Flambda.With_free_variables.t) - -let simplify_free_variable_internal env original_var = - let var = Freshening.apply_variable (E.freshening env) original_var in - let original_var = var in - (* In the case where an approximation is useful, we introduce a [let] - to bind (e.g.) the constant or symbol replacing [var], unless this - would introduce a useless [let] as a consequence of [var] already being - in the current scope. - - Even when the approximation is not useful, this simplification helps. - In particular, it squashes aliases of the form: - let var1 = var2 in ... var2 ... - by replacing [var2] in the body with [var1]. Simplification can then - eliminate the [let]. - *) - let var = - let approx = E.find_exn env var in - match approx.var with - | Some var when E.mem env var -> var - | Some _ | None -> var - in - (* CR-soon mshinwell: Should we update [r] when we *add* code? - Aside from that, it looks like maybe we don't need [r] in this function, - because the approximation within it wouldn't be used by any of the - call sites. *) - match E.find_with_scope_exn env var with - | Current, approx -> No_binding var, approx (* avoid useless [let] *) - | Outer, approx -> - match A.simplify_var approx with - | None -> No_binding var, approx - | Some (named, approx) -> - let module W = Flambda.With_free_variables in - Binding (original_var, W.of_named named), approx - -let simplify_free_variable env var ~f : Flambda.t * R.t = - match simplify_free_variable_internal env var with - | No_binding var, approx -> f env var approx - | Binding (var, named), approx -> - let module W = Flambda.With_free_variables in - let var = Variable.rename var in - let env = E.add env var approx in - let body, r = f env var approx in - (W.create_let_reusing_defining_expr var named body), r - -let simplify_free_variables env vars ~f : Flambda.t * R.t = - let rec collect_bindings vars env bound_vars approxs : Flambda.t * R.t = - match vars with - | [] -> f env (List.rev bound_vars) (List.rev approxs) - | var::vars -> - match simplify_free_variable_internal env var with - | No_binding var, approx -> - collect_bindings vars env (var::bound_vars) (approx::approxs) - | Binding (var, named), approx -> - let module W = Flambda.With_free_variables in - let var = Variable.rename var in - let env = E.add env var approx in - let body, r = - collect_bindings vars env (var::bound_vars) (approx::approxs) - in - (W.create_let_reusing_defining_expr var named body), r - in - collect_bindings vars env [] [] - -let simplify_free_variables_named env vars ~f : Flambda.named * R.t = - let rec collect_bindings vars env bound_vars approxs - : Flambda.maybe_named * R.t = - match vars with - | [] -> - let named, r = f env (List.rev bound_vars) (List.rev approxs) in - Is_named named, r - | var::vars -> - match simplify_free_variable_internal env var with - | No_binding var, approx -> - collect_bindings vars env (var::bound_vars) (approx::approxs) - | Binding (var, named), approx -> - let module W = Flambda.With_free_variables in - let var = Variable.rename var in - let env = E.add env var approx in - let body, r = - collect_bindings vars env (var::bound_vars) (approx::approxs) - in - let body = - match body with - | Is_named body -> - let name = Internal_variable_names.simplify_fv in - Flambda_utils.name_expr body ~name - | Is_expr body -> body - in - Is_expr (W.create_let_reusing_defining_expr var named body), r - in - let named_or_expr, r = collect_bindings vars env [] [] in - match named_or_expr with - | Is_named named -> named, r - | Is_expr expr -> Expr expr, r - -(* CR-soon mshinwell: tidy this up *) -let simplify_free_variable_named env var ~f : Flambda.named * R.t = - simplify_free_variables_named env [var] ~f:(fun env vars vars_approxs -> - match vars, vars_approxs with - | [var], [approx] -> f env var approx - | _ -> assert false) - -let simplify_named_using_approx r lam approx = - let lam, _summary, approx = A.simplify_named approx lam in - lam, R.set_approx r approx - -let simplify_using_approx_and_env env r original_lam approx = - let lam, summary, approx = - A.simplify_using_env approx ~is_present_in_env:(E.mem env) original_lam - in - let r = - let r = ret r approx in - match summary with - (* CR-soon mshinwell: Why is [r] not updated with the cost of adding the - new code? - mshinwell: similar to CR above *) - | Replaced_term -> R.map_benefit r (B.remove_code original_lam) - | Nothing_done -> r - in - lam, r - -let simplify_named_using_approx_and_env env r original_named approx = - let named, summary, approx = - A.simplify_named_using_env approx ~is_present_in_env:(E.mem env) - original_named - in - let r = - let r = ret r approx in - match summary with - | Replaced_term -> R.map_benefit r (B.remove_code_named original_named) - | Nothing_done -> r - in - named, r - -let simplify_const (const : Flambda.const) = - match const with - | Int i -> A.value_int i - | Char c -> A.value_char c - | Const_pointer i -> A.value_constptr i - -let approx_for_allocated_const (const : Allocated_const.t) = - match const with - | String s -> A.value_string (String.length s) None - | Immutable_string s -> A.value_string (String.length s) (Some s) - | Int32 i -> A.value_boxed_int Int32 i - | Int64 i -> A.value_boxed_int Int64 i - | Nativeint i -> A.value_boxed_int Nativeint i - | Float f -> A.value_float f - | Float_array a -> A.value_mutable_float_array ~size:(List.length a) - | Immutable_float_array a -> - A.value_immutable_float_array - (Array.map A.value_float (Array.of_list a)) - -type filtered_switch_branches = - | Must_be_taken of Flambda.t - | Can_be_taken of (int * Flambda.t) list - -(* Determine whether a given closure ID corresponds directly to a variable - (bound to a closure) in the given environment. This happens when the body - of a [let rec]-bound function refers to another in the same set of closures. - If we succeed in this process, we can change [Project_closure] - expressions into [Var] expressions, thus sharing closure projections. *) -let reference_recursive_function_directly env closure_id = - let closure_id = Closure_id.unwrap closure_id in - match E.find_opt env closure_id with - | None -> None - | Some approx -> Some (Flambda.Expr (Var closure_id), approx) - -(* Simplify an expression that takes a set of closures and projects an - individual closure from it. *) -let simplify_project_closure env r ~(project_closure : Flambda.project_closure) - : Flambda.named * R.t = - simplify_free_variable_named env project_closure.set_of_closures - ~f:(fun _env set_of_closures set_of_closures_approx -> - match A.check_approx_for_set_of_closures set_of_closures_approx with - | Wrong -> - Misc.fatal_errorf "Wrong approximation when projecting closure: %a" - Flambda.print_project_closure project_closure - | Unresolved value -> - (* A set of closures coming from another compilation unit, whose .cmx is - missing; as such, we cannot have rewritten the function and don't - need to do any freshening. *) - Project_closure { - set_of_closures; - closure_id = project_closure.closure_id; - }, ret r (A.value_unresolved value) - | Unknown -> - (* CR-soon mshinwell: see CR comment in e.g. simple_value_approx.ml - [check_approx_for_closure_allowing_unresolved] *) - Project_closure { - set_of_closures; - closure_id = project_closure.closure_id; - }, ret r (A.value_unknown Other) - | Unknown_because_of_unresolved_value value -> - Project_closure { - set_of_closures; - closure_id = project_closure.closure_id; - }, ret r (A.value_unknown (Unresolved_value value)) - | Ok (set_of_closures_var, value_set_of_closures) -> - let closure_id = - A.freshen_and_check_closure_id value_set_of_closures - project_closure.closure_id - in - let projecting_from = - match set_of_closures_var with - | None -> None - | Some set_of_closures_var -> - let projection : Projection.t = - Project_closure { - set_of_closures = set_of_closures_var; - closure_id; - } - in - match E.find_projection env ~projection with - | None -> None - | Some var -> Some (var, projection) - in - match projecting_from with - | Some (var, projection) -> - simplify_free_variable_named env var ~f:(fun _env var var_approx -> - let r = R.map_benefit r (B.remove_projection projection) in - Expr (Var var), ret r var_approx) - | None -> - match reference_recursive_function_directly env closure_id with - | Some (flam, approx) -> flam, ret r approx - | None -> - let set_of_closures_var = - match set_of_closures_var with - | Some set_of_closures_var' when E.mem env set_of_closures_var' -> - set_of_closures_var - | Some _ | None -> None - in - let approx = - A.value_closure ?set_of_closures_var value_set_of_closures - closure_id - in - Project_closure { set_of_closures; closure_id; }, ret r approx) - -(* Simplify an expression that, given one closure within some set of - closures, returns another closure (possibly the same one) within the - same set. *) -let simplify_move_within_set_of_closures env r - ~(move_within_set_of_closures : Flambda.move_within_set_of_closures) - : Flambda.named * R.t = - simplify_free_variable_named env move_within_set_of_closures.closure - ~f:(fun _env closure closure_approx -> - match A.check_approx_for_closure_allowing_unresolved closure_approx with - | Wrong -> - Misc.fatal_errorf "Wrong approximation when moving within set of \ - closures. Approximation: %a Term: %a" - A.print closure_approx - Flambda.print_move_within_set_of_closures move_within_set_of_closures - | Unresolved sym -> - Move_within_set_of_closures { - closure; - start_from = move_within_set_of_closures.start_from; - move_to = move_within_set_of_closures.move_to; - }, - ret r (A.value_unresolved sym) - | Unknown -> - Move_within_set_of_closures { - closure; - start_from = move_within_set_of_closures.start_from; - move_to = move_within_set_of_closures.move_to; - }, - ret r (A.value_unknown Other) - | Unknown_because_of_unresolved_value value -> - (* For example: a move upon a (move upon a closure whose .cmx file - is missing). *) - Move_within_set_of_closures { - closure; - start_from = move_within_set_of_closures.start_from; - move_to = move_within_set_of_closures.move_to; - }, - ret r (A.value_unknown (Unresolved_value value)) - | Ok (_value_closure, set_of_closures_var, set_of_closures_symbol, - value_set_of_closures) -> - let freshen = - (* CR-soon mshinwell: potentially misleading name---not freshening with - new names, but with previously fresh names *) - A.freshen_and_check_closure_id value_set_of_closures - in - let move_to = freshen move_within_set_of_closures.move_to in - let start_from = freshen move_within_set_of_closures.start_from in - let projection : Projection.t = - Move_within_set_of_closures { - closure; - start_from; - move_to; - } - in - match E.find_projection env ~projection with - | Some var -> - simplify_free_variable_named env var ~f:(fun _env var var_approx -> - let r = R.map_benefit r (B.remove_projection projection) in - Expr (Var var), ret r var_approx) - | None -> - match reference_recursive_function_directly env move_to with - | Some (flam, approx) -> flam, ret r approx - | None -> - if Closure_id.equal start_from move_to then - (* Moving from one closure to itself is a no-op. We can return an - [Var] since we already have a variable bound to the closure. *) - Expr (Var closure), ret r closure_approx - else - match set_of_closures_var with - | Some set_of_closures_var when E.mem env set_of_closures_var -> - (* A variable bound to the set of closures is in scope, - meaning we can rewrite the [Move_within_set_of_closures] to a - [Project_closure]. *) - let project_closure : Flambda.project_closure = - { set_of_closures = set_of_closures_var; - closure_id = move_to; - } - in - let approx = - A.value_closure ~set_of_closures_var value_set_of_closures - move_to - in - Project_closure project_closure, ret r approx - | Some _ | None -> - match set_of_closures_symbol with - | Some set_of_closures_symbol -> - let set_of_closures_var = - Variable.create Internal_variable_names.symbol - in - let project_closure : Flambda.project_closure = - { set_of_closures = set_of_closures_var; - closure_id = move_to; - } - in - let project_closure_var = - Variable.create Internal_variable_names.project_closure - in - let let1 = - Flambda.create_let project_closure_var - (Project_closure project_closure) - (Var project_closure_var) - in - let expr = - Flambda.create_let set_of_closures_var - (Symbol set_of_closures_symbol) - let1 - in - let approx = - A.value_closure ~set_of_closures_var ~set_of_closures_symbol - value_set_of_closures move_to - in - Expr expr, ret r approx - | None -> - (* The set of closures is not available in scope, and we - have no other information by which to simplify the move. *) - let move_within : Flambda.move_within_set_of_closures = - { closure; start_from; move_to; } - in - let approx = A.value_closure value_set_of_closures move_to in - Move_within_set_of_closures move_within, ret r approx) - -(* Transform an expression denoting an access to a variable bound in - a closure. Variables in the closure ([project_var.closure]) may - have been freshened since [expr] was constructed; as such, we - must ensure the same happens to [expr]. The renaming information is - contained within the approximation deduced from [closure] (as - such, that approximation *must* identify which closure it is). - - For instance in some imaginary syntax for flambda: - - [let f x = - let g y ~closure:{a} = a + y in - let closure = { a = x } in - g 12 ~closure] - - when [f] is traversed, [g] can be inlined, resulting in the - expression - - [let f z = - let g y ~closure:{a} = a + y in - let closure = { a = x } in - closure.a + 12] - - [closure.a] being a notation for: - - [Project_var{closure = closure; closure_id = g; var = a}] - - If [f] is inlined later, the resulting code will be - - [let x = ... in - let g' y' ~closure':{a'} = a' + y' in - let closure' = { a' = x } in - closure'.a' + 12] - - in particular the field [a] of the closure has been alpha renamed to [a']. - This information must be carried from the declaration to the use. - - If the function is declared outside of the alpha renamed part, there is - no need for renaming in the [Ffunction] and [Project_var]. - This is not usually the case, except when the closure declaration is a - symbol. - - What ensures that this information is available at [Project_var] - point is that those constructions can only be introduced by inlining, - which requires that same information. For this to still be valid, - other transformation must avoid transforming the information flow in - a way that the inline function can't propagate it. -*) -let rec simplify_project_var env r ~(project_var : Flambda.project_var) - : Flambda.named * R.t = - simplify_free_variable_named env project_var.closure - ~f:(fun _env closure approx -> - match A.check_approx_for_closure_allowing_unresolved approx with - | Ok (value_closure, _set_of_closures_var, _set_of_closures_symbol, - value_set_of_closures) -> - let module F = Freshening.Project_var in - let freshening = value_set_of_closures.freshening in - let var = F.apply_var_within_closure freshening project_var.var in - let closure_id = F.apply_closure_id freshening project_var.closure_id in - let closure_id_in_approx = value_closure.closure_id in - if not (Closure_id.equal closure_id closure_id_in_approx) then begin - Misc.fatal_errorf "When simplifying [Project_var], the closure ID %a \ - in the approximation of the set of closures did not match the \ - closure ID %a in the [Project_var] term. Approximation: %a@. \ - Var-within-closure being projected: %a@." - Closure_id.print closure_id_in_approx - Closure_id.print closure_id - Simple_value_approx.print approx - Var_within_closure.print var - end; - let projection : Projection.t = - Project_var { - closure; - closure_id; - var; - } - in - begin match E.find_projection env ~projection with - | Some var -> - simplify_free_variable_named env var ~f:(fun _env var var_approx -> - let r = R.map_benefit r (B.remove_projection projection) in - Expr (Var var), ret r var_approx) - | None -> - let approx = A.approx_for_bound_var value_set_of_closures var in - let expr : Flambda.named = Project_var { closure; closure_id; var; } in - let unwrapped = Var_within_closure.unwrap var in - let expr = - if E.mem env unwrapped then - Flambda.Expr (Var unwrapped) - else - expr - in - simplify_named_using_approx_and_env env r expr approx - end - | Unresolved symbol -> - (* This value comes from a symbol for which we couldn't find any - approximation, telling us that names within the closure couldn't - have been renamed. So we don't need to change the variable or - closure ID in the [Project_var] expression. *) - Project_var { project_var with closure }, - ret r (A.value_unresolved symbol) - | Unknown -> - Project_var { project_var with closure }, - ret r (A.value_unknown Other) - | Unknown_because_of_unresolved_value value -> - Project_var { project_var with closure }, - ret r (A.value_unknown (Unresolved_value value)) - | Wrong -> - (* We must have the correct approximation of the value to ensure - we take account of all freshenings. *) - Misc.fatal_errorf "[Project_var] from a value with wrong \ - approximation: %a@.closure=%a@.approx of closure=%a@." - Flambda.print_project_var project_var - Variable.print closure - Simple_value_approx.print approx) - -(* Transforms closure definitions by applying [loop] on the code of every - one of the set and on the expressions of the free variables. - If the substitution is activated, alpha renaming also occur on everything - defined by the set of closures: - * Variables bound by a closure of the set - * closure identifiers - * parameters - - The rewriting occurs in a clean environment without any of the variables - defined outside reachable. This helps increase robustness against - accidental, potentially unsound simplification of variable accesses by - [simplify_using_approx_and_env]. - - The rewriting occurs in an environment filled with: - * The approximation of the free variables - * An explicitly unknown approximation for function parameters, - except for those where it is known to be safe: those present in the - [specialised_args] set. - * An approximation for the closures in the set. It contains the code of - the functions before rewriting. - - The approximation of the currently defined closures is available to - allow marking recursives calls as direct and in some cases, allow - inlining of one closure from the set inside another one. For this to - be correct an alpha renaming is first applied on the expressions by - [apply_function_decls_and_free_vars]. - - For instance when rewriting the declaration - - [let rec f_1 x_1 = - let y_1 = x_1 + 1 in - g_1 y_1 - and g_1 z_1 = f_1 (f_1 z_1)] - - When rewriting this function, the first substitution will contain - some mapping: - { f_1 -> f_2; - g_1 -> g_2; - x_1 -> x_2; - z_1 -> z_2 } - - And the approximation for the closure will contain - - { f_2: - fun x_2 -> - let y_1 = x_2 + 1 in - g_2 y_1 - g_2: - fun z_2 -> f_2 (f_2 z_2) } - - Note that no substitution is applied to the let-bound variable [y_1]. - If [f_2] where to be inlined inside [g_2], we known that a new substitution - will be introduced in the current scope for [y_1] each time. - - - If the function where a recursive one coming from another compilation - unit, the code already went through [Flambdasym] that could have - replaced the function variable by the symbol identifying the function - (this occur if the function contains only constants in its closure). - To handle that case, we first replace those symbols by the original - variable. -*) -and simplify_set_of_closures original_env r - (set_of_closures : Flambda.set_of_closures) - : Flambda.set_of_closures * R.t * Freshening.Project_var.t = - let function_decls = - let module Backend = (val (E.backend original_env) : Backend_intf.S) in - (* CR-soon mshinwell: Does this affect - [reference_recursive_function_directly]? - mshinwell: This should be thought about as part of the wider issue of - references to functions via symbols or variables. *) - Freshening.rewrite_recursive_calls_with_symbols (E.freshening original_env) - set_of_closures.function_decls - ~make_closure_symbol:Backend.closure_symbol - in - let env = E.increase_closure_depth original_env in - let free_vars, specialised_args, function_decls, parameter_approximations, - internal_value_set_of_closures, set_of_closures_env = - Inline_and_simplify_aux.prepare_to_simplify_set_of_closures ~env - ~set_of_closures ~function_decls ~only_for_function_decl:None - ~freshen:true - in - let simplify_function fun_var (function_decl : Flambda.function_declaration) - (funs, used_params, r) - : Flambda.function_declaration Variable.Map.t * Variable.Set.t * R.t = - let closure_env = - Inline_and_simplify_aux.prepare_to_simplify_closure ~function_decl - ~free_vars ~specialised_args ~parameter_approximations - ~set_of_closures_env - in - let body, r = - E.enter_closure closure_env ~closure_id:(Closure_id.wrap fun_var) - ~inline_inside: - (Inlining_decision.should_inline_inside_declaration function_decl) - ~dbg:function_decl.dbg - ~f:(fun body_env -> - assert (E.inside_set_of_closures_declaration - function_decls.set_of_closures_origin body_env); - simplify body_env r function_decl.body) - in - let function_decl = - Flambda.create_function_declaration ~params:function_decl.params - ~body ~stub:function_decl.stub ~dbg:function_decl.dbg - ~inline:function_decl.inline ~specialise:function_decl.specialise - ~is_a_functor:function_decl.is_a_functor - ~closure_origin:function_decl.closure_origin - in - let used_params' = Flambda.used_params function_decl in - Variable.Map.add fun_var function_decl funs, - Variable.Set.union used_params used_params', r - in - let funs, _used_params, r = - Variable.Map.fold simplify_function function_decls.funs - (Variable.Map.empty, Variable.Set.empty, r) - in - let function_decls = - Flambda.update_function_declarations function_decls ~funs - in - let invariant_params = - lazy (Invariant_params.invariant_params_in_recursion function_decls - ~backend:(E.backend env)) - in - let recursive = - lazy (Find_recursive_functions.in_function_declarations function_decls - ~backend:(E.backend env)) - in - let keep_body = - Inline_and_simplify_aux.keep_body_check - ~is_classic_mode:function_decls.is_classic_mode ~recursive - in - let function_decls_approx = - A.function_declarations_approx ~keep_body function_decls - in - let value_set_of_closures = - A.create_value_set_of_closures - ~function_decls:function_decls_approx - ~bound_vars:internal_value_set_of_closures.bound_vars - ~invariant_params - ~recursive - ~specialised_args:internal_value_set_of_closures.specialised_args - ~free_vars:internal_value_set_of_closures.free_vars - ~freshening:internal_value_set_of_closures.freshening - ~direct_call_surrogates: - internal_value_set_of_closures.direct_call_surrogates - in - let direct_call_surrogates = - Closure_id.Map.fold (fun existing surrogate surrogates -> - Variable.Map.add (Closure_id.unwrap existing) - (Closure_id.unwrap surrogate) surrogates) - internal_value_set_of_closures.direct_call_surrogates - Variable.Map.empty - in - let set_of_closures = - Flambda.create_set_of_closures ~function_decls - ~free_vars:(Variable.Map.map fst free_vars) - ~specialised_args - ~direct_call_surrogates - in - let r = ret r (A.value_set_of_closures value_set_of_closures) in - set_of_closures, r, value_set_of_closures.freshening - -and simplify_apply env r ~(apply : Flambda.apply) : Flambda.t * R.t = - let { - Flambda. func = lhs_of_application; args; kind = _; dbg; - inline = inline_requested; specialise = specialise_requested; - } = apply in - let dbg = E.add_inlined_debuginfo env ~dbg in - simplify_free_variable env lhs_of_application - ~f:(fun env lhs_of_application lhs_of_application_approx -> - simplify_free_variables env args ~f:(fun env args args_approxs -> - (* By using the approximation of the left-hand side of the - application, attempt to determine which function is being applied - (even if the application is currently [Indirect]). If - successful---in which case we then have a direct - application---consider inlining. *) - match A.check_approx_for_closure lhs_of_application_approx with - | Ok (value_closure, set_of_closures_var, - set_of_closures_symbol, value_set_of_closures) -> - let lhs_of_application, closure_id_being_applied, - value_set_of_closures, env, wrap = - let closure_id_being_applied = value_closure.closure_id in - (* If the call site is a direct call to a function that has a - "direct call surrogate" (see inline_and_simplify_aux.mli), - repoint the call to the surrogate. *) - let surrogates = value_set_of_closures.direct_call_surrogates in - match Closure_id.Map.find closure_id_being_applied surrogates with - | exception Not_found -> - lhs_of_application, closure_id_being_applied, - value_set_of_closures, env, (fun expr -> expr) - | surrogate -> - let rec find_transitively surrogate = - match Closure_id.Map.find surrogate surrogates with - | exception Not_found -> surrogate - | surrogate -> find_transitively surrogate - in - let surrogate = find_transitively surrogate in - let surrogate_var = Variable.rename lhs_of_application in - let move_to_surrogate : Projection.move_within_set_of_closures = - { closure = lhs_of_application; - start_from = closure_id_being_applied; - move_to = surrogate; - } - in - let approx_for_surrogate = - A.value_closure ~closure_var:surrogate_var - ?set_of_closures_var ?set_of_closures_symbol - value_set_of_closures surrogate - in - let env = E.add env surrogate_var approx_for_surrogate in - let wrap expr = - Flambda.create_let surrogate_var - (Move_within_set_of_closures move_to_surrogate) - expr - in - surrogate_var, surrogate, value_set_of_closures, env, wrap - in - let function_decls = value_set_of_closures.function_decls in - let function_decl = - try - Variable.Map.find - (Closure_id.unwrap closure_id_being_applied) - function_decls.funs - with - | Not_found -> - Misc.fatal_errorf "When handling application expression, \ - approximation references non-existent closure %a@." - Closure_id.print closure_id_being_applied - in - let r = - match apply.kind with - | Indirect -> - R.map_benefit r Inlining_cost.Benefit.direct_call_of_indirect - | Direct _ -> r - in - let nargs = List.length args in - let arity = A.function_arity function_decl in - let result, r = - if nargs = arity then - simplify_full_application env r ~function_decls - ~lhs_of_application ~closure_id_being_applied ~function_decl - ~value_set_of_closures ~args ~args_approxs ~dbg - ~inline_requested ~specialise_requested - else if nargs > arity then - simplify_over_application env r ~args ~args_approxs - ~function_decls ~lhs_of_application ~closure_id_being_applied - ~function_decl ~value_set_of_closures ~dbg ~inline_requested - ~specialise_requested - else if nargs > 0 && nargs < arity then - simplify_partial_application env r ~lhs_of_application - ~closure_id_being_applied ~function_decl ~args ~dbg - ~inline_requested ~specialise_requested - else - Misc.fatal_errorf "Function with arity %d when simplifying \ - application expression: %a" - arity Flambda.print (Flambda.Apply apply) - in - wrap result, r - | Wrong -> (* Insufficient approximation information to simplify. *) - Apply ({ func = lhs_of_application; args; kind = Indirect; dbg; - inline = inline_requested; specialise = specialise_requested; }), - ret r (A.value_unknown Other))) - -and simplify_full_application env r ~function_decls ~lhs_of_application - ~closure_id_being_applied ~function_decl ~value_set_of_closures ~args - ~args_approxs ~dbg ~inline_requested ~specialise_requested = - Inlining_decision.for_call_site ~env ~r ~function_decls - ~lhs_of_application ~closure_id_being_applied ~function_decl - ~value_set_of_closures ~args ~args_approxs ~dbg ~simplify - ~inline_requested ~specialise_requested - -and simplify_partial_application env r ~lhs_of_application - ~closure_id_being_applied ~function_decl ~args ~dbg - ~inline_requested ~specialise_requested = - let arity = A.function_arity function_decl in - assert (arity > List.length args); - (* For simplicity, we disallow [@inline] attributes on partial - applications. The user may always write an explicit wrapper instead - with such an attribute. *) - (* CR-someday mshinwell: Pierre noted that we might like a function to be - inlined when applied to its first set of arguments, e.g. for some kind - of type class like thing. *) - begin match (inline_requested : Lambda.inline_attribute) with - | Always_inline | Never_inline -> - Location.prerr_warning (Debuginfo.to_location dbg) - (Warnings.Inlining_impossible "[@inlined] attributes may not be used \ - on partial applications") - | Unroll _ -> - Location.prerr_warning (Debuginfo.to_location dbg) - (Warnings.Inlining_impossible "[@unroll] attributes may not be used \ - on partial applications") - | Default_inline -> () - end; - begin match (specialise_requested : Lambda.specialise_attribute) with - | Always_specialise | Never_specialise -> - Location.prerr_warning (Debuginfo.to_location dbg) - (Warnings.Inlining_impossible "[@specialised] attributes may not be used \ - on partial applications") - | Default_specialise -> () - end; - let freshened_params = - List.map (fun p -> Parameter.rename p) function_decl.A.params - in - let applied_args, remaining_args = - Misc.Stdlib.List.map2_prefix (fun arg id' -> id', arg) - args freshened_params - in - let wrapper_accepting_remaining_args = - let body : Flambda.t = - Apply { - func = lhs_of_application; - args = Parameter.List.vars freshened_params; - kind = Direct closure_id_being_applied; - dbg; - inline = Default_inline; - specialise = Default_specialise; - } - in - let closure_variable = - Variable.rename - (Closure_id.unwrap closure_id_being_applied) - in - Flambda_utils.make_closure_declaration ~id:closure_variable - ~is_classic_mode:false - ~body - ~params:remaining_args - ~stub:true - in - let with_known_args = - Flambda_utils.bind - ~bindings:(List.map (fun (param, arg) -> - Parameter.var param, Flambda.Expr (Var arg)) applied_args) - ~body:wrapper_accepting_remaining_args - in - simplify env r with_known_args - -and simplify_over_application env r ~args ~args_approxs ~function_decls - ~lhs_of_application ~closure_id_being_applied ~function_decl - ~value_set_of_closures ~dbg ~inline_requested ~specialise_requested = - let arity = A.function_arity function_decl in - assert (arity < List.length args); - assert (List.length args = List.length args_approxs); - let full_app_args, remaining_args = - Misc.Stdlib.List.split_at arity args - in - let full_app_approxs, _ = - Misc.Stdlib.List.split_at arity args_approxs - in - let expr, r = - simplify_full_application env r ~function_decls ~lhs_of_application - ~closure_id_being_applied ~function_decl ~value_set_of_closures - ~args:full_app_args ~args_approxs:full_app_approxs ~dbg - ~inline_requested ~specialise_requested - in - let func_var = Variable.create Internal_variable_names.full_apply in - let expr : Flambda.t = - Flambda.create_let func_var (Expr expr) - (Apply { func = func_var; args = remaining_args; kind = Indirect; dbg; - inline = inline_requested; specialise = specialise_requested; }) - in - let expr = Lift_code.lift_lets_expr expr ~toplevel:true in - simplify (E.set_never_inline env) r expr - -and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t = - match tree with - | Symbol sym -> - (* New Symbol construction could have been introduced during - transformation (by simplify_named_using_approx_and_env). - When this comes from another compilation unit, we must load it. *) - let approx = E.find_or_load_symbol env sym in - simplify_named_using_approx r tree approx - | Const cst -> tree, ret r (simplify_const cst) - | Allocated_const cst -> tree, ret r (approx_for_allocated_const cst) - | Read_mutable mut_var -> - (* See comment on the [Assign] case. *) - let mut_var = - Freshening.apply_mutable_variable (E.freshening env) mut_var - in - Read_mutable mut_var, ret r (A.value_unknown Other) - | Read_symbol_field (symbol, field_index) -> - let approx = E.find_or_load_symbol env symbol in - begin match A.get_field approx ~field_index with - (* CR-someday mshinwell: Think about [Unreachable] vs. [Value_bottom]. *) - | Unreachable -> (Flambda.Expr Proved_unreachable), r - | Ok approx -> - let approx = A.augment_with_symbol_field approx symbol field_index in - simplify_named_using_approx_and_env env r tree approx - end - | Set_of_closures set_of_closures -> begin - let backend = E.backend env in - let set_of_closures, r, first_freshening = - simplify_set_of_closures env r set_of_closures - in - let simplify env r expr ~pass_name : Flambda.named * R.t = - (* If simplifying a set of closures more than once during any given round - of simplification, the [Freshening.Project_var] substitutions arising - from each call to [simplify_set_of_closures] must be composed. - Note that this function only composes with [first_freshening] owing - to the structure of the code below (this new [simplify] is always - in tail position). *) - (* CR-someday mshinwell: It was mooted that maybe we could try - structurally-typed closures (i.e. where we would never rename the - closure elements), or something else, to try to remove - the "closure freshening" thing in the approximation which is hard - to deal with. *) - let expr, r = simplify (E.set_never_inline env) r expr in - let approx = R.approx r in - let value_set_of_closures = - match A.strict_check_approx_for_set_of_closures approx with - | Wrong -> - Misc.fatal_errorf "Unexpected approximation returned from \ - simplification of [%s] result: %a" - pass_name A.print approx - | Ok (_var, value_set_of_closures) -> - let freshening = - Freshening.Project_var.compose ~earlier:first_freshening - ~later:value_set_of_closures.freshening - in - A.update_freshening_of_value_set_of_closures value_set_of_closures - ~freshening - in - Expr expr, (ret r (A.value_set_of_closures value_set_of_closures)) - in - (* This does the actual substitutions of specialised args introduced - by [Unbox_closures] for free variables. (Apart from simplifying - the [Unbox_closures] output, this also prevents applying - [Unbox_closures] over and over.) *) - let set_of_closures = - let ppf_dump = Inline_and_simplify_aux.Env.ppf_dump env in - match Remove_free_vars_equal_to_args.run ~ppf_dump set_of_closures with - | None -> set_of_closures - | Some set_of_closures -> set_of_closures - in - (* Do [Unbox_closures] next to try to decide which things are - free variables and which things are specialised arguments before - unboxing them. *) - match - Unbox_closures.rewrite_set_of_closures ~env - ~duplicate_function ~set_of_closures - with - | Some (expr, benefit) -> - let r = R.add_benefit r benefit in - simplify env r expr ~pass_name:"Unbox_closures" - | None -> - match Unbox_free_vars_of_closures.run ~env ~set_of_closures with - | Some (expr, benefit) -> - let r = R.add_benefit r benefit in - simplify env r expr ~pass_name:"Unbox_free_vars_of_closures" - | None -> - (* CR-soon mshinwell: should maybe add one allocation for the stub *) - match - Unbox_specialised_args.rewrite_set_of_closures ~env - ~duplicate_function ~set_of_closures - with - | Some (expr, benefit) -> - let r = R.add_benefit r benefit in - simplify env r expr ~pass_name:"Unbox_specialised_args" - | None -> - match - Remove_unused_arguments. - separate_unused_arguments_in_set_of_closures - set_of_closures ~backend - with - | Some set_of_closures -> - let expr = - Flambda_utils.name_expr (Set_of_closures set_of_closures) - ~name:Internal_variable_names.remove_unused_arguments - in - simplify env r expr ~pass_name:"Remove_unused_arguments" - | None -> - Set_of_closures set_of_closures, r - end - | Project_closure project_closure -> - simplify_project_closure env r ~project_closure - | Project_var project_var -> simplify_project_var env r ~project_var - | Move_within_set_of_closures move_within_set_of_closures -> - simplify_move_within_set_of_closures env r ~move_within_set_of_closures - | Prim (prim, args, dbg) -> - let dbg = E.add_inlined_debuginfo env ~dbg in - simplify_free_variables_named env args ~f:(fun env args args_approxs -> - let tree = Flambda.Prim (prim, args, dbg) in - begin match prim, args, args_approxs with - | Pgetglobal _, _, _ -> - Misc.fatal_error "Pgetglobal is forbidden in Inline_and_simplify" - (* CR-someday mshinwell: Optimise [Pfield_computed]. *) - | Pfield field_index, [arg], [arg_approx] -> - let projection : Projection.t = Field (field_index, arg) in - begin match E.find_projection env ~projection with - | Some var -> - simplify_free_variable_named env var ~f:(fun _env var var_approx -> - let r = R.map_benefit r (B.remove_projection projection) in - Expr (Var var), ret r var_approx) - | None -> - begin match A.get_field arg_approx ~field_index with - | Unreachable -> (Flambda.Expr Proved_unreachable, r) - | Ok approx -> - let tree, approx = - match arg_approx.symbol with - (* If the [Pfield] is projecting directly from a symbol, rewrite - the expression to [Read_symbol_field]. *) - | Some (symbol, None) -> - let approx = - A.augment_with_symbol_field approx symbol field_index - in - Flambda.Read_symbol_field (symbol, field_index), approx - | None | Some (_, Some _ ) -> - (* This [Pfield] is either not projecting from a symbol at all, - or it is the projection of a projection from a symbol. *) - let approx' = E.really_import_approx env approx in - tree, approx' - in - simplify_named_using_approx_and_env env r tree approx - end - end - | Pfield _, _, _ -> Misc.fatal_error "Pfield arity error" - | (Parraysetu kind | Parraysets kind), - [_block; _field; _value], - [block_approx; _field_approx; value_approx] -> - if A.warn_on_mutation block_approx then begin - Location.prerr_warning (Debuginfo.to_location dbg) - Warnings.Assignment_to_non_mutable_value - end; - let kind = - let check () = - match kind with - | Pfloatarray | Pgenarray -> () - | Paddrarray | Pintarray -> - (* CR pchambart: Do a proper warning here *) - Misc.fatal_errorf "Assignment of a float to a specialised \ - non-float array: %a" - Flambda.print_named tree - in - match A.descr block_approx, A.descr value_approx with - | (Value_float_array _, _) -> check (); Lambda.Pfloatarray - | (_, Value_float _) when Config.flat_float_array -> - check (); Lambda.Pfloatarray - (* CR pchambart: This should be accounted by the benefit *) - | _ -> - kind - in - let prim : Lambda.primitive = match prim with - | Parraysetu _ -> Parraysetu kind - | Parraysets _ -> Parraysets kind - | _ -> assert false - in - Prim (prim, args, dbg), ret r (A.value_unknown Other) - | Psetfield _, _block::_, block_approx::_ -> - if A.warn_on_mutation block_approx then begin - Location.prerr_warning (Debuginfo.to_location dbg) - Warnings.Assignment_to_non_mutable_value - end; - tree, ret r (A.value_unknown Other) - | (Psetfield _ | Parraysetu _ | Parraysets _), _, _ -> - Misc.fatal_error "Psetfield / Parraysetu / Parraysets arity error" - | (Psequand | Psequor), _, _ -> - Misc.fatal_error "Psequand and Psequor must be expanded (see handling \ - in closure_conversion.ml)" - | p, args, args_approxs -> - let expr, approx, benefit = - let module Backend = (val (E.backend env) : Backend_intf.S) in - Simplify_primitives.primitive p (args, args_approxs) tree dbg - ~size_int:Backend.size_int ~big_endian:Backend.big_endian - in - let r = R.map_benefit r (B.(+) benefit) in - let approx = - match p with - | Popaque -> A.value_unknown Other - | _ -> approx - in - expr, ret r approx - end) - | Expr expr -> - let expr, r = simplify env r expr in - Expr expr, r - -and simplify env r (tree : Flambda.t) : Flambda.t * R.t = - match tree with - | Var var -> - let var = Freshening.apply_variable (E.freshening env) var in - (* If from the approximations we can simplify [var], then we will be - forced to insert [let]-expressions (done using [name_expr], in - [Simple_value_approx]) to bind a [named]. This has an important - consequence: it brings bindings of constants closer to their use - points. *) - simplify_using_approx_and_env env r (Var var) (E.find_exn env var) - | Apply apply -> - simplify_apply env r ~apply - | Let _ -> - let for_defining_expr (env, r) var defining_expr = - let defining_expr, r = simplify_named env r defining_expr in - let var, sb = Freshening.add_variable (E.freshening env) var in - let env = E.set_freshening env sb in - let env = E.add env var (R.approx r) in - (env, r), var, defining_expr - in - let for_last_body (env, r) body = - simplify env r body - in - let filter_defining_expr r var defining_expr free_vars_of_body = - if Variable.Set.mem var free_vars_of_body then - r, var, Some defining_expr - else if Effect_analysis.no_effects_named defining_expr then - let r = R.map_benefit r (B.remove_code_named defining_expr) in - r, var, None - else - r, var, Some defining_expr - in - Flambda.fold_lets_option tree - ~init:(env, r) - ~for_defining_expr - ~for_last_body - ~filter_defining_expr - | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> - (* CR-someday mshinwell: add the dead let elimination, as above. *) - simplify_free_variable env var ~f:(fun env var _var_approx -> - let mut_var, sb = - Freshening.add_mutable_variable (E.freshening env) mut_var - in - let env = E.set_freshening env sb in - let body, r = - simplify (E.add_mutable env mut_var (A.value_unknown Other)) r body - in - Flambda.Let_mutable - { var = mut_var; - initial_value = var; - body; - contents_kind }, - r) - | Let_rec (defs, body) -> - let defs, sb = Freshening.add_variables (E.freshening env) defs in - let env = E.set_freshening env sb in - let def_env = - List.fold_left (fun env_acc (id, _lam) -> - E.add env_acc id (A.value_unknown Other)) - env defs - in - let defs, body_env, r = - List.fold_right (fun (id, lam) (defs, env_acc, r) -> - let lam, r = simplify_named def_env r lam in - let defs = (id, lam) :: defs in - let env_acc = E.add env_acc id (R.approx r) in - defs, env_acc, r) - defs ([], env, r) - in - let body, r = simplify body_env r body in - Let_rec (defs, body), r - | Static_raise (i, args) -> - let i = Freshening.apply_static_exception (E.freshening env) i in - simplify_free_variables env args ~f:(fun _env args _args_approxs -> - let r = R.use_static_exception r i in - Static_raise (i, args), ret r A.value_bottom) - | Static_catch (i, vars, body, handler) -> - begin - match body with - | Let { var; defining_expr = def; body; _ } - when not (Flambda_utils.might_raise_static_exn def i) -> - simplify env r - (Flambda.create_let var def (Static_catch (i, vars, body, handler))) - | _ -> - let i, sb = Freshening.add_static_exception (E.freshening env) i in - let env = E.set_freshening env sb in - let body, r = simplify env r body in - (* CR-soon mshinwell: for robustness, R.used_static_exceptions should - maybe be removed. *) - if not (Static_exception.Set.mem i (R.used_static_exceptions r)) then - (* If the static exception is not used, we can drop the declaration *) - body, r - else begin - match (body : Flambda.t) with - | Static_raise (j, args) -> - assert (Static_exception.equal i j); - let handler = - List.fold_left2 (fun body var arg -> - Flambda.create_let var (Expr (Var arg)) body) - handler vars args - in - let r = R.exit_scope_catch r i in - simplify env r handler - | _ -> - let vars, sb = Freshening.add_variables' (E.freshening env) vars in - let approx = R.approx r in - let env = - List.fold_left (fun env id -> - E.add env id (A.value_unknown Other)) - (E.set_freshening env sb) vars - in - let env = E.inside_branch env in - let handler, r = simplify env r handler in - let r = R.exit_scope_catch r i in - Static_catch (i, vars, body, handler), - R.meet_approx r env approx - end - end - | Try_with (body, id, handler) -> - let body, r = simplify env r body in - let id, sb = Freshening.add_variable (E.freshening env) id in - let env = E.add (E.set_freshening env sb) id (A.value_unknown Other) in - let env = E.inside_branch env in - let handler, r = simplify env r handler in - Try_with (body, id, handler), ret r (A.value_unknown Other) - | If_then_else (arg, ifso, ifnot) -> - (* When arg is the constant false or true (or something considered - as true), we can drop the if and replace it by a sequence. - if arg is not effectful we can also drop it. *) - simplify_free_variable env arg ~f:(fun env arg arg_approx -> - begin match arg_approx.descr with - | Value_constptr 0 | Value_int 0 -> (* Constant [false]: keep [ifnot] *) - let ifnot, r = simplify env r ifnot in - ifnot, R.map_benefit r B.remove_branch - | Value_constptr _ | Value_int _ - | Value_block _ -> (* Constant [true]: keep [ifso] *) - let ifso, r = simplify env r ifso in - ifso, R.map_benefit r B.remove_branch - | _ -> - let env = E.inside_branch env in - let ifso, r = simplify env r ifso in - let ifso_approx = R.approx r in - let ifnot, r = simplify env r ifnot in - If_then_else (arg, ifso, ifnot), - R.meet_approx r env ifso_approx - end) - | While (cond, body) -> - let cond, r = simplify env r cond in - let body, r = simplify env r body in - While (cond, body), ret r (A.value_unknown Other) - | Send { kind; meth; obj; args; dbg; } -> - let dbg = E.add_inlined_debuginfo env ~dbg in - simplify_free_variable env meth ~f:(fun env meth _meth_approx -> - simplify_free_variable env obj ~f:(fun env obj _obj_approx -> - simplify_free_variables env args ~f:(fun _env args _args_approx -> - Send { kind; meth; obj; args; dbg; }, - ret r (A.value_unknown Other)))) - | For { bound_var; from_value; to_value; direction; body; } -> - simplify_free_variable env from_value ~f:(fun env from_value _approx -> - simplify_free_variable env to_value ~f:(fun env to_value _approx -> - let bound_var, sb = - Freshening.add_variable (E.freshening env) bound_var - in - let env = - E.add (E.set_freshening env sb) bound_var - (A.value_unknown Other) - in - let body, r = simplify env r body in - For { bound_var; from_value; to_value; direction; body; }, - ret r (A.value_unknown Other))) - | Assign { being_assigned; new_value; } -> - (* No need to use something like [simplify_free_variable]: the - approximation of [being_assigned] is always unknown. *) - let being_assigned = - Freshening.apply_mutable_variable (E.freshening env) being_assigned - in - simplify_free_variable env new_value ~f:(fun _env new_value _approx -> - Assign { being_assigned; new_value; }, ret r (A.value_unknown Other)) - | Switch (arg, sw) -> - (* When [arg] is known to be a variable whose approximation is that of a - block with a fixed tag or a fixed integer, we can eliminate the - [Switch]. (This should also make the [Let] that binds [arg] redundant, - meaning that it too can be eliminated.) *) - simplify_free_variable env arg ~f:(fun env arg arg_approx -> - let rec filter_branches filter branches compatible_branches = - match branches with - | [] -> Can_be_taken compatible_branches - | (c, lam) as branch :: branches -> - match filter arg_approx c with - | A.Cannot_be_taken -> - filter_branches filter branches compatible_branches - | A.Can_be_taken -> - filter_branches filter branches (branch :: compatible_branches) - | A.Must_be_taken -> - Must_be_taken lam - in - let filtered_consts = - filter_branches A.potentially_taken_const_switch_branch sw.consts [] - in - let filtered_blocks = - filter_branches A.potentially_taken_block_switch_branch sw.blocks [] - in - begin match filtered_consts, filtered_blocks with - | Must_be_taken _, Must_be_taken _ -> - assert false - | Must_be_taken branch, _ - | _, Must_be_taken branch -> - let lam, r = simplify env r branch in - lam, R.map_benefit r B.remove_branch - | Can_be_taken consts, Can_be_taken blocks -> - match consts, blocks, sw.failaction with - | [], [], None -> - (* If the switch is applied to a statically-known value that does not - match any case: - * if there is a default action take that case; - * otherwise this is something that is guaranteed not to - be reachable by the type checker. For example: - [type 'a t = Int : int -> int t | Float : float -> float t - match Int 1 with - | Int _ -> ... - | Float f as v -> - match v with <-- This match is unreachable - | Float f -> ...] - *) - Proved_unreachable, ret r A.value_bottom - | [_, branch], [], None - | [], [_, branch], None - | [], [], Some branch -> - let lam, r = simplify env r branch in - lam, R.map_benefit r B.remove_branch - | _ -> - let env = E.inside_branch env in - let f (i, v) (acc, r) = - let approx = R.approx r in - let lam, r = simplify env r v in - (i, lam)::acc, - R.meet_approx r env approx - in - let r = R.set_approx r A.value_bottom in - let consts, r = List.fold_right f consts ([], r) in - let blocks, r = List.fold_right f blocks ([], r) in - let failaction, r = - match sw.failaction with - | None -> None, r - | Some l -> - let approx = R.approx r in - let l, r = simplify env r l in - Some l, - R.meet_approx r env approx - in - let sw = { sw with failaction; consts; blocks; } in - Switch (arg, sw), r - end) - | String_switch (arg, sw, def) -> - simplify_free_variable env arg ~f:(fun env arg arg_approx -> - match A.check_approx_for_string arg_approx with - | None -> - let env = E.inside_branch env in - let sw, r = - List.fold_right (fun (str, lam) (sw, r) -> - let approx = R.approx r in - let lam, r = simplify env r lam in - (str, lam)::sw, - R.meet_approx r env approx) - sw - ([], r) - in - let def, r = - match def with - | None -> def, r - | Some def -> - let approx = R.approx r in - let def, r = simplify env r def in - Some def, - R.meet_approx r env approx - in - String_switch (arg, sw, def), ret r (A.value_unknown Other) - | Some arg_string -> - let branch = - match List.find (fun (str, _) -> String.equal str arg_string) sw with - | (_, branch) -> branch - | exception Not_found -> - match def with - | None -> - Flambda.Proved_unreachable - | Some def -> - def - in - let branch, r = simplify env r branch in - branch, R.map_benefit r B.remove_branch) - | Proved_unreachable -> tree, ret r A.value_bottom - -and simplify_list env r l = - match l with - | [] -> [], [], r - | h::t -> - let t', approxs, r = simplify_list env r t in - let h', r = simplify env r h in - let approxs = (R.approx r) :: approxs in - if t' == t && h' == h - then l, approxs, r - else h' :: t', approxs, r - -and duplicate_function ~env ~(set_of_closures : Flambda.set_of_closures) - ~fun_var ~new_fun_var = - let function_decl = - match Variable.Map.find fun_var set_of_closures.function_decls.funs with - | exception Not_found -> - Misc.fatal_errorf "duplicate_function: cannot find function %a" - Variable.print fun_var - | function_decl -> function_decl - in - let env = E.activate_freshening (E.set_never_inline env) in - let free_vars, specialised_args, function_decls, parameter_approximations, - _internal_value_set_of_closures, set_of_closures_env = - Inline_and_simplify_aux.prepare_to_simplify_set_of_closures ~env - ~set_of_closures ~function_decls:set_of_closures.function_decls - ~freshen:false ~only_for_function_decl:(Some function_decl) - in - let function_decl = - match Variable.Map.find fun_var function_decls.funs with - | exception Not_found -> - Misc.fatal_errorf "duplicate_function: cannot find function %a (2)" - Variable.print fun_var - | function_decl -> function_decl - in - let closure_env = - Inline_and_simplify_aux.prepare_to_simplify_closure ~function_decl - ~free_vars ~specialised_args ~parameter_approximations - ~set_of_closures_env - in - let body, _r = - E.enter_closure closure_env - ~closure_id:(Closure_id.wrap fun_var) - ~inline_inside:false - ~dbg:function_decl.dbg - ~f:(fun body_env -> - assert (E.inside_set_of_closures_declaration - function_decls.set_of_closures_origin body_env); - simplify body_env (R.create ()) function_decl.body) - in - let function_decl = - Flambda.create_function_declaration ~params:function_decl.params - ~body ~stub:function_decl.stub ~dbg:function_decl.dbg - ~inline:function_decl.inline ~specialise:function_decl.specialise - ~is_a_functor:function_decl.is_a_functor - ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var)) - in - function_decl, specialised_args - -let constant_defining_value_approx - env - (constant_defining_value:Flambda.constant_defining_value) = - match constant_defining_value with - | Allocated_const const -> - approx_for_allocated_const const - | Block (tag, fields) -> - let fields = - List.map - (function - | Flambda.Symbol sym -> begin - match E.find_symbol_opt env sym with - | Some approx -> approx - | None -> A.value_unresolved (Symbol sym) - end - | Flambda.Const cst -> simplify_const cst) - fields - in - A.value_block tag (Array.of_list fields) - | Set_of_closures { function_decls; free_vars; specialised_args } -> - (* At toplevel, there is no freshening currently happening (this - cannot be the body of a currently inlined function), so we can - keep the original set_of_closures in the approximation. *) - assert(Freshening.is_empty (E.freshening env)); - assert(Variable.Map.is_empty free_vars); - assert(Variable.Map.is_empty specialised_args); - let invariant_params = - lazy (Invariant_params.invariant_params_in_recursion function_decls - ~backend:(E.backend env)) - in - let recursive = - lazy (Find_recursive_functions.in_function_declarations function_decls - ~backend:(E.backend env)) - in - let value_set_of_closures = - let keep_body = - Inline_and_simplify_aux.keep_body_check - ~is_classic_mode:function_decls.is_classic_mode ~recursive - in - let function_decls = - A.function_declarations_approx ~keep_body function_decls - in - A.create_value_set_of_closures ~function_decls - ~bound_vars:Var_within_closure.Map.empty - ~invariant_params - ~recursive - ~specialised_args:Variable.Map.empty - ~free_vars:Variable.Map.empty - ~freshening:Freshening.Project_var.empty - ~direct_call_surrogates:Closure_id.Map.empty - in - A.value_set_of_closures value_set_of_closures - | Project_closure (set_of_closures_symbol, closure_id) -> begin - match E.find_symbol_opt env set_of_closures_symbol with - | None -> - A.value_unresolved (Symbol set_of_closures_symbol) - | Some set_of_closures_approx -> - let checked_approx = - A.check_approx_for_set_of_closures set_of_closures_approx - in - match checked_approx with - | Ok (_, value_set_of_closures) -> - let closure_id = - A.freshen_and_check_closure_id value_set_of_closures closure_id - in - A.value_closure value_set_of_closures closure_id - | Unresolved sym -> A.value_unresolved sym - | Unknown -> A.value_unknown Other - | Unknown_because_of_unresolved_value value -> - A.value_unknown (Unresolved_value value) - | Wrong -> - Misc.fatal_errorf "Wrong approximation for [Project_closure] \ - when being used as a [constant_defining_value]: %a" - Flambda.print_constant_defining_value constant_defining_value - end - -(* See documentation on [Let_rec_symbol] in flambda.mli. *) -let define_let_rec_symbol_approx orig_env defs = - (* First declare an empty version of the symbols *) - let init_env = - List.fold_left (fun building_env (symbol, _) -> - E.add_symbol building_env symbol (A.value_unresolved (Symbol symbol))) - orig_env defs - in - let rec loop times lookup_env = - if times <= 0 then - lookup_env - else - let env = - List.fold_left (fun building_env (symbol, constant_defining_value) -> - let approx = - constant_defining_value_approx lookup_env constant_defining_value - in - let approx = A.augment_with_symbol approx symbol in - E.add_symbol building_env symbol approx) - orig_env defs - in - loop (times-1) env - in - loop 2 init_env - -let simplify_constant_defining_value - env r symbol - (constant_defining_value:Flambda.constant_defining_value) = - let r, constant_defining_value, approx = - match constant_defining_value with - (* No simplifications are possible for [Allocated_const] or [Block]. *) - | Allocated_const const -> - r, constant_defining_value, approx_for_allocated_const const - | Block (tag, fields) -> - let fields = List.map - (function - | Flambda.Symbol sym -> E.find_symbol_exn env sym - | Flambda.Const cst -> simplify_const cst) - fields - in - r, constant_defining_value, A.value_block tag (Array.of_list fields) - | Set_of_closures set_of_closures -> - if Variable.Map.cardinal set_of_closures.free_vars <> 0 then begin - Misc.fatal_errorf "Set of closures bound by [Let_symbol] is not \ - closed: %a" - Flambda.print_set_of_closures set_of_closures - end; - let set_of_closures, r, _freshening = - simplify_set_of_closures env r set_of_closures - in - r, ((Set_of_closures set_of_closures) : Flambda.constant_defining_value), - R.approx r - | Project_closure (set_of_closures_symbol, closure_id) -> - (* No simplifications are necessary here. *) - let set_of_closures_approx = - E.find_symbol_exn env set_of_closures_symbol - in - let closure_approx = - match A.check_approx_for_set_of_closures set_of_closures_approx with - | Ok (_, value_set_of_closures) -> - let closure_id = - A.freshen_and_check_closure_id value_set_of_closures closure_id - in - A.value_closure value_set_of_closures closure_id - | Unresolved sym -> A.value_unresolved sym - | Unknown -> A.value_unknown Other - | Unknown_because_of_unresolved_value value -> - A.value_unknown (Unresolved_value value) - | Wrong -> - Misc.fatal_errorf "Wrong approximation for [Project_closure] \ - when being used as a [constant_defining_value]: %a" - Flambda.print_constant_defining_value constant_defining_value - in - r, constant_defining_value, closure_approx - in - let approx = A.augment_with_symbol approx symbol in - let r = ret r approx in - r, constant_defining_value, approx - -let rec simplify_program_body env r (program : Flambda.program_body) - : Flambda.program_body * R.t = - match program with - | Let_rec_symbol (defs, program) -> - let set_of_closures_defs, other_defs = - List.partition - (function - | (_, Flambda.Set_of_closures _) -> true - | _ -> false) - defs in - let process_defs ~lookup_env ~env r defs = - List.fold_left (fun (building_env, r, defs) (symbol, def) -> - let r, def, approx = - simplify_constant_defining_value lookup_env r symbol def - in - let approx = A.augment_with_symbol approx symbol in - let building_env = E.add_symbol building_env symbol approx in - (building_env, r, (symbol, def) :: defs)) - (env, r, []) defs - in - let env, r, set_of_closures_defs = - let lookup_env = define_let_rec_symbol_approx env defs in - process_defs ~lookup_env ~env r set_of_closures_defs - in - let env, r, other_defs = - let lookup_env = define_let_rec_symbol_approx env other_defs in - process_defs ~lookup_env ~env r other_defs - in - let program, r = simplify_program_body env r program in - Let_rec_symbol (set_of_closures_defs @ other_defs, program), r - | Let_symbol (symbol, constant_defining_value, program) -> - let r, constant_defining_value, approx = - simplify_constant_defining_value env r symbol constant_defining_value - in - let approx = A.augment_with_symbol approx symbol in - let env = E.add_symbol env symbol approx in - let program, r = simplify_program_body env r program in - Let_symbol (symbol, constant_defining_value, program), r - | Initialize_symbol (symbol, tag, fields, program) -> - let fields, approxs, r = simplify_list env r fields in - let approx = - A.augment_with_symbol (A.value_block tag (Array.of_list approxs)) symbol - in - let module Backend = (val (E.backend env) : Backend_intf.S) in - let env = E.add_symbol env symbol approx in - let program, r = simplify_program_body env r program in - Initialize_symbol (symbol, tag, fields, program), r - | Effect (expr, program) -> - let expr, r = simplify env r expr in - let program, r = simplify_program_body env r program in - Effect (expr, program), r - | End root -> End root, r - -let simplify_program env r (program : Flambda.program) = - let env, r = - Symbol.Set.fold (fun symbol (env, r) -> - let env, approx = - match E.find_symbol_exn env symbol with - | exception Not_found -> - let module Backend = (val (E.backend env) : Backend_intf.S) in - (* CR-someday mshinwell for mshinwell: Is there a reason we cannot - use [simplify_named_using_approx_and_env] here? *) - let approx = Backend.import_symbol symbol in - E.add_symbol env symbol approx, approx - | approx -> env, approx - in - env, ret r approx) - program.imported_symbols - (env, r) - in - let program_body, r = simplify_program_body env r program.program_body in - let program = { program with program_body; } in - program, r - -let add_predef_exns_to_environment ~env ~backend = - let module Backend = (val backend : Backend_intf.S) in - List.fold_left (fun env predef_exn -> - assert (Ident.is_predef predef_exn); - let symbol = Backend.symbol_for_global' predef_exn in - let name = Ident.name predef_exn in - let approx = - A.value_block Tag.object_tag - [| A.value_string (String.length name) (Some name); - A.value_unknown Other; - |] - in - E.add_symbol env symbol (A.augment_with_symbol approx symbol)) - env - Predef.all_predef_exns - -let run ~never_inline ~backend ~prefixname ~round ~ppf_dump program = - let r = R.create () in - let report = !Clflags.inlining_report in - if never_inline then Clflags.inlining_report := false; - let initial_env = - add_predef_exns_to_environment - ~env:(E.create ~never_inline ~backend ~round ~ppf_dump) - ~backend - in - let result, r = simplify_program initial_env r program in - let result = Flambda_utils.introduce_needed_import_symbols result in - if not (Static_exception.Set.is_empty (R.used_static_exceptions r)) - then begin - Misc.fatal_error (Format.asprintf "Remaining static exceptions: %a@.%a@." - Static_exception.Set.print (R.used_static_exceptions r) - Flambda.print_program result) - end; - assert (Static_exception.Set.is_empty (R.used_static_exceptions r)); - if !Clflags.inlining_report then begin - let output_prefix = Printf.sprintf "%s.%d" prefixname round in - Inlining_stats.save_then_forget_decisions ~output_prefix - end; - Clflags.inlining_report := report; - result diff --git a/middle_end/inline_and_simplify.mli b/middle_end/inline_and_simplify.mli deleted file mode 100644 index 9a8e6e8b..00000000 --- a/middle_end/inline_and_simplify.mli +++ /dev/null @@ -1,40 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Simplification of Flambda programs combined with function inlining: - for the most part a beta-reduction pass. - - Readers interested in the inlining strategy should read the - [Inlining_decision] module first. -*) -val run - : never_inline:bool - -> backend:(module Backend_intf.S) - -> prefixname:string - -> round:int - -> ppf_dump:Format.formatter - -> Flambda.program - -> Flambda.program - -val duplicate_function - : env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> fun_var:Variable.t - -> new_fun_var:Variable.t - -> Flambda.function_declaration - * Flambda.specialised_to Variable.Map.t (* new specialised arguments *) diff --git a/middle_end/inline_and_simplify_aux.ml b/middle_end/inline_and_simplify_aux.ml deleted file mode 100644 index bb725e8c..00000000 --- a/middle_end/inline_and_simplify_aux.ml +++ /dev/null @@ -1,738 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module Env = struct - type scope = Current | Outer - - type t = { - backend : (module Backend_intf.S); - round : int; - ppf_dump : Format.formatter; - approx : (scope * Simple_value_approx.t) Variable.Map.t; - approx_mutable : Simple_value_approx.t Mutable_variable.Map.t; - approx_sym : Simple_value_approx.t Symbol.Map.t; - projections : Variable.t Projection.Map.t; - current_functions : Set_of_closures_origin.Set.t; - (* The functions currently being declared: used to avoid inlining - recursively *) - inlining_level : int; - (* Number of times "inline" has been called recursively *) - inside_branch : int; - freshening : Freshening.t; - never_inline : bool ; - never_inline_inside_closures : bool; - never_inline_outside_closures : bool; - unroll_counts : int Set_of_closures_origin.Map.t; - inlining_counts : int Closure_origin.Map.t; - actively_unrolling : int Set_of_closures_origin.Map.t; - closure_depth : int; - inlining_stats_closure_stack : Inlining_stats.Closure_stack.t; - inlined_debuginfo : Debuginfo.t; - } - - let create ~never_inline ~backend ~round ~ppf_dump = - { backend; - round; - ppf_dump; - approx = Variable.Map.empty; - approx_mutable = Mutable_variable.Map.empty; - approx_sym = Symbol.Map.empty; - projections = Projection.Map.empty; - current_functions = Set_of_closures_origin.Set.empty; - inlining_level = 0; - inside_branch = 0; - freshening = Freshening.empty; - never_inline; - never_inline_inside_closures = false; - never_inline_outside_closures = false; - unroll_counts = Set_of_closures_origin.Map.empty; - inlining_counts = Closure_origin.Map.empty; - actively_unrolling = Set_of_closures_origin.Map.empty; - closure_depth = 0; - inlining_stats_closure_stack = - Inlining_stats.Closure_stack.create (); - inlined_debuginfo = Debuginfo.none; - } - - let backend t = t.backend - let round t = t.round - let ppf_dump t = t.ppf_dump - - let local env = - { env with - approx = Variable.Map.empty; - projections = Projection.Map.empty; - freshening = Freshening.empty_preserving_activation_state env.freshening; - inlined_debuginfo = Debuginfo.none; - } - - let inlining_level_up env = - let max_level = - Clflags.Int_arg_helper.get ~key:(env.round) !Clflags.inline_max_depth - in - if (env.inlining_level + 1) > max_level then - Misc.fatal_error "Inlining level increased above maximum"; - { env with inlining_level = env.inlining_level + 1 } - - let print ppf t = - Format.fprintf ppf - "Environment maps: %a@.Projections: %a@.Freshening: %a@." - Variable.Set.print (Variable.Map.keys t.approx) - (Projection.Map.print Variable.print) t.projections - Freshening.print t.freshening - - let mem t var = Variable.Map.mem var t.approx - - let add_internal t var (approx : Simple_value_approx.t) ~scope = - let approx = - (* The semantics of this [match] are what preserve the property - described at the top of simple_value_approx.mli, namely that when a - [var] is mem on an approximation (amongst many possible [var]s), - it is the one with the outermost scope. *) - match approx.var with - | Some var when mem t var -> approx - | _ -> Simple_value_approx.augment_with_variable approx var - in - { t with approx = Variable.Map.add var (scope, approx) t.approx } - - let add t var approx = add_internal t var approx ~scope:Current - let add_outer_scope t var approx = add_internal t var approx ~scope:Outer - - let add_mutable t mut_var approx = - { t with approx_mutable = - Mutable_variable.Map.add mut_var approx t.approx_mutable; - } - - let really_import_approx t = - let module Backend = (val (t.backend) : Backend_intf.S) in - Backend.really_import_approx - - let really_import_approx_with_scope t (scope, approx) = - scope, really_import_approx t approx - - let find_symbol_exn t symbol = - really_import_approx t - (Symbol.Map.find symbol t.approx_sym) - - let find_symbol_opt t symbol = - try Some (really_import_approx t - (Symbol.Map.find symbol t.approx_sym)) - with Not_found -> None - - let find_symbol_fatal t symbol = - match find_symbol_exn t symbol with - | exception Not_found -> - Misc.fatal_errorf "Symbol %a is unbound. Maybe there is a missing \ - [Let_symbol], [Import_symbol] or similar?" - Symbol.print symbol - | approx -> approx - - let find_or_load_symbol t symbol = - match find_symbol_exn t symbol with - | exception Not_found -> - if Compilation_unit.equal - (Compilation_unit.get_current_exn ()) - (Symbol.compilation_unit symbol) - then - Misc.fatal_errorf "Symbol %a from the current compilation unit is \ - unbound. Maybe there is a missing [Let_symbol] or similar?" - Symbol.print symbol; - let module Backend = (val (t.backend) : Backend_intf.S) in - Backend.import_symbol symbol - | approx -> approx - - let add_projection t ~projection ~bound_to = - { t with - projections = - Projection.Map.add projection bound_to t.projections; - } - - let find_projection t ~projection = - match Projection.Map.find projection t.projections with - | exception Not_found -> None - | var -> Some var - - let does_not_bind t vars = - not (List.exists (mem t) vars) - - let does_not_freshen t vars = - Freshening.does_not_freshen t.freshening vars - - let add_symbol t symbol approx = - match find_symbol_exn t symbol with - | exception Not_found -> - { t with - approx_sym = Symbol.Map.add symbol approx t.approx_sym; - } - | _ -> - Misc.fatal_errorf "Attempt to redefine symbol %a (to %a) in environment \ - for [Inline_and_simplify]" - Symbol.print symbol - Simple_value_approx.print approx - - let redefine_symbol t symbol approx = - match find_symbol_exn t symbol with - | exception Not_found -> - assert false - | _ -> - { t with - approx_sym = Symbol.Map.add symbol approx t.approx_sym; - } - - let find_with_scope_exn t id = - try - really_import_approx_with_scope t - (Variable.Map.find id t.approx) - with Not_found -> - Misc.fatal_errorf "Env.find_with_scope_exn: Unbound variable \ - %a@.%s@. Environment: %a@." - Variable.print id - (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int)) - print t - - let find_exn t id = - snd (find_with_scope_exn t id) - - let find_mutable_exn t mut_var = - try Mutable_variable.Map.find mut_var t.approx_mutable - with Not_found -> - Misc.fatal_errorf "Env.find_mutable_exn: Unbound variable \ - %a@.%s@. Environment: %a@." - Mutable_variable.print mut_var - (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int)) - print t - - let find_list_exn t vars = - List.map (fun var -> find_exn t var) vars - - let find_opt t id = - try Some (really_import_approx t - (snd (Variable.Map.find id t.approx))) - with Not_found -> None - - let activate_freshening t = - { t with freshening = Freshening.activate t.freshening } - - let enter_set_of_closures_declaration t origin = - { t with - current_functions = - Set_of_closures_origin.Set.add origin t.current_functions; } - - let inside_set_of_closures_declaration origin t = - Set_of_closures_origin.Set.mem origin t.current_functions - - let at_toplevel t = - t.closure_depth = 0 - - let is_inside_branch env = env.inside_branch > 0 - - let branch_depth env = env.inside_branch - - let inside_branch t = - { t with inside_branch = t.inside_branch + 1 } - - let set_freshening t freshening = - { t with freshening; } - - let increase_closure_depth t = - let approx = - Variable.Map.map (fun (_scope, approx) -> Outer, approx) t.approx - in - { t with - approx; - closure_depth = t.closure_depth + 1; - } - - let set_never_inline t = - if t.never_inline then t - else { t with never_inline = true } - - let set_never_inline_inside_closures t = - if t.never_inline_inside_closures then t - else { t with never_inline_inside_closures = true } - - let unset_never_inline_inside_closures t = - if t.never_inline_inside_closures then - { t with never_inline_inside_closures = false } - else t - - let set_never_inline_outside_closures t = - if t.never_inline_outside_closures then t - else { t with never_inline_outside_closures = true } - - let unset_never_inline_outside_closures t = - if t.never_inline_outside_closures then - { t with never_inline_outside_closures = false } - else t - - let actively_unrolling t origin = - match Set_of_closures_origin.Map.find origin t.actively_unrolling with - | count -> Some count - | exception Not_found -> None - - let start_actively_unrolling t origin i = - let actively_unrolling = - Set_of_closures_origin.Map.add origin i t.actively_unrolling - in - { t with actively_unrolling } - - let continue_actively_unrolling t origin = - let unrolling = - try - Set_of_closures_origin.Map.find origin t.actively_unrolling - with Not_found -> - Misc.fatal_error "Unexpected actively unrolled function" - in - let actively_unrolling = - Set_of_closures_origin.Map.add origin (unrolling - 1) t.actively_unrolling - in - { t with actively_unrolling } - - let unrolling_allowed t origin = - let unroll_count = - try - Set_of_closures_origin.Map.find origin t.unroll_counts - with Not_found -> - Clflags.Int_arg_helper.get - ~key:t.round !Clflags.inline_max_unroll - in - unroll_count > 0 - - let inside_unrolled_function t origin = - let unroll_count = - try - Set_of_closures_origin.Map.find origin t.unroll_counts - with Not_found -> - Clflags.Int_arg_helper.get - ~key:t.round !Clflags.inline_max_unroll - in - let unroll_counts = - Set_of_closures_origin.Map.add - origin (unroll_count - 1) t.unroll_counts - in - { t with unroll_counts } - - let inlining_allowed t id = - let inlining_count = - try - Closure_origin.Map.find id t.inlining_counts - with Not_found -> - max 1 (Clflags.Int_arg_helper.get - ~key:t.round !Clflags.inline_max_unroll) - in - inlining_count > 0 - - let inside_inlined_function t id = - let inlining_count = - try - Closure_origin.Map.find id t.inlining_counts - with Not_found -> - max 1 (Clflags.Int_arg_helper.get - ~key:t.round !Clflags.inline_max_unroll) - in - let inlining_counts = - Closure_origin.Map.add id (inlining_count - 1) t.inlining_counts - in - { t with inlining_counts } - - let inlining_level t = t.inlining_level - let freshening t = t.freshening - let never_inline t = t.never_inline || t.never_inline_outside_closures - - let note_entering_closure t ~closure_id ~dbg = - if t.never_inline then t - else - { t with - inlining_stats_closure_stack = - Inlining_stats.Closure_stack.note_entering_closure - t.inlining_stats_closure_stack ~closure_id ~dbg; - } - - let note_entering_call t ~closure_id ~dbg = - if t.never_inline then t - else - { t with - inlining_stats_closure_stack = - Inlining_stats.Closure_stack.note_entering_call - t.inlining_stats_closure_stack ~closure_id ~dbg; - } - - let note_entering_inlined t = - if t.never_inline then t - else - { t with - inlining_stats_closure_stack = - Inlining_stats.Closure_stack.note_entering_inlined - t.inlining_stats_closure_stack; - } - - let note_entering_specialised t ~closure_ids = - if t.never_inline then t - else - { t with - inlining_stats_closure_stack = - Inlining_stats.Closure_stack.note_entering_specialised - t.inlining_stats_closure_stack ~closure_ids; - } - - let enter_closure t ~closure_id ~inline_inside ~dbg ~f = - let t = - if inline_inside && not t.never_inline_inside_closures then t - else set_never_inline t - in - let t = unset_never_inline_outside_closures t in - f (note_entering_closure t ~closure_id ~dbg) - - let record_decision t decision = - Inlining_stats.record_decision decision - ~closure_stack:t.inlining_stats_closure_stack - - let set_inline_debuginfo t ~dbg = - { t with inlined_debuginfo = dbg } - - let add_inlined_debuginfo t ~dbg = - Debuginfo.concat t.inlined_debuginfo dbg -end - -let initial_inlining_threshold ~round : Inlining_cost.Threshold.t = - let unscaled = - Clflags.Float_arg_helper.get ~key:round !Clflags.inline_threshold - in - (* CR-soon pchambart: Add a warning if this is too big - mshinwell: later *) - Can_inline_if_no_larger_than - (int_of_float - (unscaled *. float_of_int Inlining_cost.scale_inline_threshold_by)) - -let initial_inlining_toplevel_threshold ~round : Inlining_cost.Threshold.t = - let ordinary_threshold = - Clflags.Float_arg_helper.get ~key:round !Clflags.inline_threshold - in - let toplevel_threshold = - Clflags.Int_arg_helper.get ~key:round !Clflags.inline_toplevel_threshold - in - let unscaled = - (int_of_float ordinary_threshold) + toplevel_threshold - in - (* CR-soon pchambart: Add a warning if this is too big - mshinwell: later *) - Can_inline_if_no_larger_than - (unscaled * Inlining_cost.scale_inline_threshold_by) - -module Result = struct - type t = - { approx : Simple_value_approx.t; - used_static_exceptions : Static_exception.Set.t; - inlining_threshold : Inlining_cost.Threshold.t option; - benefit : Inlining_cost.Benefit.t; - num_direct_applications : int; - } - - let create () = - { approx = Simple_value_approx.value_unknown Other; - used_static_exceptions = Static_exception.Set.empty; - inlining_threshold = None; - benefit = Inlining_cost.Benefit.zero; - num_direct_applications = 0; - } - - let approx t = t.approx - let set_approx t approx = { t with approx } - - let meet_approx t env approx = - let really_import_approx = Env.really_import_approx env in - let meet = - Simple_value_approx.meet ~really_import_approx t.approx approx - in - set_approx t meet - - let use_static_exception t i = - { t with - used_static_exceptions = - Static_exception.Set.add i t.used_static_exceptions; - } - - let used_static_exceptions t = t.used_static_exceptions - - let exit_scope_catch t i = - { t with - used_static_exceptions = - Static_exception.Set.remove i t.used_static_exceptions; - } - - let map_benefit t f = - { t with benefit = f t.benefit } - - let add_benefit t b = - { t with benefit = Inlining_cost.Benefit.(+) t.benefit b } - - let benefit t = t.benefit - - let reset_benefit t = - { t with benefit = Inlining_cost.Benefit.zero; } - - let set_inlining_threshold t inlining_threshold = - { t with inlining_threshold } - - let add_inlining_threshold t j = - match t.inlining_threshold with - | None -> t - | Some i -> - let inlining_threshold = Some (Inlining_cost.Threshold.add i j) in - { t with inlining_threshold } - - let sub_inlining_threshold t j = - match t.inlining_threshold with - | None -> t - | Some i -> - let inlining_threshold = Some (Inlining_cost.Threshold.sub i j) in - { t with inlining_threshold } - - let inlining_threshold t = t.inlining_threshold - - let seen_direct_application t = - { t with num_direct_applications = t.num_direct_applications + 1; } - - let num_direct_applications t = - t.num_direct_applications -end - -module A = Simple_value_approx -module E = Env - -let keep_body_check ~is_classic_mode ~recursive = - if not is_classic_mode then begin - fun _ _ -> true - end else begin - let can_inline_non_rec_function (fun_decl : Flambda.function_declaration) = - (* In classic-inlining mode, the inlining decision is taken at - definition site (here). If the function is small enough - (below the -inline threshold) it will always be inlined. - - Closure gives a bonus of [8] to optional arguments. In classic - mode, however, we would inline functions with the "*opt*" argument - in all cases, as it is a stub. (This is ensured by - [middle_end/closure_conversion.ml]). - *) - let inlining_threshold = initial_inlining_threshold ~round:0 in - let bonus = Flambda_utils.function_arity fun_decl in - Inlining_cost.can_inline fun_decl.body inlining_threshold ~bonus - in - fun (var : Variable.t) (fun_decl : Flambda.function_declaration) -> - if fun_decl.stub then begin - true - end else if Variable.Set.mem var (Lazy.force recursive) then begin - false - end else begin - match fun_decl.inline with - | Default_inline -> can_inline_non_rec_function fun_decl - | Unroll factor -> factor > 0 - | Always_inline -> true - | Never_inline -> false - end - end - -let prepare_to_simplify_set_of_closures ~env - ~(set_of_closures : Flambda.set_of_closures) - ~function_decls ~freshen - ~(only_for_function_decl : Flambda.function_declaration option) = - let free_vars = - Variable.Map.map (fun (external_var : Flambda.specialised_to) -> - let var = - let var = - Freshening.apply_variable (E.freshening env) external_var.var - in - match - A.simplify_var_to_var_using_env (E.find_exn env var) - ~is_present_in_env:(fun var -> E.mem env var) - with - | None -> var - | Some var -> var - in - let approx = E.find_exn env var in - (* The projections are freshened below in one step, once we know - the closure freshening substitution. *) - let projection = external_var.projection in - ({ var; projection; } : Flambda.specialised_to), approx) - set_of_closures.free_vars - in - let specialised_args = - Variable.Map.filter_map set_of_closures.specialised_args - ~f:(fun param (spec_to : Flambda.specialised_to) -> - let keep = - match only_for_function_decl with - | None -> true - | Some function_decl -> - Variable.Set.mem param (Parameter.Set.vars function_decl.params) - in - if not keep then None - else - let external_var = spec_to.var in - let var = - Freshening.apply_variable (E.freshening env) external_var - in - let var = - match - A.simplify_var_to_var_using_env (E.find_exn env var) - ~is_present_in_env:(fun var -> E.mem env var) - with - | None -> var - | Some var -> var - in - let projection = spec_to.projection in - Some ({ var; projection; } : Flambda.specialised_to)) - in - let environment_before_cleaning = env in - (* [E.local] helps us to catch bugs whereby variables escape their scope. *) - let env = E.local env in - let free_vars, function_decls, sb, freshening = - Freshening.apply_function_decls_and_free_vars (E.freshening env) free_vars - function_decls ~only_freshen_parameters:(not freshen) - in - let env = E.set_freshening env sb in - let free_vars = - Freshening.freshen_projection_relation' free_vars - ~freshening:(E.freshening env) - ~closure_freshening:freshening - in - let specialised_args = - let specialised_args = - Variable.Map.map_keys (Freshening.apply_variable (E.freshening env)) - specialised_args - in - Freshening.freshen_projection_relation specialised_args - ~freshening:(E.freshening env) - ~closure_freshening:freshening - in - let parameter_approximations = - (* Approximations of parameters that are known to always hold the same - argument throughout the body of the function. *) - Variable.Map.map_keys (Freshening.apply_variable (E.freshening env)) - (Variable.Map.mapi (fun _id' (spec_to : Flambda.specialised_to) -> - E.find_exn environment_before_cleaning spec_to.var) - specialised_args) - in - let direct_call_surrogates = - Variable.Map.fold (fun existing surrogate surrogates -> - let existing = - Freshening.Project_var.apply_closure_id freshening - (Closure_id.wrap existing) - in - let surrogate = - Freshening.Project_var.apply_closure_id freshening - (Closure_id.wrap surrogate) - in - assert (not (Closure_id.Map.mem existing surrogates)); - Closure_id.Map.add existing surrogate surrogates) - set_of_closures.direct_call_surrogates - Closure_id.Map.empty - in - let env = - E.enter_set_of_closures_declaration env - function_decls.set_of_closures_origin - in - (* we use the previous closure for evaluating the functions *) - let internal_value_set_of_closures = - let bound_vars = - Variable.Map.fold (fun id (_, desc) map -> - Var_within_closure.Map.add (Var_within_closure.wrap id) desc map) - free_vars Var_within_closure.Map.empty - in - let free_vars = Variable.Map.map fst free_vars in - let invariant_params = lazy Variable.Map.empty in - let recursive = lazy (Variable.Map.keys function_decls.funs) in - let is_classic_mode = function_decls.is_classic_mode in - let keep_body = keep_body_check ~is_classic_mode ~recursive in - let function_decls = - A.function_declarations_approx ~keep_body function_decls - in - A.create_value_set_of_closures ~function_decls ~bound_vars - ~free_vars ~invariant_params ~recursive ~specialised_args - ~freshening ~direct_call_surrogates - in - (* Populate the environment with the approximation of each closure. - This part of the environment is shared between all of the closures in - the set of closures. *) - let set_of_closures_env = - Variable.Map.fold (fun closure _ env -> - let approx = - A.value_closure ~closure_var:closure internal_value_set_of_closures - (Closure_id.wrap closure) - in - E.add env closure approx - ) - function_decls.funs env - in - free_vars, specialised_args, function_decls, parameter_approximations, - internal_value_set_of_closures, set_of_closures_env - -(* This adds only the minimal set of approximations to the closures. - It is not strictly necessary to have this restriction, but it helps - to catch potential substitution bugs. *) -let populate_closure_approximations - ~(function_decl : Flambda.function_declaration) - ~(free_vars : (_ * A.t) Variable.Map.t) - ~(parameter_approximations : A.t Variable.Map.t) - ~set_of_closures_env = - (* Add approximations of free variables *) - let env = - Variable.Map.fold (fun id (_, desc) env -> - E.add_outer_scope env id desc) - free_vars set_of_closures_env - in - (* Add known approximations of function parameters *) - let env = - List.fold_left (fun env id -> - let approx = - try Variable.Map.find id parameter_approximations - with Not_found -> (A.value_unknown Other) - in - E.add env id approx) - env (Parameter.List.vars function_decl.params) - in - env - -let prepare_to_simplify_closure ~(function_decl : Flambda.function_declaration) - ~free_vars ~specialised_args ~parameter_approximations - ~set_of_closures_env = - let closure_env = - populate_closure_approximations ~function_decl ~free_vars - ~parameter_approximations ~set_of_closures_env - in - (* Add definitions of known projections to the environment. *) - let add_projections ~closure_env ~which_variables ~map = - Variable.Map.fold (fun inner_var spec_arg env -> - let (spec_arg : Flambda.specialised_to) = map spec_arg in - match spec_arg.projection with - | None -> env - | Some projection -> - let from = Projection.projecting_from projection in - if Variable.Set.mem from function_decl.free_variables then - E.add_projection env ~projection ~bound_to:inner_var - else - env) - which_variables - closure_env - in - let closure_env = - add_projections ~closure_env ~which_variables:specialised_args - ~map:(fun spec_to -> spec_to) - in - add_projections ~closure_env ~which_variables:free_vars - ~map:(fun (spec_to, _approx) -> spec_to) diff --git a/middle_end/inline_and_simplify_aux.mli b/middle_end/inline_and_simplify_aux.mli deleted file mode 100755 index 79d84a31..00000000 --- a/middle_end/inline_and_simplify_aux.mli +++ /dev/null @@ -1,368 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Environments and result structures used during inlining and - simplification. (See inline_and_simplify.ml.) *) - -module Env : sig - (** Environments follow the lexical scopes of the program. *) - type t - - (** Create a new environment. If [never_inline] is true then the returned - environment will prevent [Inline_and_simplify] from inlining. The - [backend] parameter is used for passing information about the compiler - backend being used. - Newly-created environments have inactive [Freshening]s (see below) and do - not initially hold any approximation information. *) - val create - : never_inline:bool - -> backend:(module Backend_intf.S) - -> round:int - -> ppf_dump:Format.formatter - -> t - - (** Obtain the first-class module that gives information about the - compiler backend being used for compilation. *) - val backend : t -> (module Backend_intf.S) - - (** Obtain the really_import_approx function from the backend module. *) - val really_import_approx - : t - -> (Simple_value_approx.t -> Simple_value_approx.t) - - (** Which simplification round we are currently in. *) - val round : t -> int - - (** Where to print intermediate asts and similar debug information *) - val ppf_dump : t -> Format.formatter - - (** Add the approximation of a variable---that is to say, some knowledge - about the value(s) the variable may take on at runtime---to the - environment. *) - val add : t -> Variable.t -> Simple_value_approx.t -> t - - val add_outer_scope : t -> Variable.t -> Simple_value_approx.t -> t - - (** Like [add], but for mutable variables. *) - val add_mutable : t -> Mutable_variable.t -> Simple_value_approx.t -> t - - (** Find the approximation of a given variable, raising a fatal error if - the environment does not know about the variable. Use [find_opt] - instead if you need to catch the failure case. *) - val find_exn : t -> Variable.t -> Simple_value_approx.t - - (** Like [find_exn], but for mutable variables. *) - val find_mutable_exn : t -> Mutable_variable.t -> Simple_value_approx.t - - type scope = Current | Outer - - val find_with_scope_exn : t -> Variable.t -> scope * Simple_value_approx.t - - (** Like [find_exn], but intended for use where the "not present in - environment" case is to be handled by the caller. *) - val find_opt : t -> Variable.t -> Simple_value_approx.t option - - (** Like [find_exn], but for a list of variables. *) - val find_list_exn : t -> Variable.t list -> Simple_value_approx.t list - - val does_not_bind : t -> Variable.t list -> bool - - val does_not_freshen : t -> Variable.t list -> bool - - val add_symbol : t -> Symbol.t -> Simple_value_approx.t -> t - val redefine_symbol : t -> Symbol.t -> Simple_value_approx.t -> t - val find_symbol_exn : t -> Symbol.t -> Simple_value_approx.t - val find_symbol_opt : t -> Symbol.t -> Simple_value_approx.t option - val find_symbol_fatal : t -> Symbol.t -> Simple_value_approx.t - - (* Like [find_symbol_exn], but load the symbol approximation using - the backend if not available in the environment. *) - val find_or_load_symbol : t -> Symbol.t -> Simple_value_approx.t - - (** Note that the given [bound_to] holds the given [projection]. *) - val add_projection - : t - -> projection:Projection.t - -> bound_to:Variable.t - -> t - - (** Determine if the environment knows about a variable that is bound - to the given [projection]. *) - val find_projection - : t - -> projection:Projection.t - -> Variable.t option - - (** Whether the environment has an approximation for the given variable. *) - val mem : t -> Variable.t -> bool - - (** Return the freshening that should be applied to variables when - rewriting code (in [Inline_and_simplify], etc.) using the given - environment. *) - val freshening : t -> Freshening.t - - (** Set the freshening that should be used as per [freshening], above. *) - val set_freshening : t -> Freshening.t -> t - - (** Causes every bound variable in code rewritten during inlining and - simplification, using the given environment, to be freshened. This is - used when descending into subexpressions substituted into existing - expressions. *) - val activate_freshening : t -> t - - (** Erase all variable approximation information and freshening information - from the given environment. However, the freshening activation state - is preserved. This function is used when rewriting inside a function - declaration, to avoid (due to a compiler bug) accidental use of - variables from outer scopes that are not accessible. *) - val local : t -> t - - (** Determine whether the inliner is currently inside a function body from - the given set of closures. This is used to detect whether a given - function call refers to a function which exists somewhere on the current - inlining stack. *) - val inside_set_of_closures_declaration : Set_of_closures_origin.t -> t -> bool - - (** Not inside a closure declaration. - Toplevel code is the one evaluated when the compilation unit is - loaded *) - val at_toplevel : t -> bool - - val is_inside_branch : t -> bool - val branch_depth : t -> int - val inside_branch : t -> t - - val increase_closure_depth : t -> t - - (** Mark that call sites contained within code rewritten using the given - environment should never be replaced by inlined (or unrolled) versions - of the callee(s). *) - val set_never_inline : t -> t - - (** Equivalent to [set_never_inline] but only applies to code inside - a set of closures. *) - val set_never_inline_inside_closures : t -> t - - (** Unset the restriction from [set_never_inline_inside_closures] *) - val unset_never_inline_inside_closures : t -> t - - (** Equivalent to [set_never_inline] but does not apply to code inside - a set of closures. *) - val set_never_inline_outside_closures : t -> t - - (** Unset the restriction from [set_never_inline_outside_closures] *) - val unset_never_inline_outside_closures : t -> t - - (** Return whether [set_never_inline] is currently in effect on the given - environment. *) - val never_inline : t -> bool - - val inlining_level : t -> int - - (** Mark that this environment is used to rewrite code for inlining. This is - used by the inlining heuristics to decide whether to continue. - Unconditionally inlined does not take this into account. *) - val inlining_level_up : t -> t - - (** Whether we are actively unrolling a given function. *) - val actively_unrolling : t -> Set_of_closures_origin.t -> int option - - (** Start actively unrolling a given function [n] times. *) - val start_actively_unrolling : t -> Set_of_closures_origin.t -> int -> t - - (** Unroll a function currently actively being unrolled. *) - val continue_actively_unrolling : t -> Set_of_closures_origin.t -> t - - (** Whether it is permissible to unroll a call to a recursive function - in the given environment. *) - val unrolling_allowed : t -> Set_of_closures_origin.t -> bool - - (** Whether the given environment is currently being used to rewrite the - body of an unrolled recursive function. *) - val inside_unrolled_function : t -> Set_of_closures_origin.t -> t - - (** Whether it is permissible to inline a call to a function in the given - environment. *) - val inlining_allowed : t -> Closure_origin.t -> bool - - (** Whether the given environment is currently being used to rewrite the - body of an inlined function. *) - val inside_inlined_function : t -> Closure_origin.t -> t - - (** If collecting inlining statistics, record that the inliner is about to - descend into [closure_id]. This information enables us to produce a - stack of closures that form a kind of context around an inlining - decision point. *) - val note_entering_closure - : t - -> closure_id:Closure_id.t - -> dbg:Debuginfo.t - -> t - - (** If collecting inlining statistics, record that the inliner is about to - descend into a call to [closure_id]. This information enables us to - produce a stack of closures that form a kind of context around an - inlining decision point. *) - val note_entering_call - : t - -> closure_id:Closure_id.t - -> dbg:Debuginfo.t - -> t - - (** If collecting inlining statistics, record that the inliner is about to - descend into an inlined function call. This requires that the inliner - has already entered the call with [note_entering_call]. *) - val note_entering_inlined : t -> t - - (** If collecting inlining statistics, record that the inliner is about to - descend into a specialised function definition. This requires that the - inliner has already entered the call with [note_entering_call]. *) - val note_entering_specialised : t -> closure_ids:Closure_id.Set.t -> t - - (** Update a given environment to record that the inliner is about to - descend into [closure_id] and pass the resulting environment to [f]. - If [inline_inside] is [false] then the environment passed to [f] will be - marked as [never_inline] (see above). *) - val enter_closure - : t - -> closure_id:Closure_id.t - -> inline_inside:bool - -> dbg:Debuginfo.t - -> f:(t -> 'a) - -> 'a - - (** If collecting inlining statistics, record an inlining decision for the - call at the top of the closure stack stored inside the given - environment. *) - val record_decision - : t - -> Inlining_stats_types.Decision.t - -> unit - - (** Print a human-readable version of the given environment. *) - val print : Format.formatter -> t -> unit - - (** The environment stores the call-site being inlined to produce - precise location information. This function sets the current - call-site being inlined. *) - val set_inline_debuginfo : t -> dbg:Debuginfo.t -> t - - (** Appends the locations of inlined call-sites to the [~dbg] argument *) - val add_inlined_debuginfo : t -> dbg:Debuginfo.t -> Debuginfo.t -end - -module Result : sig - (** Result structures approximately follow the evaluation order of the - program. They are returned by the simplification algorithm acting on - an Flambda subexpression. *) - type t - - val create : unit -> t - - (** The approximation of the subexpression that has just been - simplified. *) - val approx : t -> Simple_value_approx.t - - (** Set the approximation of the subexpression that has just been - simplified. Typically used just before returning from a case of the - simplification algorithm. *) - val set_approx : t -> Simple_value_approx.t -> t - - (** Set the approximation of the subexpression to the meet of the - current return approximation and the provided one. Typically - used just before returning from a branch case of the - simplification algorithm. *) - val meet_approx : t -> Env.t -> Simple_value_approx.t -> t - - (** All static exceptions for which [use_staticfail] has been called on - the given result structure. *) - val used_static_exceptions : t -> Static_exception.Set.t - - (** Mark that the given static exception has been used. *) - val use_static_exception : t -> Static_exception.t -> t - - (** Mark that we are moving up out of the scope of a static-catch block - that catches the given static exception identifier. This has the effect - of removing the identifier from the [used_staticfail] set. *) - val exit_scope_catch : t -> Static_exception.t -> t - - (** The benefit to be gained by inlining the subexpression whose - simplification yielded the given result structure. *) - val benefit : t -> Inlining_cost.Benefit.t - - (** Apply a transformation to the inlining benefit stored within the - given result structure. *) - val map_benefit - : t - -> (Inlining_cost.Benefit.t -> Inlining_cost.Benefit.t) - -> t - - (** Add some benefit to the inlining benefit stored within the - given result structure. *) - val add_benefit : t -> Inlining_cost.Benefit.t -> t - - (** Set the benefit of inlining the subexpression corresponding to the - given result structure to zero. *) - val reset_benefit : t -> t - - val set_inlining_threshold : - t -> Inlining_cost.Threshold.t option -> t - val add_inlining_threshold : - t -> Inlining_cost.Threshold.t -> t - val sub_inlining_threshold : - t -> Inlining_cost.Threshold.t -> t - val inlining_threshold : t -> Inlining_cost.Threshold.t option - - val seen_direct_application : t -> t - val num_direct_applications : t -> int -end - -(** Command line argument -inline *) -val initial_inlining_threshold : round:int -> Inlining_cost.Threshold.t - -(** Command line argument -inline-toplevel *) -val initial_inlining_toplevel_threshold - : round:int -> Inlining_cost.Threshold.t - -val prepare_to_simplify_set_of_closures - : env:Env.t - -> set_of_closures:Flambda.set_of_closures - -> function_decls:Flambda.function_declarations - -> freshen:bool - -> only_for_function_decl:Flambda.function_declaration option - -> (Flambda.specialised_to * Simple_value_approx.t) Variable.Map.t (* fvs *) - * Flambda.specialised_to Variable.Map.t (* specialised arguments *) - * Flambda.function_declarations - * Simple_value_approx.t Variable.Map.t (* parameter approximations *) - * Simple_value_approx.value_set_of_closures - * Env.t - -val prepare_to_simplify_closure - : function_decl:Flambda.function_declaration - -> free_vars:(Flambda.specialised_to * Simple_value_approx.t) Variable.Map.t - -> specialised_args:Flambda.specialised_to Variable.Map.t - -> parameter_approximations:Simple_value_approx.t Variable.Map.t - -> set_of_closures_env:Env.t - -> Env.t - -val keep_body_check - : is_classic_mode:bool - -> recursive:Variable.Set.t Lazy.t - -> Variable.t - -> Flambda.function_declaration - -> bool diff --git a/middle_end/inlining_cost.ml b/middle_end/inlining_cost.ml deleted file mode 100644 index f2af293f..00000000 --- a/middle_end/inlining_cost.ml +++ /dev/null @@ -1,703 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -(* Simple approximation of the space cost of a primitive. *) - -let prim_size (prim : Lambda.primitive) args = - match prim with - | Pidentity -> 0 - | Pgetglobal _ -> 1 - | Psetglobal _ -> 1 - | Pmakeblock _ -> 5 + List.length args - | Pfield _ -> 1 - | Psetfield (_, isptr, init) -> - begin match init with - | Root_initialization -> 1 (* never causes a write barrier hit *) - | Assignment | Heap_initialization -> - match isptr with - | Pointer -> 4 - | Immediate -> 1 - end - | Pfloatfield _ -> 1 - | Psetfloatfield _ -> 1 - | Pduprecord _ -> 10 + List.length args - | Pccall p -> (if p.Primitive.prim_alloc then 10 else 4) + List.length args - | Praise _ -> 4 - | Pstringlength -> 5 - | Pbyteslength -> 5 - | Pstringrefs -> 6 - | Pbytesrefs | Pbytessets -> 6 - | Pmakearray _ -> 5 + List.length args - | Parraylength Pgenarray -> 6 - | Parraylength _ -> 2 - | Parrayrefu Pgenarray -> 12 - | Parrayrefu _ -> 2 - | Parraysetu Pgenarray -> 16 - | Parraysetu _ -> 4 - | Parrayrefs Pgenarray -> 18 - | Parrayrefs _ -> 8 - | Parraysets Pgenarray -> 22 - | Parraysets _ -> 10 - | Pbigarrayref (_, ndims, _, _) -> 4 + ndims * 6 - | Pbigarrayset (_, ndims, _, _) -> 4 + ndims * 6 - | Psequand | Psequor -> - Misc.fatal_error "Psequand and Psequor are not allowed in Prim \ - expressions; translate out instead (cf. closure_conversion.ml)" - (* CR-soon mshinwell: This match must be made exhaustive. - mshinwell: Let's do this when we have the new size computation. *) - | _ -> 2 (* arithmetic and comparisons *) - -(* Simple approximation of the space cost of an Flambda expression. *) - -(* CR-soon mshinwell: Investigate revised size numbers. *) - -let direct_call_size = 4 -let project_size = 1 - -let lambda_smaller' lam ~than:threshold = - let size = ref 0 in - let rec lambda_size (lam : Flambda.t) = - if !size > threshold then raise Exit; - match lam with - | Var _ -> () - | Apply ({ func = _; args = _; kind = direct }) -> - let call_cost = - match direct with Indirect -> 6 | Direct _ -> direct_call_size - in - size := !size + call_cost - | Assign _ -> incr size - | Send _ -> size := !size + 8 - | Proved_unreachable -> () - | Let { defining_expr; body; _ } -> - lambda_named_size defining_expr; - lambda_size body - | Let_mutable { body } -> lambda_size body - | Let_rec (bindings, body) -> - List.iter (fun (_, lam) -> lambda_named_size lam) bindings; - lambda_size body - | Switch (_, sw) -> - let aux = function _::_::_ -> size := !size + 5 | _ -> () in - aux sw.consts; aux sw.blocks; - List.iter (fun (_, lam) -> lambda_size lam) sw.consts; - List.iter (fun (_, lam) -> lambda_size lam) sw.blocks; - Misc.Stdlib.Option.iter lambda_size sw.failaction - | String_switch (_, sw, def) -> - List.iter (fun (_, lam) -> - size := !size + 2; - lambda_size lam) - sw; - Misc.may lambda_size def - | Static_raise _ -> () - | Static_catch (_, _, body, handler) -> - incr size; lambda_size body; lambda_size handler - | Try_with (body, _, handler) -> - size := !size + 8; lambda_size body; lambda_size handler - | If_then_else (_, ifso, ifnot) -> - size := !size + 2; - lambda_size ifso; lambda_size ifnot - | While (cond, body) -> - size := !size + 2; lambda_size cond; lambda_size body - | For { body; _ } -> - size := !size + 4; lambda_size body - and lambda_named_size (named : Flambda.named) = - if !size > threshold then raise Exit; - match named with - | Symbol _ | Read_mutable _ -> () - | Const _ | Allocated_const _ -> incr size - | Read_symbol_field _ -> incr size - | Set_of_closures ({ function_decls = ffuns }) -> - Variable.Map.iter (fun _ (ffun : Flambda.function_declaration) -> - lambda_size ffun.body) - ffuns.funs - | Project_closure _ | Project_var _ -> - size := !size + project_size - | Move_within_set_of_closures _ -> - incr size - | Prim (prim, args, _) -> - size := !size + prim_size prim args - | Expr expr -> lambda_size expr - in - try - lambda_size lam; - if !size <= threshold then Some !size - else None - with Exit -> - None - -let lambda_size lam = - match lambda_smaller' lam ~than:max_int with - | Some size -> - size - | None -> - (* There is no way that an expression of size max_int could fit in - memory. *) - assert false - -module Threshold = struct - - type t = - | Never_inline - | Can_inline_if_no_larger_than of int - - let add t1 t2 = - match t1, t2 with - | Never_inline, t -> t - | t, Never_inline -> t - | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> - Can_inline_if_no_larger_than (i1 + i2) - - let sub t1 t2 = - match t1, t2 with - | Never_inline, _ -> Never_inline - | t, Never_inline -> t - | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> - if i1 > i2 then Can_inline_if_no_larger_than (i1 - i2) - else Never_inline - - let min t1 t2 = - match t1, t2 with - | Never_inline, _ -> Never_inline - | _, Never_inline -> Never_inline - | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> - Can_inline_if_no_larger_than (min i1 i2) - - let equal t1 t2 = - match t1, t2 with - | Never_inline, Never_inline -> true - | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> - i1 = i2 - | (Never_inline | Can_inline_if_no_larger_than _), _ -> - false - -end - -let can_try_inlining lam inlining_threshold ~number_of_arguments - ~size_from_approximation = - match inlining_threshold with - | Threshold.Never_inline -> Threshold.Never_inline - | Threshold.Can_inline_if_no_larger_than inlining_threshold -> - let bonus = - (* removing a call will reduce the size by at least the number - of arguments *) - number_of_arguments - in - let size = - let than = inlining_threshold + bonus in - match size_from_approximation with - | Some size -> if size <= than then Some size else None - | None -> lambda_smaller' lam ~than - in - match size with - | None -> Threshold.Never_inline - | Some size -> - Threshold.Can_inline_if_no_larger_than - (inlining_threshold - size + bonus) - -let lambda_smaller lam ~than = - match lambda_smaller' lam ~than with - | Some _ -> true - | None -> false - -let can_inline lam inlining_threshold ~bonus = - match inlining_threshold with - | Threshold.Never_inline -> false - | Threshold.Can_inline_if_no_larger_than inlining_threshold -> - lambda_smaller - lam - ~than:(inlining_threshold + bonus) - -let cost (flag : Clflags.Int_arg_helper.parsed) ~round = - Clflags.Int_arg_helper.get ~key:round flag - -let benefit_factor = 1 - -module Benefit = struct - type t = { - remove_call : int; - remove_alloc : int; - remove_prim : int; - remove_branch : int; - (* CR-someday pchambart: branch_benefit : t list; *) - direct_call_of_indirect : int; - requested_inline : int; - (* Benefit to compensate the size of functions marked for inlining *) - } - - let zero = { - remove_call = 0; - remove_alloc = 0; - remove_prim = 0; - remove_branch = 0; - direct_call_of_indirect = 0; - requested_inline = 0; - } - - let remove_call t = { t with remove_call = t.remove_call + 1; } - let remove_alloc t = { t with remove_alloc = t.remove_alloc + 1; } - let remove_prim t = { t with remove_prim = t.remove_prim + 1; } - let remove_prims t n = { t with remove_prim = t.remove_prim + n; } - let remove_branch t = { t with remove_branch = t.remove_branch + 1; } - let direct_call_of_indirect t = - { t with direct_call_of_indirect = t.direct_call_of_indirect + 1; } - let requested_inline t ~size_of = - let size = lambda_size size_of in - { t with requested_inline = t.requested_inline + size; } - - let remove_code_helper b (flam : Flambda.t) = - match flam with - | Assign _ -> b := remove_prim !b - | Switch _ | String_switch _ | Static_raise _ | Try_with _ - | If_then_else _ | While _ | For _ -> b := remove_branch !b - | Apply _ | Send _ -> b := remove_call !b - | Let _ | Let_mutable _ | Let_rec _ | Proved_unreachable | Var _ - | Static_catch _ -> () - - let remove_code_helper_named b (named : Flambda.named) = - match named with - | Set_of_closures _ - | Prim ((Pmakearray _ | Pmakeblock _ | Pduprecord _), _, _) -> - b := remove_alloc !b - (* CR-soon pchambart: should we consider that boxed integer and float - operations are allocations ? *) - | Prim _ | Project_closure _ | Project_var _ - | Move_within_set_of_closures _ - | Read_symbol_field _ -> b := remove_prim !b - | Symbol _ | Read_mutable _ | Allocated_const _ | Const _ | Expr _ -> () - - let remove_code lam b = - let b = ref b in - Flambda_iterators.iter_toplevel (remove_code_helper b) - (remove_code_helper_named b) lam; - !b - - let remove_code_named lam b = - let b = ref b in - Flambda_iterators.iter_named_toplevel (remove_code_helper b) - (remove_code_helper_named b) lam; - !b - - let remove_projection (_proj : Projection.t) b = - (* They are all primitives for the moment. The [Projection.t] argument - is here for future expansion. *) - remove_prim b - - let print ppf b = - Format.fprintf ppf "@[remove_call: %i@ remove_alloc: %i@ \ - remove_prim: %i@ remove_branch: %i@ \ - direct: %i@ requested: %i@]" - b.remove_call - b.remove_alloc - b.remove_prim - b.remove_branch - b.direct_call_of_indirect - b.requested_inline - - let evaluate t ~round : int = - benefit_factor * - (t.remove_call * (cost !Clflags.inline_call_cost ~round) - + t.remove_alloc * (cost !Clflags.inline_alloc_cost ~round) - + t.remove_prim * (cost !Clflags.inline_prim_cost ~round) - + t.remove_branch * (cost !Clflags.inline_branch_cost ~round) - + (t.direct_call_of_indirect - * (cost !Clflags.inline_indirect_cost ~round))) - + t.requested_inline - - let (+) t1 t2 = { - remove_call = t1.remove_call + t2.remove_call; - remove_alloc = t1.remove_alloc + t2.remove_alloc; - remove_prim = t1.remove_prim + t2.remove_prim; - remove_branch = t1.remove_branch + t2.remove_branch; - direct_call_of_indirect = - t1.direct_call_of_indirect + t2.direct_call_of_indirect; - requested_inline = t1.requested_inline + t2.requested_inline; - } - - let (-) t1 t2 = { - remove_call = t1.remove_call - t2.remove_call; - remove_alloc = t1.remove_alloc - t2.remove_alloc; - remove_prim = t1.remove_prim - t2.remove_prim; - remove_branch = t1.remove_branch - t2.remove_branch; - direct_call_of_indirect = - t1.direct_call_of_indirect - t2.direct_call_of_indirect; - requested_inline = t1.requested_inline - t2.requested_inline; - } - - let max ~round t1 t2 = - let c1 = evaluate ~round t1 in - let c2 = evaluate ~round t2 in - if c1 > c2 then t1 else t2 - - let add_code lam b = - b - (remove_code lam zero) - - let add_code_named lam b = - b - (remove_code_named lam zero) - - let add_projection proj b = - b - (remove_projection proj zero) - - (* Print out a benefit as a table *) - - let benefit_table = - [ "Calls", (fun b -> b.remove_call); - "Allocs", (fun b -> b.remove_alloc); - "Prims", (fun b -> b.remove_prim); - "Branches", (fun b -> b.remove_branch); - "Indirect calls", (fun b -> b.direct_call_of_indirect); - ] - - let benefits_table = - lazy begin - List.map - (fun (header, accessor) -> (header, accessor, String.length header)) - benefit_table - end - - let table_line = - lazy begin - let benefits_table = Lazy.force benefits_table in - let dashes = - List.map (fun (_, _, n) -> String.make n '-') benefits_table - in - "|-" ^ String.concat "-+-" dashes ^ "-|" - end - - let table_headers = - lazy begin - let benefits_table = Lazy.force benefits_table in - let headers = List.map (fun (head, _, _) -> head) benefits_table in - "| " ^ String.concat " | " headers ^ " |" - end - - let print_table_values ppf b = - let rec loop ppf = function - | [] -> Format.fprintf ppf "|" - | (_, accessor, width) :: rest -> - Format.fprintf ppf "| %*d %a" width (accessor b) loop rest - in - loop ppf (Lazy.force benefits_table) - - let print_table ppf b = - let table_line = Lazy.force table_line in - let table_headers = Lazy.force table_headers in - Format.fprintf ppf - "@[@[%s@]@;@[%s@]@;@[%s@]@;@[%a@]@;@[%s@]@]" - table_line table_headers table_line - print_table_values b - table_line -end - -module Whether_sufficient_benefit = struct - type t = { - round : int; - benefit : Benefit.t; - toplevel : bool; - branch_depth : int; - lifting : bool; - original_size : int; - new_size : int; - evaluated_benefit : int; - estimate : bool; - } - - let create ~original ~toplevel ~branch_depth lam ~benefit ~lifting ~round = - let evaluated_benefit = Benefit.evaluate benefit ~round in - { round; benefit; toplevel; branch_depth; lifting; - original_size = lambda_size original; - new_size = lambda_size lam; - evaluated_benefit; - estimate = false; - } - - let create_estimate ~original_size ~toplevel ~branch_depth ~new_size - ~benefit ~lifting ~round = - let evaluated_benefit = Benefit.evaluate benefit ~round in - { round; benefit; toplevel; branch_depth; lifting; original_size; - new_size; evaluated_benefit; estimate = true; - } - - let is_nan f = - match Float.classify_float f with - | FP_nan -> true - | FP_normal | FP_subnormal | FP_zero | FP_infinite -> false - - let correct_branch_factor f = - (not (is_nan f)) - && (Float.compare f 0. >= 0) - - let estimated_benefit t = - if t.toplevel && t.lifting && t.branch_depth = 0 then begin - let lifting_benefit = - Clflags.Int_arg_helper.get ~key:t.round !Clflags.inline_lifting_benefit - in - float (t.evaluated_benefit + lifting_benefit) - end else begin - (* The estimated benefit is the evaluated benefit times an - estimation of the probability that the branch does actually matter - for performance (i.e. is hot). The probability is very roughly - estimated by considering that under every branch the - sub-expressions have the same [1 / (1 + factor)] probability - [p] of being hot. Hence the probability for the current - call to be hot is [p ^ number of nested branches]. - The probability is expressed as [1 / (1 + factor)] rather - than letting the user directly provide [p], since for every - positive value of [factor] [p] is in [0, 1]. *) - let branch_taken_estimated_probability = - let inline_branch_factor = - let factor = - Clflags.Float_arg_helper.get ~key:t.round - !Clflags.inline_branch_factor - in - if is_nan factor then - Clflags.default_inline_branch_factor - else if Float.compare factor 0. < 0 then - 0. - else - factor - in - assert (correct_branch_factor inline_branch_factor); - 1. /. (1. +. inline_branch_factor) - in - let call_estimated_probability = - branch_taken_estimated_probability ** float t.branch_depth - in - float t.evaluated_benefit *. call_estimated_probability - end - - let evaluate t = - Float.compare - (float t.new_size -. estimated_benefit t) - (float t.original_size) <= 0 - - let to_string t = - let lifting = t.toplevel && t.lifting && t.branch_depth = 0 in - let evaluated_benefit = - if lifting then - let lifting_benefit = - Clflags.Int_arg_helper.get ~key:t.round - !Clflags.inline_lifting_benefit - in - t.evaluated_benefit + lifting_benefit - else t.evaluated_benefit - in - let estimate = if t.estimate then "<" else "=" in - Printf.sprintf "{benefit%s{call=%d,alloc=%d,prim=%i,branch=%i,\ - indirect=%i,req=%i,\ - lifting=%B}, orig_size=%d,new_size=%d,eval_size=%d,\ - eval_benefit%s%d,\ - branch_depth=%d}=%s" - estimate - t.benefit.remove_call - t.benefit.remove_alloc - t.benefit.remove_prim - t.benefit.remove_branch - t.benefit.direct_call_of_indirect - t.benefit.requested_inline - lifting - t.original_size - t.new_size - (t.original_size - t.new_size) - estimate - evaluated_benefit - t.branch_depth - (if evaluate t then "yes" else "no") - - let print_description ~subfunctions ppf t = - let pr_intro ppf = - let estimate = if t.estimate then " at most" else "" in - Format.pp_print_text ppf - "Specialisation of the function body"; - if subfunctions then - Format.pp_print_text ppf - ", including speculative inlining of other functions,"; - Format.pp_print_text ppf " removed"; - Format.pp_print_text ppf estimate; - Format.pp_print_text ppf " the following operations:" - in - let lifting = t.toplevel && t.lifting && t.branch_depth = 0 in - let requested = t.benefit.requested_inline in - let pr_requested ppf = - if requested > 0 then begin - Format.pp_open_box ppf 0; - Format.pp_print_text ppf - "and inlined user-annotated functions worth "; - Format.fprintf ppf "%d." requested; - Format.pp_close_box ppf (); - Format.pp_print_cut ppf (); - Format.pp_print_cut ppf () - end - in - let pr_lifting ppf = - if lifting then begin - Format.pp_open_box ppf 0; - Format.pp_print_text ppf - "Inlining the function would also \ - lift some definitions to toplevel."; - Format.pp_close_box ppf (); - Format.pp_print_cut ppf (); - Format.pp_print_cut ppf () - end - in - let total_benefit = - if lifting then - let lifting_benefit = - Clflags.Int_arg_helper.get ~key:t.round - !Clflags.inline_lifting_benefit - in - t.evaluated_benefit + lifting_benefit - else t.evaluated_benefit - in - let expected_benefit = estimated_benefit t in - let size_change = t.new_size - t.original_size in - let result = if evaluate t then "less" else "greater" in - let pr_conclusion ppf = - Format.pp_print_text ppf "This gives a total benefit of "; - Format.pp_print_int ppf total_benefit; - Format.pp_print_text ppf ". At a branch depth of "; - Format.pp_print_int ppf t.branch_depth; - Format.pp_print_text ppf " this produces an expected benefit of "; - Format.fprintf ppf "%.1f" expected_benefit; - Format.pp_print_text ppf ". The new code has size "; - Format.pp_print_int ppf t.new_size; - Format.pp_print_text ppf ", giving a change in code size of "; - Format.pp_print_int ppf size_change; - Format.pp_print_text ppf ". The change in code size is "; - Format.pp_print_text ppf result; - Format.pp_print_text ppf " than the expected benefit." - in - Format.fprintf ppf "%t@,@[@[@;%a@]@;@;%t%t@]%t" - pr_intro Benefit.print_table t.benefit pr_requested pr_lifting - pr_conclusion -end - -let scale_inline_threshold_by = 8 - -let default_toplevel_multiplier = 8 - - (* CR-soon mshinwell for mshinwell: hastily-written comment, to review *) - (* We may in [Inlining_decision] need to measure the size of functions - that are below the inlining threshold. We also need to measure with - regard to benefit (see [Inlining_decision.inline_non_recursive). The - intuition for having a cached size in the second case is as follows. - If a function's body exceeds some maximum size and its argument - approximations are unknown (meaning that we cannot materially simplify - it further), we can infer without examining the function's body that - it cannot be inlined. The aim is to speed up [Inlining_decision]. - - The "original size" is [Inlining_cost.direct_call_size]. The "new size" is - the size of the function's body plus [Inlining_cost.project_size] for each - free variable and mutually recursive function accessed through the closure. - - To be inlined we need: - - body_size - + (closure_accesses * project_size) <= direct_call_size - - (evaluated_benefit * call_prob) - - i.e.: - - body_size <= direct_call_size - + (evaluated_benefit * call_prob) - - (closure_accesses * project_size) - - In this case we would be removing a single call and a projection for each - free variable that can be accessed directly (i.e. not via the closure - or the internal variable). - - evaluated_benefit = - benefit_factor - * (inline_call_cost - + ((free_variables - indirect_accesses) * inline_prim_cost)) - - (For [inline_call_cost] and [inline_prim_cost], we use the maximum these - might be across any round.) - - Substituting: - - body_size <= direct_call_size - + (benefit_factor - * (inline_call_cost - + ((free_variables - indirect_accesses) - * inline_prim_cost))) - * call_prob - - (closure_accesses * project_size) - - Rearranging: - - body_size <= direct_call_size - + (inline_call_cost * benefit_factor * call_prob) - + (free_variables * inline_prim_cost - * benefit_factor * call_prob) - - (indirect_accesses * inline_prim_cost - * benefit_factor * call_prob) - - (closure_accesses * project_size) - - The upper bound for the right-hand side is when call_prob = 1.0, - indirect_accesses = 0 and closure_accesses = 0, giving: - - direct_call_size - + (inline_call_cost * benefit_factor) - + (free_variables * inline_prim_cost * benefit_factor) - - So we should measure all functions at or below this size, but also record - the size discovered, so we can later re-check (without examining the body) - when we know [call_prob], [indirect_accesses] and [closure_accesses]. - - This number is split into parts dependent and independent of the - number of free variables: - - base = direct_call_size + (inline_call_cost * benefit_factor) - - multiplier = inline_prim_cost * benefit_factor - - body_size <= base + free_variables * multiplier - - *) -let maximum_interesting_size_of_function_body_base = - lazy begin - let max_cost = ref 0 in - for round = 0 to (Clflags.rounds ()) - 1 do - let max_size = - let inline_call_cost = cost !Clflags.inline_call_cost ~round in - direct_call_size + (inline_call_cost * benefit_factor) - in - max_cost := max !max_cost max_size - done; - !max_cost - end - -let maximum_interesting_size_of_function_body_multiplier = - lazy begin - let max_cost = ref 0 in - for round = 0 to (Clflags.rounds ()) - 1 do - let max_size = - let inline_prim_cost = cost !Clflags.inline_prim_cost ~round in - inline_prim_cost * benefit_factor - in - max_cost := max !max_cost max_size - done; - !max_cost - end - -let maximum_interesting_size_of_function_body num_free_variables = - let base = Lazy.force maximum_interesting_size_of_function_body_base in - let multiplier = - Lazy.force maximum_interesting_size_of_function_body_multiplier - in - base + (num_free_variables * multiplier) diff --git a/middle_end/inlining_cost.mli b/middle_end/inlining_cost.mli deleted file mode 100644 index 345f67ab..00000000 --- a/middle_end/inlining_cost.mli +++ /dev/null @@ -1,142 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Measurement of the cost (including cost in space) of Flambda terms - in the context of inlining. *) - -module Threshold : sig - - (** The maximum size, in some abstract measure of space cost, that an - Flambda expression may be in order to be inlined. *) - type t = - | Never_inline - | Can_inline_if_no_larger_than of int - - val add : t -> t -> t - val sub : t -> t -> t - val min : t -> t -> t - val equal : t -> t -> bool - -end - -(* Determine whether the given Flambda expression has a sufficiently low space - cost so as to fit under the given [inlining_threshold]. The [bonus] is - added to the threshold before evaluation. *) -val can_inline - : Flambda.t - -> Threshold.t - -> bonus:int - -> bool - -(* CR-soon mshinwell for pchambart: I think the name of this function might be - misleading. It should probably reflect the functionality it provides, - not the use to which it is put in another module. *) -(* As for [can_inline], but returns the decision as an inlining threshold. - If [Never_inline] is returned, the expression was too large for the - input [inlining_threshold]. Otherwise, [Can_inline_if_no_larger_than] is - returned, with the constructor argument being the measured estimated size - of the expression. *) -val can_try_inlining - : Flambda.t - -> Threshold.t - -> number_of_arguments:int - -> size_from_approximation:int option - -> Threshold.t - -module Benefit : sig - (* A model of the benefit we gain by removing a particular combination - of operations. Such removals are typically performed by inlining (for - example, [remove_call]) and simplification (for example, [remove_alloc]) - passes. *) - - type t - - val zero : t - val (+) : t -> t -> t - val max : round:int -> t -> t -> t - - val remove_call : t -> t - (* CR-soon mshinwell: [remove_alloc] should take the size of the block - (to account for removal of initializing writes). *) - val remove_alloc : t -> t - val remove_prim : t -> t - val remove_prims : t -> int -> t - val remove_branch : t -> t - val direct_call_of_indirect : t -> t - val requested_inline : t -> size_of:Flambda.t -> t - - val remove_code : Flambda.t -> t -> t - val remove_code_named : Flambda.named -> t -> t - val remove_projection : Projection.t -> t -> t - - val add_code : Flambda.t -> t -> t - val add_code_named : Flambda.named -> t -> t - val add_projection : Projection.t -> t -> t - - val print : Format.formatter -> t -> unit -end - -module Whether_sufficient_benefit : sig - (* Evaluation of the benefit of removing certain operations against an - inlining threshold. *) - - type t - - val create - : original:Flambda.t - -> toplevel:bool - -> branch_depth:int - -> Flambda.t - -> benefit:Benefit.t - -> lifting:bool - -> round:int - -> t - - val create_estimate - : original_size:int - -> toplevel:bool - -> branch_depth: int - -> new_size:int - -> benefit:Benefit.t - -> lifting:bool - -> round:int - -> t - - val evaluate : t -> bool - - val to_string : t -> string - - val print_description : subfunctions:bool -> Format.formatter -> t -> unit -end - -val scale_inline_threshold_by : int - -val default_toplevel_multiplier : int - -val direct_call_size : int - -(** If a function body exceeds this size, we can make a fast decision not - to inline it (see [Inlining_decision]). *) -val maximum_interesting_size_of_function_body : int -> int - -(** Measure the given expression to determine whether its size is at or - below the given threshold. [None] is returned if it is too big; otherwise - [Some] is returned with the measured size. *) -val lambda_smaller' : Flambda.expr -> than:int -> int option - -val lambda_size : Flambda.expr -> int diff --git a/middle_end/inlining_decision.ml b/middle_end/inlining_decision.ml deleted file mode 100755 index ca462a56..00000000 --- a/middle_end/inlining_decision.ml +++ /dev/null @@ -1,741 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module A = Simple_value_approx -module E = Inline_and_simplify_aux.Env -module R = Inline_and_simplify_aux.Result -module W = Inlining_cost.Whether_sufficient_benefit -module T = Inlining_cost.Threshold -module S = Inlining_stats_types -module D = S.Decision - -let get_function_body (function_decl : A.function_declaration) = - match function_decl.function_body with - | None -> assert false - | Some function_body -> function_body - -type ('a, 'b) inlining_result = - | Changed of (Flambda.t * R.t) * 'a - | Original of 'b - -type 'b good_idea = - | Try_it - | Don't_try_it of 'b - -let inline env r ~lhs_of_application - ~closure_id_being_applied - ~(function_decl : A.function_declaration) - ~(function_body : A.function_body) - ~value_set_of_closures ~only_use_of_function ~original ~recursive - ~(args : Variable.t list) ~size_from_approximation ~dbg ~simplify - ~(inline_requested : Lambda.inline_attribute) - ~(specialise_requested : Lambda.specialise_attribute) - ~fun_vars ~set_of_closures_origin - ~self_call ~fun_cost ~inlining_threshold = - let toplevel = E.at_toplevel env in - let branch_depth = E.branch_depth env in - let unrolling, always_inline, never_inline, env = - let unrolling = E.actively_unrolling env set_of_closures_origin in - match unrolling with - | Some count -> - if count > 0 then - let env = E.continue_actively_unrolling env set_of_closures_origin in - true, true, false, env - else false, false, true, env - | None -> begin - let inline_annotation = - (* Merge call site annotation and function annotation. - The call site annotation takes precedence *) - match (inline_requested : Lambda.inline_attribute) with - | Always_inline | Never_inline | Unroll _ -> inline_requested - | Default_inline -> function_body.inline - in - match inline_annotation with - | Always_inline -> false, true, false, env - | Never_inline -> false, false, true, env - | Default_inline -> false, false, false, env - | Unroll count -> - if count > 0 then - let env = - E.start_actively_unrolling - env set_of_closures_origin (count - 1) - in - true, true, false, env - else false, false, true, env - end - in - let remaining_inlining_threshold : Inlining_cost.Threshold.t = - if always_inline then inlining_threshold - else Lazy.force fun_cost - in - let try_inlining = - if unrolling then - Try_it - else if self_call then - Don't_try_it S.Not_inlined.Self_call - else if not (E.inlining_allowed env function_decl.closure_origin) then - Don't_try_it S.Not_inlined.Unrolling_depth_exceeded - else if only_use_of_function || always_inline then - Try_it - else if never_inline then - Don't_try_it S.Not_inlined.Annotation - else if not (E.unrolling_allowed env set_of_closures_origin) - && (Lazy.force recursive) then - Don't_try_it S.Not_inlined.Unrolling_depth_exceeded - else if T.equal remaining_inlining_threshold T.Never_inline then - let threshold = - match inlining_threshold with - | T.Never_inline -> assert false - | T.Can_inline_if_no_larger_than threshold -> threshold - in - Don't_try_it (S.Not_inlined.Above_threshold threshold) - else if not (toplevel && branch_depth = 0) - && A.all_not_useful (E.find_list_exn env args) then - (* When all of the arguments to the function being inlined are unknown, - then we cannot materially simplify the function. As such, we know - what the benefit of inlining it would be: just removing the call. - In this case we may be able to prove the function cannot be inlined - without traversing its body. - Note that if the function is sufficiently small, we still have to call - [simplify], because the body needs freshening before substitution. - *) - (* CR-someday mshinwell: (from GPR#8): pchambart writes: - - We may need to think a bit about that. I can't see a lot of - meaningful examples right now, but there are some cases where some - optimization can happen even if we don't know anything about the - shape of the arguments. - - For instance - - let f x y = x - - let g x = - let y = (x,x) in - f x y - let f x y = - if x = y then ... else ... - - let g x = f x x - *) - match size_from_approximation with - | Some body_size -> - let wsb = - let benefit = Inlining_cost.Benefit.zero in - let benefit = Inlining_cost.Benefit.remove_call benefit in - let benefit = - Variable.Set.fold (fun v acc -> - try - let t = - Var_within_closure.Map.find (Var_within_closure.wrap v) - value_set_of_closures.A.bound_vars - in - match t.A.var with - | Some v -> - if (E.mem env v) then Inlining_cost.Benefit.remove_prim acc - else acc - | None -> acc - with Not_found -> acc) - function_body.free_variables benefit - in - W.create_estimate - ~original_size:Inlining_cost.direct_call_size - ~new_size:body_size - ~toplevel:(E.at_toplevel env) - ~branch_depth:(E.branch_depth env) - ~lifting:function_body.A.is_a_functor - ~round:(E.round env) - ~benefit - in - if (not (W.evaluate wsb)) then begin - Don't_try_it - (S.Not_inlined.Without_subfunctions wsb) - end else Try_it - | None -> - (* The function is definitely too large to inline given that we don't - have any approximations for its arguments. Further, the body - should already have been simplified (inside its declaration), so - we also expect no gain from the code below that permits inlining - inside the body. *) - Don't_try_it S.Not_inlined.No_useful_approximations - else begin - (* There are useful approximations, so we should simplify. *) - Try_it - end - in - match try_inlining with - | Don't_try_it decision -> Original decision - | Try_it -> - let r = - R.set_inlining_threshold r (Some remaining_inlining_threshold) - in - let body, r_inlined = - (* First we construct the code that would result from copying the body of - the function, without doing any further inlining upon it, to the call - site. *) - Inlining_transforms.inline_by_copying_function_body ~env - ~r:(R.reset_benefit r) ~lhs_of_application - ~closure_id_being_applied ~specialise_requested ~inline_requested - ~function_decl ~function_body ~fun_vars ~args ~dbg ~simplify - in - let num_direct_applications_seen = - (R.num_direct_applications r_inlined) - (R.num_direct_applications r) - in - assert (num_direct_applications_seen >= 0); - let keep_inlined_version decision = - (* Inlining the body of the function was sufficiently beneficial that we - will keep it, replacing the call site. We continue by allowing - further inlining within the inlined copy of the body. *) - let r_inlined = - (* The meaning of requesting inlining is that the user ensure - that the function has a benefit of at least its size. It is not - added to the benefit exposed by the inlining because the user should - have taken that into account before annotating the function. *) - if always_inline then - R.map_benefit r_inlined - (Inlining_cost.Benefit.max ~round:(E.round env) - Inlining_cost.Benefit.(requested_inline ~size_of:body zero)) - else r_inlined - in - let r = - R.map_benefit r_inlined (Inlining_cost.Benefit.(+) (R.benefit r)) - in - let env = E.note_entering_inlined env in - let env = - (* We decrement the unrolling count even if the function is not - recursive to avoid having to check whether or not it is recursive *) - E.inside_unrolled_function env set_of_closures_origin - in - let env = E.inside_inlined_function env function_decl.closure_origin in - let env = - if E.inlining_level env = 0 - (* If the function was considered for inlining without considering - its sub-functions, and it is not below another inlining choice, - then we are certain that this code will be kept. *) - then env - else E.inlining_level_up env - in - Changed ((simplify env r body), decision) - in - if always_inline then - keep_inlined_version S.Inlined.Annotation - else if only_use_of_function then - keep_inlined_version S.Inlined.Decl_local_to_application - else begin - let wsb = - W.create ~original body - ~toplevel:(E.at_toplevel env) - ~branch_depth:(E.branch_depth env) - ~lifting:function_body.is_a_functor - ~round:(E.round env) - ~benefit:(R.benefit r_inlined) - in - if W.evaluate wsb then - keep_inlined_version (S.Inlined.Without_subfunctions wsb) - else if num_direct_applications_seen < 1 then begin - (* Inlining the body of the function did not appear sufficiently - beneficial; however, it may become so if we inline within the body - first. We try that next, unless it is known that there were - no direct applications in the simplified body computed above, meaning - no opportunities for inlining. *) - Original (S.Not_inlined.Without_subfunctions wsb) - end else begin - let env = E.inlining_level_up env in - let env = E.note_entering_inlined env in - let env = - (* We decrement the unrolling count even if the function is recursive - to avoid having to check whether or not it is recursive *) - E.inside_unrolled_function env set_of_closures_origin - in - let body, r_inlined = simplify env r_inlined body in - let wsb_with_subfunctions = - W.create ~original body - ~toplevel:(E.at_toplevel env) - ~branch_depth:(E.branch_depth env) - ~lifting:function_body.is_a_functor - ~round:(E.round env) - ~benefit:(R.benefit r_inlined) - in - if W.evaluate wsb_with_subfunctions then begin - let res = - (body, R.map_benefit r_inlined - (Inlining_cost.Benefit.(+) (R.benefit r))) - in - let decision = - S.Inlined.With_subfunctions (wsb, wsb_with_subfunctions) - in - Changed (res, decision) - end - else begin - (* r_inlined contains an approximation that may be invalid for the - untransformed expression: it may reference functions that only - exists if the body of the function is in fact inlined. - If the function approximation contained an approximation that - does not depend on the actual values of its arguments, it - could be returned instead of [A.value_unknown]. *) - let decision = - S.Not_inlined.With_subfunctions (wsb, wsb_with_subfunctions) - in - Original decision - end - end - end - -let specialise env r ~lhs_of_application - ~(function_decls : A.function_declarations) - ~(function_decl : A.function_declaration) - ~closure_id_being_applied - ~(value_set_of_closures : A.value_set_of_closures) - ~args ~args_approxs ~dbg ~simplify ~original ~recursive ~self_call - ~inlining_threshold ~fun_cost - ~inline_requested ~specialise_requested = - let invariant_params = value_set_of_closures.invariant_params in - let free_vars = value_set_of_closures.free_vars in - let has_no_useful_approxes = - lazy - (List.for_all2 - (fun id approx -> - not ((A.useful approx) - && Variable.Map.mem id (Lazy.force invariant_params))) - (Parameter.List.vars function_decl.params) args_approxs) - in - let always_specialise, never_specialise = - (* Merge call site annotation and function annotation. - The call site annotation takes precedence *) - match (specialise_requested : Lambda.specialise_attribute) with - | Always_specialise -> true, false - | Never_specialise -> false, true - | Default_specialise -> begin - match function_decl.function_body with - | None -> false, true - | Some { specialise } -> - match (specialise : Lambda.specialise_attribute) with - | Always_specialise -> true, false - | Never_specialise -> false, true - | Default_specialise -> false, false - end - in - let remaining_inlining_threshold : Inlining_cost.Threshold.t = - if always_specialise then inlining_threshold - else Lazy.force fun_cost - in - let try_specialising = - (* Try specialising if the function: - - is recursive; and - - is closed (it and all other members of the set of closures on which - it depends); and - - has useful approximations for some invariant parameters. *) - if function_decls.is_classic_mode then - Don't_try_it S.Not_specialised.Classic_mode - else if self_call then - Don't_try_it S.Not_specialised.Self_call - else if always_specialise && not (Lazy.force has_no_useful_approxes) then - Try_it - else if never_specialise then - Don't_try_it S.Not_specialised.Annotation - else if T.equal remaining_inlining_threshold T.Never_inline then - let threshold = - match inlining_threshold with - | T.Never_inline -> assert false - | T.Can_inline_if_no_larger_than threshold -> threshold - in - Don't_try_it (S.Not_specialised.Above_threshold threshold) - else if not (Variable.Map.is_empty free_vars) then - Don't_try_it S.Not_specialised.Not_closed - else if not (Lazy.force recursive) then - Don't_try_it S.Not_specialised.Not_recursive - else if Variable.Map.is_empty (Lazy.force invariant_params) then - Don't_try_it S.Not_specialised.No_invariant_parameters - else if Lazy.force has_no_useful_approxes then - Don't_try_it S.Not_specialised.No_useful_approximations - else Try_it - in - match try_specialising with - | Don't_try_it decision -> Original decision - | Try_it -> begin - let r = - R.set_inlining_threshold r (Some remaining_inlining_threshold) - in - let copied_function_declaration = - Inlining_transforms.inline_by_copying_function_declaration ~env - ~r:(R.reset_benefit r) ~lhs_of_application - ~function_decls ~closure_id_being_applied ~function_decl - ~args ~args_approxs - ~invariant_params:invariant_params - ~specialised_args:value_set_of_closures.specialised_args - ~free_vars:value_set_of_closures.free_vars - ~direct_call_surrogates:value_set_of_closures.direct_call_surrogates - ~dbg ~simplify ~inline_requested - in - match copied_function_declaration with - | Some (expr, r_inlined) -> - let wsb = - W.create ~original expr - ~toplevel:false - ~branch_depth:(E.branch_depth env) - ~lifting:false - ~round:(E.round env) - ~benefit:(R.benefit r_inlined) - in - let env = - (* CR-someday lwhite: could avoid calculating this if stats is turned - off *) - let closure_ids = - Closure_id.Set.of_list ( - List.map Closure_id.wrap - (Variable.Set.elements (Variable.Map.keys function_decls.funs))) - in - E.note_entering_specialised env ~closure_ids - in - if always_specialise || W.evaluate wsb then begin - let r_inlined = - if always_specialise then - R.map_benefit r_inlined - (Inlining_cost.Benefit.max ~round:(E.round env) - Inlining_cost.Benefit.(requested_inline ~size_of:expr zero)) - else r_inlined - in - let r = - R.map_benefit r_inlined (Inlining_cost.Benefit.(+) (R.benefit r)) - in - let closure_env = - let env = - if E.inlining_level env = 0 - (* If the function was considered for specialising without - considering its sub-functions, and it is not below another - inlining choice, then we are certain that this code will - be kept. *) - then env - else E.inlining_level_up env - in - E.set_never_inline_outside_closures env - in - let application_env = E.set_never_inline_inside_closures env in - let expr, r = simplify closure_env r expr in - let res = simplify application_env r expr in - let decision = - if always_specialise then S.Specialised.Annotation - else S.Specialised.Without_subfunctions wsb - in - Changed (res, decision) - end else begin - let closure_env = - let env = E.inlining_level_up env in - E.set_never_inline_outside_closures env - in - let expr, r_inlined = simplify closure_env r_inlined expr in - let wsb_with_subfunctions = - W.create ~original expr - ~toplevel:false - ~branch_depth:(E.branch_depth env) - ~lifting:false - ~round:(E.round env) - ~benefit:(R.benefit r_inlined) - in - if W.evaluate wsb_with_subfunctions then begin - let r = - R.map_benefit r_inlined - (Inlining_cost.Benefit.(+) (R.benefit r)) - in - let application_env = E.set_never_inline_inside_closures env in - let res = simplify application_env r expr in - let decision = - S.Specialised.With_subfunctions (wsb, wsb_with_subfunctions) - in - Changed (res, decision) - end else begin - let decision = - S.Not_specialised.Not_beneficial (wsb, wsb_with_subfunctions) - in - Original decision - end - end - | None -> - let decision = S.Not_specialised.No_useful_approximations in - Original decision - end - -let for_call_site ~env ~r ~(function_decls : A.function_declarations) - ~lhs_of_application ~closure_id_being_applied - ~(function_decl : A.function_declaration) - ~(value_set_of_closures : A.value_set_of_closures) - ~args ~args_approxs ~dbg ~simplify ~inline_requested - ~specialise_requested = - if List.length args <> List.length args_approxs then begin - Misc.fatal_error "Inlining_decision.for_call_site: inconsistent lengths \ - of [args] and [args_approxs]" - end; - (* Remove unroll attributes from functions we are already actively - unrolling, otherwise they'll be unrolled again next round. *) - let inline_requested : Lambda.inline_attribute = - match (inline_requested : Lambda.inline_attribute) with - | Unroll _ -> begin - let unrolling = - E.actively_unrolling env function_decls.set_of_closures_origin - in - match unrolling with - | Some _ -> Default_inline - | None -> inline_requested - end - | Always_inline | Default_inline | Never_inline -> - inline_requested - in - let original = - Flambda.Apply { - func = lhs_of_application; - args; - kind = Direct closure_id_being_applied; - dbg; - inline = inline_requested; - specialise = specialise_requested; - } - in - let original_r = - R.set_approx (R.seen_direct_application r) (A.value_unknown Other) - in - match function_decl.function_body with - | None -> original, original_r - | Some { stub; _ } -> - if stub then begin - let fun_vars = Variable.Map.keys function_decls.funs in - let function_body = get_function_body function_decl in - let body, r = - Inlining_transforms.inline_by_copying_function_body ~env - ~r ~fun_vars ~lhs_of_application - ~closure_id_being_applied ~specialise_requested ~inline_requested - ~function_decl ~function_body ~args ~dbg ~simplify - in - simplify env r body - end else if E.never_inline env then - (* This case only occurs when examining the body of a stub function - but not in the context of inlining said function. As such, there - is nothing to do here (and no decision to report). *) - original, original_r - else if function_decls.is_classic_mode then begin - let env = - E.note_entering_call env - ~closure_id:closure_id_being_applied ~dbg:dbg - in - let simpl = - match function_decl.function_body with - | None -> Original S.Not_inlined.Classic_mode - | Some function_body -> - let self_call = - E.inside_set_of_closures_declaration - function_decls.set_of_closures_origin env - in - let try_inlining = - if self_call then - Don't_try_it S.Not_inlined.Self_call - else - if not (E.inlining_allowed env function_decl.closure_origin) then - Don't_try_it S.Not_inlined.Unrolling_depth_exceeded - else - Try_it - in - match try_inlining with - | Don't_try_it decision -> Original decision - | Try_it -> - let fun_vars = Variable.Map.keys function_decls.funs in - let body, r = - Inlining_transforms.inline_by_copying_function_body ~env - ~r ~function_body ~lhs_of_application - ~closure_id_being_applied ~specialise_requested - ~inline_requested ~function_decl ~fun_vars ~args ~dbg ~simplify - in - let env = E.note_entering_inlined env in - let env = - (* We decrement the unrolling count even if the function is not - recursive to avoid having to check whether or not it is - recursive *) - E.inside_unrolled_function env - function_decls.set_of_closures_origin - in - let env = - E.inside_inlined_function env function_decl.closure_origin - in - Changed ((simplify env r body), S.Inlined.Classic_mode) - in - let res, decision = - match simpl with - | Original decision -> - let decision = - S.Decision.Unchanged (S.Not_specialised.Classic_mode, decision) - in - (original, original_r), decision - | Changed ((expr, r), decision) -> - let max_inlining_threshold = - if E.at_toplevel env then - Inline_and_simplify_aux.initial_inlining_toplevel_threshold - ~round:(E.round env) - else - Inline_and_simplify_aux.initial_inlining_threshold - ~round:(E.round env) - in - let raw_inlining_threshold = R.inlining_threshold r in - let unthrottled_inlining_threshold = - match raw_inlining_threshold with - | None -> max_inlining_threshold - | Some inlining_threshold -> inlining_threshold - in - let inlining_threshold = - T.min unthrottled_inlining_threshold max_inlining_threshold - in - let inlining_threshold_diff = - T.sub unthrottled_inlining_threshold inlining_threshold - in - let res = - if E.inlining_level env = 0 - then expr, R.set_inlining_threshold r raw_inlining_threshold - else expr, R.add_inlining_threshold r inlining_threshold_diff - in - res, S.Decision.Inlined (S.Not_specialised.Classic_mode, decision) - in - E.record_decision env decision; - res - end else begin - let function_body = get_function_body function_decl in - let env = E.unset_never_inline_inside_closures env in - let env = - E.note_entering_call env - ~closure_id:closure_id_being_applied ~dbg:dbg - in - let max_level = - Clflags.Int_arg_helper.get ~key:(E.round env) !Clflags.inline_max_depth - in - let raw_inlining_threshold = R.inlining_threshold r in - let max_inlining_threshold = - if E.at_toplevel env then - Inline_and_simplify_aux.initial_inlining_toplevel_threshold - ~round:(E.round env) - else - Inline_and_simplify_aux.initial_inlining_threshold - ~round:(E.round env) - in - let unthrottled_inlining_threshold = - match raw_inlining_threshold with - | None -> max_inlining_threshold - | Some inlining_threshold -> inlining_threshold - in - let inlining_threshold = - T.min unthrottled_inlining_threshold max_inlining_threshold - in - let inlining_threshold_diff = - T.sub unthrottled_inlining_threshold inlining_threshold - in - let inlining_prevented = - match inlining_threshold with - | Never_inline -> true - | Can_inline_if_no_larger_than _ -> false - in - let simpl = - if inlining_prevented then - Original (D.Prevented Function_prevented_from_inlining) - else if E.inlining_level env >= max_level then - Original (D.Prevented Level_exceeded) - else begin - let self_call = - E.inside_set_of_closures_declaration - function_decls.set_of_closures_origin env - in - let fun_cost = - lazy - (Inlining_cost.can_try_inlining function_body.body - inlining_threshold - ~number_of_arguments:(List.length function_decl.params) - (* CR-someday mshinwell: for the moment, this is None, since - the Inlining_cost code isn't checking sizes up to the max - inlining threshold---this seems to take too long. *) - ~size_from_approximation:None) - in - let recursive = - lazy - (let fun_var = Closure_id.unwrap closure_id_being_applied in - Variable.Set.mem fun_var - (Lazy.force value_set_of_closures.recursive)) - in - let specialise_result = - specialise env r - ~function_decls ~function_decl - ~lhs_of_application ~recursive ~closure_id_being_applied - ~value_set_of_closures ~args ~args_approxs ~dbg ~simplify - ~original ~inline_requested ~specialise_requested ~fun_cost - ~self_call ~inlining_threshold - in - match specialise_result with - | Changed (res, spec_reason) -> - Changed (res, D.Specialised spec_reason) - | Original spec_reason -> - let only_use_of_function = false in - (* If we didn't specialise then try inlining *) - let size_from_approximation = - let fun_var = Closure_id.unwrap closure_id_being_applied in - match - Variable.Map.find fun_var - (Lazy.force value_set_of_closures.size) - with - | size -> size - | exception Not_found -> - Misc.fatal_errorf "Approximation does not give a size for the \ - function having fun_var %a. \ - value_set_of_closures: %a" - Variable.print fun_var - A.print_value_set_of_closures value_set_of_closures - in - let fun_vars = Variable.Map.keys function_decls.funs in - let set_of_closures_origin = - function_decls.set_of_closures_origin - in - let inline_result = - inline env r ~lhs_of_application - ~closure_id_being_applied ~function_decl ~value_set_of_closures - ~only_use_of_function ~original ~recursive - ~inline_requested ~specialise_requested - ~fun_vars ~set_of_closures_origin ~args - ~size_from_approximation ~dbg ~simplify ~fun_cost ~self_call - ~inlining_threshold ~function_body - in - match inline_result with - | Changed (res, inl_reason) -> - Changed (res, D.Inlined (spec_reason, inl_reason)) - | Original inl_reason -> - Original (D.Unchanged (spec_reason, inl_reason)) - end - in - let res, decision = - match simpl with - | Original decision -> (original, original_r), decision - | Changed ((expr, r), decision) -> - let res = - if E.inlining_level env = 0 - then expr, R.set_inlining_threshold r raw_inlining_threshold - else expr, R.add_inlining_threshold r inlining_threshold_diff - in - res, decision - in - E.record_decision env decision; - res - end - -(* We do not inline inside stubs, which are always inlined at their call site. - Inlining inside the declaration of a stub could result in more code than - expected being inlined (e.g. the body of a function that was transformed - by adding the stub). *) -let should_inline_inside_declaration (decl : Flambda.function_declaration) = - not decl.stub diff --git a/middle_end/inlining_decision.mli b/middle_end/inlining_decision.mli deleted file mode 100644 index 3694e303..00000000 --- a/middle_end/inlining_decision.mli +++ /dev/null @@ -1,43 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** See the Flambda manual chapter for an explanation in prose of the - inlining decision procedure. *) - -(** Try to inline a full application of a known function, guided by various - heuristics. *) -val for_call_site - : env:Inline_and_simplify_aux.Env.t - -> r:Inline_and_simplify_aux.Result.t - -> function_decls:Simple_value_approx.function_declarations - -> lhs_of_application:Variable.t - -> closure_id_being_applied:Closure_id.t - -> function_decl:Simple_value_approx.function_declaration - -> value_set_of_closures:Simple_value_approx.value_set_of_closures - -> args:Variable.t list - -> args_approxs:Simple_value_approx.t list - -> dbg:Debuginfo.t - -> simplify:Inlining_decision_intf.simplify - -> inline_requested:Lambda.inline_attribute - -> specialise_requested:Lambda.specialise_attribute - -> Flambda.t * Inline_and_simplify_aux.Result.t - -(** When a function declaration is encountered by [for_call_site], the body - may be subject to inlining immediately, thus changing the declaration. - This function must return [true] for that to be able to happen. *) -val should_inline_inside_declaration : Flambda.function_declaration -> bool diff --git a/middle_end/inlining_decision_intf.mli b/middle_end/inlining_decision_intf.mli deleted file mode 100644 index 15a08031..00000000 --- a/middle_end/inlining_decision_intf.mli +++ /dev/null @@ -1,49 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(* CR-someday mshinwell: name of this source file could now be improved *) - -type 'a by_copying_function_body = - env:Inline_and_simplify_aux.Env.t - -> r:Inline_and_simplify_aux.Result.t - -> clos:Flambda.function_declarations - -> lfunc:Flambda.t - -> fun_id:Closure_id.t - -> func:Flambda.function_declaration - -> args:Flambda.t list - -> Flambda.t * Inline_and_simplify_aux.Result.t - -type 'a by_copying_function_declaration = - env:Inline_and_simplify_aux.Env.t - -> r:Inline_and_simplify_aux.Result.t - -> funct:Flambda.t - -> clos:Flambda.function_declarations - -> fun_id:Closure_id.t - -> func:Flambda.function_declaration - -> args_with_approxs: - (Flambda.t list) * (Simple_value_approx.t list) - -> invariant_params:Variable.Set.t - -> specialised_args:Variable.Set.t - -> dbg:Debuginfo.t - -> (Flambda.t * Inline_and_simplify_aux.Result.t) option - -type simplify = - Inline_and_simplify_aux.Env.t - -> Inline_and_simplify_aux.Result.t - -> Flambda.t - -> Flambda.t * Inline_and_simplify_aux.Result.t diff --git a/middle_end/inlining_stats.ml b/middle_end/inlining_stats.ml deleted file mode 100644 index 6809d4cb..00000000 --- a/middle_end/inlining_stats.ml +++ /dev/null @@ -1,252 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module Closure_stack = struct - type t = node list - - and node = - | Closure of Closure_id.t * Debuginfo.t - | Call of Closure_id.t * Debuginfo.t - | Inlined - | Specialised of Closure_id.Set.t - - let create () = [] - - let note_entering_closure t ~closure_id ~dbg = - if not !Clflags.inlining_report then t - else - match t with - | [] | (Closure _ | Inlined | Specialised _) :: _-> - (Closure (closure_id, dbg)) :: t - | (Call _) :: _ -> - Misc.fatal_errorf "note_entering_closure: unexpected Call node" - - (* CR-someday lwhite: since calls do not have a unique id it is possible - some calls will end up sharing nodes. *) - let note_entering_call t ~closure_id ~dbg = - if not !Clflags.inlining_report then t - else - match t with - | [] | (Closure _ | Inlined | Specialised _) :: _ -> - (Call (closure_id, dbg)) :: t - | (Call _) :: _ -> - Misc.fatal_errorf "note_entering_call: unexpected Call node" - - let note_entering_inlined t = - if not !Clflags.inlining_report then t - else - match t with - | [] | (Closure _ | Inlined | Specialised _) :: _-> - Misc.fatal_errorf "note_entering_inlined: missing Call node" - | (Call _) :: _ -> Inlined :: t - - let note_entering_specialised t ~closure_ids = - if not !Clflags.inlining_report then t - else - match t with - | [] | (Closure _ | Inlined | Specialised _) :: _ -> - Misc.fatal_errorf "note_entering_specialised: missing Call node" - | (Call _) :: _ -> Specialised closure_ids :: t - -end - -let log - : (Closure_stack.t * Inlining_stats_types.Decision.t) list ref - = ref [] - -let record_decision decision ~closure_stack = - if !Clflags.inlining_report then begin - match closure_stack with - | [] - | Closure_stack.Closure _ :: _ - | Closure_stack.Inlined :: _ - | Closure_stack.Specialised _ :: _ -> - Misc.fatal_errorf "record_decision: missing Call node" - | Closure_stack.Call _ :: _ -> - log := (closure_stack, decision) :: !log - end - -module Inlining_report = struct - - module Place = struct - type kind = - | Closure - | Call - - type t = Debuginfo.t * Closure_id.t * kind - - let compare ((d1, cl1, k1) : t) ((d2, cl2, k2) : t) = - let c = Debuginfo.compare d1 d2 in - if c <> 0 then c else - let c = Closure_id.compare cl1 cl2 in - if c <> 0 then c else - match k1, k2 with - | Closure, Closure -> 0 - | Call, Call -> 0 - | Closure, Call -> 1 - | Call, Closure -> -1 - end - - module Place_map = Map.Make(Place) - - type t = node Place_map.t - - and node = - | Closure of t - | Call of call - - and call = - { decision: Inlining_stats_types.Decision.t option; - inlined: t option; - specialised: t option; } - - let empty_call = - { decision = None; - inlined = None; - specialised = None; } - - (* Prevented or unchanged decisions may be overridden by a later look at the - same call. Other decisions may also be "overridden" because calls are not - uniquely identified. *) - let add_call_decision call (decision : Inlining_stats_types.Decision.t) = - match call.decision, decision with - | None, _ -> { call with decision = Some decision } - | Some _, Prevented _ -> call - | Some (Prevented _), _ -> { call with decision = Some decision } - | Some (Specialised _), _ -> call - | Some _, Specialised _ -> { call with decision = Some decision } - | Some (Inlined _), _ -> call - | Some _, Inlined _ -> { call with decision = Some decision } - | Some Unchanged _, Unchanged _ -> call - - let add_decision t (stack, decision) = - let rec loop t : Closure_stack.t -> _ = function - | Closure(cl, dbg) :: rest -> - let key : Place.t = (dbg, cl, Closure) in - let v = - try - match Place_map.find key t with - | Closure v -> v - | Call _ -> assert false - with Not_found -> Place_map.empty - in - let v = loop v rest in - Place_map.add key (Closure v) t - | Call(cl, dbg) :: rest -> - let key : Place.t = (dbg, cl, Call) in - let v = - try - match Place_map.find key t with - | Call v -> v - | Closure _ -> assert false - with Not_found -> empty_call - in - let v = - match rest with - | [] -> add_call_decision v decision - | Inlined :: rest -> - let inlined = - match v.inlined with - | None -> Place_map.empty - | Some inlined -> inlined - in - let inlined = loop inlined rest in - { v with inlined = Some inlined } - | Specialised _ :: rest -> - let specialised = - match v.specialised with - | None -> Place_map.empty - | Some specialised -> specialised - in - let specialised = loop specialised rest in - { v with specialised = Some specialised } - | Call _ :: _ -> assert false - | Closure _ :: _ -> assert false - in - Place_map.add key (Call v) t - | [] -> assert false - | Inlined :: _ -> assert false - | Specialised _ :: _ -> assert false - in - loop t (List.rev stack) - - let build log = - List.fold_left add_decision Place_map.empty log - - let print_stars ppf n = - let s = String.make n '*' in - Format.fprintf ppf "%s" s - - let rec print ~depth ppf t = - Place_map.iter (fun (dbg, cl, _) v -> - match v with - | Closure t -> - Format.fprintf ppf "@[%a Definition of %a%s@]@." - print_stars (depth + 1) - Closure_id.print cl - (Debuginfo.to_string dbg); - print ppf ~depth:(depth + 1) t; - if depth = 0 then Format.pp_print_newline ppf () - | Call c -> - match c.decision with - | None -> - Misc.fatal_error "Inlining_report.print: missing call decision" - | Some decision -> - Format.pp_open_vbox ppf (depth + 2); - Format.fprintf ppf "@[%a Application of %a%s@]@;@;@[%a@]" - print_stars (depth + 1) - Closure_id.print cl - (Debuginfo.to_string dbg) - Inlining_stats_types.Decision.summary decision; - Format.pp_close_box ppf (); - Format.pp_print_newline ppf (); - Format.pp_print_newline ppf (); - Inlining_stats_types.Decision.calculation ~depth:(depth + 1) - ppf decision; - begin - match c.specialised with - | None -> () - | Some specialised -> - print ppf ~depth:(depth + 1) specialised - end; - begin - match c.inlined with - | None -> () - | Some inlined -> - print ppf ~depth:(depth + 1) inlined - end; - if depth = 0 then Format.pp_print_newline ppf ()) - t - - let print ppf t = print ~depth:0 ppf t - -end - -let really_save_then_forget_decisions ~output_prefix = - let report = Inlining_report.build !log in - let out_channel = open_out (output_prefix ^ ".inlining.org") in - let ppf = Format.formatter_of_out_channel out_channel in - Inlining_report.print ppf report; - close_out out_channel; - log := [] - -let save_then_forget_decisions ~output_prefix = - if !Clflags.inlining_report then begin - really_save_then_forget_decisions ~output_prefix - end diff --git a/middle_end/inlining_stats.mli b/middle_end/inlining_stats.mli deleted file mode 100644 index f1e84fdc..00000000 --- a/middle_end/inlining_stats.mli +++ /dev/null @@ -1,46 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -module Closure_stack : sig - type t - - val create : unit -> t - - val note_entering_closure - : t - -> closure_id:Closure_id.t - -> dbg:Debuginfo.t - -> t - - val note_entering_call - : t - -> closure_id:Closure_id.t - -> dbg:Debuginfo.t - -> t - - val note_entering_inlined : t -> t - val note_entering_specialised : t -> closure_ids:Closure_id.Set.t -> t - -end - -val record_decision - : Inlining_stats_types.Decision.t - -> closure_stack:Closure_stack.t - -> unit - -val save_then_forget_decisions : output_prefix:string -> unit diff --git a/middle_end/inlining_stats_types.ml b/middle_end/inlining_stats_types.ml deleted file mode 100644 index 7aef0796..00000000 --- a/middle_end/inlining_stats_types.ml +++ /dev/null @@ -1,290 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module Wsb = Inlining_cost.Whether_sufficient_benefit - -let print_stars ppf n = - let s = String.make n '*' in - Format.fprintf ppf "%s" s - -let print_calculation ~depth ~title ~subfunctions ppf wsb = - Format.pp_open_vbox ppf (depth + 2); - Format.fprintf ppf "@[%a %s@]@;@;@[%a@]" - print_stars (depth + 1) - title - (Wsb.print_description ~subfunctions) wsb; - Format.pp_close_box ppf (); - Format.pp_print_newline ppf (); - Format.pp_print_newline ppf () - -module Inlined = struct - - type t = - | Classic_mode - | Annotation - | Decl_local_to_application - | Without_subfunctions of Wsb.t - | With_subfunctions of Wsb.t * Wsb.t - - let summary ppf = function - | Classic_mode -> - Format.pp_print_text ppf - "This function was inlined because it was small enough \ - to be inlined in `-Oclassic'" - | Annotation -> - Format.pp_print_text ppf - "This function was inlined because of an annotation." - | Decl_local_to_application -> - Format.pp_print_text ppf - "This function was inlined because it was local to this application." - | Without_subfunctions _ -> - Format.pp_print_text ppf - "This function was inlined because \ - the expected benefit outweighed the change in code size." - | With_subfunctions _ -> - Format.pp_print_text ppf - "This function was inlined because \ - the expected benefit outweighed the change in code size." - - let calculation ~depth ppf = function - | Classic_mode -> () - | Annotation -> () - | Decl_local_to_application -> () - | Without_subfunctions wsb -> - print_calculation - ~depth ~title:"Inlining benefit calculation" - ~subfunctions:false ppf wsb - | With_subfunctions(_, wsb) -> - print_calculation - ~depth ~title:"Inlining benefit calculation" - ~subfunctions:true ppf wsb - -end - -module Not_inlined = struct - type t = - | Classic_mode - | Above_threshold of int - | Annotation - | No_useful_approximations - | Unrolling_depth_exceeded - | Self_call - | Without_subfunctions of Wsb.t - | With_subfunctions of Wsb.t * Wsb.t - - - let summary ppf = function - | Classic_mode -> - Format.pp_print_text ppf - "This function was not inlined because it was too \ - large to be inlined in `-Oclassic'." - | Above_threshold size -> - Format.pp_print_text ppf - "This function was not inlined because \ - it was larger than the current size threshold"; - Format.fprintf ppf "(%i)" size - | Annotation -> - Format.pp_print_text ppf - "This function was not inlined because \ - of an annotation." - | No_useful_approximations -> - Format.pp_print_text ppf - "This function was not inlined because \ - there was no useful information about any of its parameters, \ - and it was not particularly small." - | Unrolling_depth_exceeded -> - Format.pp_print_text ppf - "This function was not inlined because \ - its unrolling depth was exceeded." - | Self_call -> - Format.pp_print_text ppf - "This function was not inlined because \ - it was a self call." - | Without_subfunctions _ -> - Format.pp_print_text ppf - "This function was not inlined because \ - the expected benefit did not outweigh the change in code size." - | With_subfunctions _ -> - Format.pp_print_text ppf - "This function was not inlined because \ - the expected benefit did not outweigh the change in code size." - - let calculation ~depth ppf = function - | Classic_mode - | Above_threshold _ - | Annotation - | No_useful_approximations - | Unrolling_depth_exceeded - | Self_call -> () - | Without_subfunctions wsb -> - print_calculation - ~depth ~title:"Inlining benefit calculation" - ~subfunctions:false ppf wsb - | With_subfunctions(_, wsb) -> - print_calculation - ~depth ~title:"Inlining benefit calculation" - ~subfunctions:true ppf wsb - -end - -module Specialised = struct - type t = - | Annotation - | Without_subfunctions of Wsb.t - | With_subfunctions of Wsb.t * Wsb.t - - let summary ppf = function - | Annotation -> - Format.pp_print_text ppf - "This function was specialised because of an annotation." - | Without_subfunctions _ -> - Format.pp_print_text ppf - "This function was specialised because the expected benefit \ - outweighed the change in code size." - | With_subfunctions _ -> - Format.pp_print_text ppf - "This function was specialised because the expected benefit \ - outweighed the change in code size." - - - let calculation ~depth ppf = function - | Annotation -> () - | Without_subfunctions wsb -> - print_calculation - ~depth ~title:"Specialising benefit calculation" - ~subfunctions:false ppf wsb - | With_subfunctions(_, wsb) -> - print_calculation - ~depth ~title:"Specialising benefit calculation" - ~subfunctions:true ppf wsb -end - -module Not_specialised = struct - type t = - | Classic_mode - | Above_threshold of int - | Annotation - | Not_recursive - | Not_closed - | No_invariant_parameters - | No_useful_approximations - | Self_call - | Not_beneficial of Wsb.t * Wsb.t - - let summary ppf = function - | Classic_mode -> - Format.pp_print_text ppf - "This function was not specialised because it was \ - compiled with `-Oclassic'." - | Above_threshold size -> - Format.pp_print_text ppf - "This function was not specialised because \ - it was larger than the current size threshold"; - Format.fprintf ppf "(%i)" size - | Annotation -> - Format.pp_print_text ppf - "This function was not specialised because \ - of an annotation." - | Not_recursive -> - Format.pp_print_text ppf - "This function was not specialised because \ - it is not recursive." - | Not_closed -> - Format.pp_print_text ppf - "This function was not specialised because \ - it is not closed." - | No_invariant_parameters -> - Format.pp_print_text ppf - "This function was not specialised because \ - it has no invariant parameters." - | No_useful_approximations -> - Format.pp_print_text ppf - "This function was not specialised because \ - there was no useful information about any of its invariant \ - parameters." - | Self_call -> - Format.pp_print_text ppf - "This function was not specialised because \ - it was a self call." - | Not_beneficial _ -> - Format.pp_print_text ppf - "This function was not specialised because \ - the expected benefit did not outweigh the change in code size." - - let calculation ~depth ppf = function - | Classic_mode - | Above_threshold _ - | Annotation - | Not_recursive - | Not_closed - | No_invariant_parameters - | No_useful_approximations - | Self_call -> () - | Not_beneficial(_, wsb) -> - print_calculation - ~depth ~title:"Specialising benefit calculation" - ~subfunctions:true ppf wsb - -end - -module Prevented = struct - type t = - | Function_prevented_from_inlining - | Level_exceeded - - let summary ppf = function - | Function_prevented_from_inlining -> - Format.pp_print_text ppf - "This function was prevented from inlining or specialising." - | Level_exceeded -> - Format.pp_print_text ppf - "This function was prevented from inlining or specialising \ - because the inlining depth was exceeded." -end - -module Decision = struct - type t = - | Prevented of Prevented.t - | Specialised of Specialised.t - | Inlined of Not_specialised.t * Inlined.t - | Unchanged of Not_specialised.t * Not_inlined.t - - let summary ppf = function - | Prevented p -> - Prevented.summary ppf p - | Specialised s -> - Specialised.summary ppf s - | Inlined (s, i) -> - Format.fprintf ppf "@[@[%a@]@;@;@[%a@]@]" - Not_specialised.summary s Inlined.summary i - | Unchanged (s, i) -> - Format.fprintf ppf "@[@[%a@]@;@;@[%a@]@]" - Not_specialised.summary s Not_inlined.summary i - - let calculation ~depth ppf = function - | Prevented _ -> () - | Specialised s -> - Specialised.calculation ~depth ppf s - | Inlined (s, i) -> - Not_specialised.calculation ~depth ppf s; - Inlined.calculation ~depth ppf i - | Unchanged (s, i) -> - Not_specialised.calculation ~depth ppf s; - Not_inlined.calculation ~depth ppf i -end diff --git a/middle_end/inlining_stats_types.mli b/middle_end/inlining_stats_types.mli deleted file mode 100644 index 9d476c89..00000000 --- a/middle_end/inlining_stats_types.mli +++ /dev/null @@ -1,89 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(* Types used for producing statistics about inlining. *) - -module Inlined : sig - type t = - | Classic_mode - | Annotation - | Decl_local_to_application - | Without_subfunctions of - Inlining_cost.Whether_sufficient_benefit.t - | With_subfunctions of - Inlining_cost.Whether_sufficient_benefit.t - * Inlining_cost.Whether_sufficient_benefit.t -end - -module Not_inlined : sig - type t = - | Classic_mode - | Above_threshold of int - | Annotation - | No_useful_approximations - | Unrolling_depth_exceeded - | Self_call - | Without_subfunctions of - Inlining_cost.Whether_sufficient_benefit.t - | With_subfunctions of - Inlining_cost.Whether_sufficient_benefit.t - * Inlining_cost.Whether_sufficient_benefit.t -end - -module Specialised : sig - type t = - | Annotation - | Without_subfunctions of - Inlining_cost.Whether_sufficient_benefit.t - | With_subfunctions of - Inlining_cost.Whether_sufficient_benefit.t - * Inlining_cost.Whether_sufficient_benefit.t -end - -module Not_specialised : sig - type t = - | Classic_mode - | Above_threshold of int - | Annotation - | Not_recursive - | Not_closed - | No_invariant_parameters - | No_useful_approximations - | Self_call - | Not_beneficial of - Inlining_cost.Whether_sufficient_benefit.t - * Inlining_cost.Whether_sufficient_benefit.t -end - -module Prevented : sig - type t = - | Function_prevented_from_inlining - | Level_exceeded -end - -module Decision : sig - - type t = - | Prevented of Prevented.t - | Specialised of Specialised.t - | Inlined of Not_specialised.t * Inlined.t - | Unchanged of Not_specialised.t * Not_inlined.t - - val summary : Format.formatter -> t -> unit - val calculation : depth:int -> Format.formatter -> t -> unit -end diff --git a/middle_end/inlining_transforms.ml b/middle_end/inlining_transforms.ml deleted file mode 100755 index c46a6cbe..00000000 --- a/middle_end/inlining_transforms.ml +++ /dev/null @@ -1,668 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module B = Inlining_cost.Benefit -module E = Inline_and_simplify_aux.Env -module R = Inline_and_simplify_aux.Result -module A = Simple_value_approx - -let new_var name = - Variable.create name - ~current_compilation_unit:(Compilation_unit.get_current_exn ()) - -(** Fold over all variables bound by the given closure, which is bound to the - variable [lhs_of_application], and corresponds to the given - [function_decls]. Each variable bound by the closure is passed to the - user-specified function as an [Flambda.named] value that projects the - variable from its closure. *) -let fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied - ~lhs_of_application ~bound_variables ~init ~f = - Variable.Set.fold (fun var acc -> - let expr : Flambda.named = - Project_var { - closure = lhs_of_application; - closure_id = closure_id_being_applied; - var = Var_within_closure.wrap var; - } - in - f ~acc ~var ~expr) - bound_variables - init - -let set_inline_attribute_on_all_apply body inline specialise = - Flambda_iterators.map_toplevel_expr (function - | Apply apply -> Apply { apply with inline; specialise } - | expr -> expr) - body - -(** Assign fresh names for a function's parameters and rewrite the body to - use these new names. *) -let copy_of_function's_body_with_freshened_params env - ~(function_decl : A.function_declaration) - ~(function_body : A.function_body) = - let params = function_decl.params in - let param_vars = Parameter.List.vars params in - (* We cannot avoid the substitution in the case where we are inlining - inside the function itself. This can happen in two ways: either - (a) we are inlining the function itself directly inside its declaration; - or (b) we are inlining the function into an already-inlined copy. - For (a) we cannot short-cut the substitution by freshening since the - original [params] may still be referenced; for (b) we cannot do it - either since the freshening may already be renaming the parameters for - the first inlining of the function. *) - if E.does_not_bind env param_vars - && E.does_not_freshen env param_vars - then - params, function_body.body - else - let freshened_params = List.map (fun p -> Parameter.rename p) params in - let subst = - Variable.Map.of_list - (List.combine param_vars (Parameter.List.vars freshened_params)) - in - let body = Flambda_utils.toplevel_substitution subst function_body.body in - freshened_params, body - -(* CR-soon mshinwell: Add a note somewhere to explain why "bound by the closure" - does not include the function identifiers for other functions in the same - set of closures. - mshinwell: The terminology may be used inconsistently. *) - -(** Inline a function by copying its body into a context where it becomes - closed. That is to say, we bind the free variables of the body - (= "variables bound by the closure"), and any function identifiers - introduced by the corresponding set of closures. *) -let inline_by_copying_function_body ~env ~r - ~lhs_of_application - ~(inline_requested : Lambda.inline_attribute) - ~(specialise_requested : Lambda.specialise_attribute) - ~closure_id_being_applied - ~(function_decl : A.function_declaration) - ~(function_body : A.function_body) - ~fun_vars - ~args ~dbg ~simplify = - assert (E.mem env lhs_of_application); - assert (List.for_all (E.mem env) args); - let r = - if function_body.stub then r - else R.map_benefit r B.remove_call - in - let freshened_params, body = - copy_of_function's_body_with_freshened_params env - ~function_decl ~function_body - in - let body = - let default_inline = - Lambda.equal_inline_attribute inline_requested Default_inline - in - let default_specialise = - Lambda.equal_specialise_attribute specialise_requested Default_specialise - in - if function_body.stub - && ((not default_inline) || (not default_specialise)) then - (* When the function inlined function is a stub, the annotation - is reported to the function applications inside the stub. - This allows reporting the annotation to the application the - original programmer really intended: the stub is not visible - in the source. *) - set_inline_attribute_on_all_apply body - inline_requested specialise_requested - else - body - in - let bindings_for_params_to_args = - (* Bind the function's parameters to the arguments from the call site. *) - let args = List.map (fun arg -> Flambda.Expr (Var arg)) args in - Flambda_utils.bind ~body - ~bindings:(List.combine (Parameter.List.vars freshened_params) args) - in - (* Add bindings for the variables bound by the closure. *) - let bindings_for_vars_bound_by_closure_and_params_to_args = - let bound_variables = - let params = Parameter.Set.vars function_decl.params in - Variable.Set.diff - (Variable.Set.diff function_body.free_variables params) - fun_vars - in - fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied - ~lhs_of_application ~bound_variables ~init:bindings_for_params_to_args - ~f:(fun ~acc:body ~var ~expr -> Flambda.create_let var expr body) - in - (* Add bindings for variables corresponding to the functions introduced by - the whole set of closures. Each such variable will be bound to a closure; - each such closure is in turn produced by moving from the closure being - applied to another closure in the same set. - *) - let expr = - Variable.Set.fold (fun another_closure_in_the_same_set expr -> - let used = - Variable.Set.mem another_closure_in_the_same_set - function_body.free_variables - in - if used then - Flambda.create_let another_closure_in_the_same_set - (Move_within_set_of_closures { - closure = lhs_of_application; - start_from = closure_id_being_applied; - move_to = Closure_id.wrap another_closure_in_the_same_set; - }) - expr - else expr) - fun_vars - bindings_for_vars_bound_by_closure_and_params_to_args - in - let env = E.set_never_inline env in - let env = E.activate_freshening env in - let env = E.set_inline_debuginfo ~dbg env in - simplify env r expr - -type state = { - old_inside_to_new_inside : Variable.t Variable.Map.t; - (* Map from old inner vars to new inner vars *) - old_outside_to_new_outside : Variable.t Variable.Map.t; - (* Map from old outer vars to new outer vars *) - old_params_to_new_outside : Variable.t Variable.Map.t; - (* Map from old parameters to new outer vars. These are params - that should be specialised if they are copied to the new set of - closures. *) - old_fun_var_to_new_fun_var : Variable.t Variable.Map.t; - (* Map from old fun vars to new fun vars. These are the functions - that will be copied into the new set of closures *) - let_bindings : (Variable.t * Flambda.named) list; - (* Let bindings that will surround the definition of the new set - of closures *) - to_copy : Variable.t list; - (* List of functions that still need to be copied to the new set - of closures *) - new_funs : Flambda.function_declaration Variable.Map.t; - (* The function declarations for the new set of closures *) - new_free_vars_with_old_projections : Flambda.specialised_to Variable.Map.t; - (* The free variables for the new set of closures, but the projection - fields still point to old free variables. *) - new_specialised_args_with_old_projections : - Flambda.specialised_to Variable.Map.t; - (* The specialised parameters for the new set of closures, but the - projection fields still point to old specialised parameters. *) -} - -let empty_state = - { to_copy = []; - old_inside_to_new_inside = Variable.Map.empty; - old_outside_to_new_outside = Variable.Map.empty; - old_params_to_new_outside = Variable.Map.empty; - old_fun_var_to_new_fun_var = Variable.Map.empty; - let_bindings = []; - new_funs = Variable.Map.empty; - new_free_vars_with_old_projections = Variable.Map.empty; - new_specialised_args_with_old_projections = Variable.Map.empty; } - -(* Add let bindings for the free vars in the set_of_closures and - add them to [old_outside_to_new_outside] *) -let bind_free_vars ~lhs_of_application ~closure_id_being_applied - ~state ~free_vars = - Variable.Map.fold - (fun free_var (spec : Flambda.specialised_to) state -> - let var_clos = new_var Internal_variable_names.from_closure in - let expr : Flambda.named = - Project_var { - closure = lhs_of_application; - closure_id = closure_id_being_applied; - var = Var_within_closure.wrap free_var; - } - in - let let_bindings = (var_clos, expr) :: state.let_bindings in - let old_outside_to_new_outside = - Variable.Map.add spec.var var_clos state.old_outside_to_new_outside - in - { state with let_bindings; old_outside_to_new_outside }) - free_vars state - -(* For arguments of specialised parameters: - - Add them to [old_outside_to_new_outside] - - Add them and their invariant aliases to [old_params_to_new_outside] - For other arguments that are also worth specialising: - - Add them and their invariant aliases to [old_params_to_new_outside] *) -let register_arguments ~specialised_args ~invariant_params - ~state ~params ~args ~args_approxs = - let rec loop ~state ~params ~args ~args_approxs = - match params, args, args_approxs with - | [], [], [] -> state - | param :: params, arg :: args, arg_approx :: args_approxs -> begin - let param = Parameter.var param in - let worth_specialising, old_outside_to_new_outside = - match Variable.Map.find_opt param specialised_args with - | Some (spec : Flambda.specialised_to) -> - let old_outside_to_new_outside = - Variable.Map.add spec.var arg state.old_outside_to_new_outside - in - true, old_outside_to_new_outside - | None -> - let worth_specialising = - A.useful arg_approx - && Variable.Map.mem param (Lazy.force invariant_params) - in - worth_specialising, state.old_outside_to_new_outside - in - let old_params_to_new_outside = - if worth_specialising then begin - let old_params_to_new_outside = - Variable.Map.add param arg state.old_params_to_new_outside - in - match Variable.Map.find_opt param (Lazy.force invariant_params) with - | Some set -> - Variable.Set.fold - (fun elem acc -> Variable.Map.add elem arg acc) - set old_params_to_new_outside - | None -> - old_params_to_new_outside - end else begin - state.old_params_to_new_outside - end - in - let state = - { state with old_outside_to_new_outside; old_params_to_new_outside } - in - loop ~state ~params ~args ~args_approxs - end - | _, _, _ -> assert false - in - loop ~state ~params ~args ~args_approxs - -(* Add an old parameter to [old_inside_to_new_inside]. If it appears in - [old_params_to_new_outside] then also add it to the new specialised args. *) -let add_param ~specialised_args ~state ~param = - let param = Parameter.var param in - let new_param = Variable.rename param in - let old_inside_to_new_inside = - Variable.Map.add param new_param state.old_inside_to_new_inside - in - let new_specialised_args_with_old_projections = - match Variable.Map.find_opt param specialised_args with - | Some (spec : Flambda.specialised_to) -> - let new_outside_var = - Variable.Map.find spec.var state.old_outside_to_new_outside - in - let new_spec : Flambda.specialised_to = - { spec with var = new_outside_var } - in - Variable.Map.add new_param new_spec - state.new_specialised_args_with_old_projections - | None -> begin - match Variable.Map.find_opt param state.old_params_to_new_outside with - | None -> state.new_specialised_args_with_old_projections - | Some new_outside_var -> - let new_spec : Flambda.specialised_to = - { var = new_outside_var; projection = None } - in - Variable.Map.add new_param new_spec - state.new_specialised_args_with_old_projections - end - in - let state = - { state with old_inside_to_new_inside; - new_specialised_args_with_old_projections } - in - state, Parameter.wrap new_param - -(* Add a let binding for an old fun_var, add it to the new free variables, and - add it to [old_inside_to_new_inside] *) -let add_fun_var ~lhs_of_application ~closure_id_being_applied ~state ~fun_var = - if Variable.Map.mem fun_var state.old_inside_to_new_inside then state - else begin - let inside_var = Variable.rename fun_var in - let outside_var = Variable.create Internal_variable_names.closure in - let expr = - Flambda.Move_within_set_of_closures - { closure = lhs_of_application; - start_from = closure_id_being_applied; - move_to = Closure_id.wrap fun_var; } - in - let let_bindings = (outside_var, expr) :: state.let_bindings in - let spec : Flambda.specialised_to = - { var = outside_var; projection = None; } - in - let new_free_vars_with_old_projections = - Variable.Map.add inside_var spec state.new_free_vars_with_old_projections - in - let old_inside_to_new_inside = - Variable.Map.add fun_var inside_var state.old_inside_to_new_inside - in - { state with - old_inside_to_new_inside; let_bindings; - new_free_vars_with_old_projections } - end - -(* Add an old free_var to the new free variables and add it to - [old_inside_to_new_inside]. *) -let add_free_var ~free_vars ~state ~free_var = - if Variable.Map.mem free_var state.old_inside_to_new_inside then state - else begin - let spec : Flambda.specialised_to = Variable.Map.find free_var free_vars in - let outside_var = spec.var in - let new_outside_var = - Variable.Map.find outside_var state.old_outside_to_new_outside - in - let new_spec : Flambda.specialised_to = - { spec with var = new_outside_var } - in - let new_inside_var = Variable.rename free_var in - let new_free_vars_with_old_projections = - Variable.Map.add new_inside_var new_spec - state.new_free_vars_with_old_projections - in - let old_inside_to_new_inside = - Variable.Map.add free_var new_inside_var state.old_inside_to_new_inside - in - { state with old_inside_to_new_inside; new_free_vars_with_old_projections } - end - -(* Add a function to the new set of closures iff: - 1) All it's specialised parameters are available in - [old_outside_to_new_outside] - 2) At least one more parameter will become specialised *) -let add_function ~specialised_args ~state ~fun_var ~function_decl = - match function_decl.A.function_body with - | None -> None - | Some _ -> begin - let rec loop worth_specialising = function - | [] -> worth_specialising - | param :: params -> begin - let param = Parameter.var param in - match Variable.Map.find_opt param specialised_args with - | Some (spec : Flambda.specialised_to) -> - Variable.Map.mem spec.var state.old_outside_to_new_outside - && loop worth_specialising params - | None -> - let worth_specialising = - worth_specialising - || Variable.Map.mem param state.old_params_to_new_outside - in - loop worth_specialising params - end - in - let worth_specialising = loop false function_decl.A.params in - if not worth_specialising then None - else begin - let new_fun_var = Variable.rename fun_var in - let old_fun_var_to_new_fun_var = - Variable.Map.add fun_var new_fun_var state.old_fun_var_to_new_fun_var - in - let to_copy = fun_var :: state.to_copy in - let state = { state with old_fun_var_to_new_fun_var; to_copy } in - Some (state, new_fun_var) - end - end - -(* Lookup a function in the new set of closures, trying to add it if - necessary. *) -let lookup_function ~specialised_args ~state ~fun_var ~function_decl = - match Variable.Map.find_opt fun_var state.old_fun_var_to_new_fun_var with - | Some new_fun_var -> Some (state, new_fun_var) - | None -> add_function ~specialised_args ~state ~fun_var ~function_decl - -(* A direct call to a function in the new set of closures can be specialised - if all the function's newly specialised parameters are passed arguments - that are specialised to the same outside variable *) -let specialisable_call ~specialised_args ~state ~args ~params = - List.for_all2 - (fun arg param -> - let param = Parameter.var param in - if Variable.Map.mem param specialised_args then true - else begin - let old_params_to_new_outside = state.old_params_to_new_outside in - match Variable.Map.find_opt param old_params_to_new_outside with - | None -> true - | Some outside_var -> begin - match Variable.Map.find_opt arg old_params_to_new_outside with - | Some outside_var' -> - Variable.equal outside_var outside_var' - | None -> false - end - end) - args params - -(* Rewrite a call iff: - 1) It is to a function in the old set of closures that can be specialised - 2) All the newly specialised parameters of that function are passed values - known to be equal to their new specialisation. *) -let rec rewrite_direct_call ~specialised_args ~funs ~direct_call_surrogates - ~state ~closure_id ~(apply : Flambda.apply) = - match Closure_id.Map.find_opt closure_id direct_call_surrogates with - | Some closure_id -> - rewrite_direct_call ~specialised_args ~funs ~direct_call_surrogates - ~state ~closure_id ~apply - | None -> begin - let fun_var = Closure_id.unwrap closure_id in - match Variable.Map.find_opt fun_var funs with - | None -> None - | Some function_decl -> begin - match - lookup_function ~specialised_args ~state ~fun_var ~function_decl - with - | None -> None - | Some (state, new_fun_var) -> begin - let args = apply.args in - let params = function_decl.A.params in - let specialisable = - specialisable_call ~specialised_args ~state ~args ~params - in - if not specialisable then None - else begin - let kind = Flambda.Direct (Closure_id.wrap new_fun_var) in - let apply = { apply with func = new_fun_var; kind } in - Some (state, Flambda.Apply apply) - end - end - end - end - -(* Rewrite the body a function declaration for use in the new set of - closures. *) -let rewrite_function ~lhs_of_application ~closure_id_being_applied - ~direct_call_surrogates ~specialised_args ~free_vars ~funs - ~state fun_var = - let function_decl : A.function_declaration = - Variable.Map.find fun_var funs - in - let function_body = - match function_decl.function_body with - | None -> assert false - | Some function_body -> function_body - in - let new_fun_var = - Variable.Map.find fun_var state.old_fun_var_to_new_fun_var - in - let state, params = - List.fold_right - (fun param (state, params) -> - let state, param = add_param ~specialised_args ~state ~param in - (state, param :: params)) - function_decl.params (state, []) - in - let state = - Variable.Set.fold - (fun var state -> - if Variable.Map.mem var funs then - add_fun_var ~lhs_of_application ~closure_id_being_applied - ~state ~fun_var:var - else if Variable.Map.mem var free_vars then - add_free_var ~free_vars ~state ~free_var:var - else - state) - function_body.free_variables state - in - let state_ref = ref state in - let body = - Flambda_iterators.map_toplevel_expr - (fun (expr : Flambda.t) -> - match expr with - | Apply ({ kind = Direct closure_id } as apply) -> begin - match - rewrite_direct_call ~specialised_args ~funs - ~direct_call_surrogates ~state:!state_ref ~closure_id ~apply - with - | None -> expr - | Some (state, expr) -> - state_ref := state; - expr - end - | _ -> expr) - function_body.body - in - let body = - Flambda_utils.toplevel_substitution state.old_inside_to_new_inside body - in - let new_function_decl = - Flambda.create_function_declaration - ~params ~body - ~stub:function_body.stub - ~dbg:function_body.dbg - ~inline:function_body.inline - ~specialise:function_body.specialise - ~is_a_functor:function_body.is_a_functor - ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var)) - in - let new_funs = - Variable.Map.add new_fun_var new_function_decl state.new_funs - in - let state = { !state_ref with new_funs } in - state - -let update_projections ~state projections = - let old_to_new = state.old_inside_to_new_inside in - Variable.Map.map - (fun (spec_to : Flambda.specialised_to) -> - let projection : Projection.t option = - match spec_to.projection with - | None -> None - | Some (Project_var proj) -> begin - match Variable.Map.find_opt proj.closure old_to_new with - | None -> None - | Some closure -> - let proj = { proj with closure } in - Some (Projection.Project_var proj) - end - | Some (Project_closure proj) -> begin - match Variable.Map.find_opt proj.set_of_closures old_to_new with - | None -> None - | Some set_of_closures -> - let proj = { proj with set_of_closures } in - Some (Projection.Project_closure proj) - end - | Some (Move_within_set_of_closures proj) -> begin - match Variable.Map.find_opt proj.closure old_to_new with - | None -> None - | Some closure -> - let proj = { proj with closure } in - Some (Projection.Move_within_set_of_closures proj) - end - | Some (Field (index, var)) -> begin - match Variable.Map.find_opt var old_to_new with - | None -> None - | Some var -> Some (Projection.Field(index, var)) - end - in - { spec_to with projection }) - projections - -let inline_by_copying_function_declaration - ~(env : Inline_and_simplify_aux.Env.t) - ~(r : Inline_and_simplify_aux.Result.t) - ~(function_decls : A.function_declarations) - ~(lhs_of_application : Variable.t) - ~(inline_requested : Lambda.inline_attribute) - ~(closure_id_being_applied : Closure_id.t) - ~(function_decl : A.function_declaration) - ~(args : Variable.t list) - ~(args_approxs : A.t list) - ~(invariant_params : Variable.Set.t Variable.Map.t lazy_t) - ~(specialised_args : Flambda.specialised_to Variable.Map.t) - ~(free_vars : Flambda.specialised_to Variable.Map.t) - ~(direct_call_surrogates : Closure_id.t Closure_id.Map.t) - ~(dbg : Debuginfo.t) - ~(simplify : Inlining_decision_intf.simplify) = - let state = empty_state in - let state = - bind_free_vars ~lhs_of_application ~closure_id_being_applied - ~state ~free_vars - in - let params = function_decl.params in - let state = - register_arguments ~specialised_args ~invariant_params - ~state ~params ~args ~args_approxs - in - let fun_var = Closure_id.unwrap closure_id_being_applied in - match add_function ~specialised_args ~state ~fun_var ~function_decl with - | None -> None - | Some (state, new_fun_var) -> begin - let funs = function_decls.funs in - let rec loop state = - match state.to_copy with - | [] -> state - | next :: rest -> - let state = { state with to_copy = rest } in - let state = - rewrite_function ~lhs_of_application ~closure_id_being_applied - ~direct_call_surrogates ~specialised_args ~free_vars ~funs - ~state next - in - loop state - in - let state = loop state in - let closure_id = Closure_id.wrap new_fun_var in - let function_decls = - Flambda.create_function_declarations_with_origin - ~funs:state.new_funs - ~set_of_closures_origin:function_decls.set_of_closures_origin - ~is_classic_mode:function_decls.is_classic_mode - in - let free_vars = - update_projections ~state - state.new_free_vars_with_old_projections - in - let specialised_args = - update_projections ~state - state.new_specialised_args_with_old_projections - in - let direct_call_surrogates = Variable.Map.empty in - let set_of_closures = - Flambda.create_set_of_closures ~function_decls - ~free_vars ~specialised_args ~direct_call_surrogates - in - let closure_var = new_var Internal_variable_names.dup_func in - let set_of_closures_var = - new_var Internal_variable_names.dup_set_of_closures - in - let project : Flambda.project_closure = - {set_of_closures = set_of_closures_var; closure_id} - in - let apply : Flambda.apply = - { func = closure_var; args; kind = Direct closure_id; dbg; - inline = inline_requested; specialise = Default_specialise; } - in - let body = - Flambda.create_let - set_of_closures_var (Set_of_closures set_of_closures) - (Flambda.create_let closure_var (Project_closure project) - (Apply apply)) - in - let expr = Flambda_utils.bind ~body ~bindings:state.let_bindings in - let env = E.activate_freshening (E.set_never_inline env) in - Some (simplify env r expr) - end diff --git a/middle_end/inlining_transforms.mli b/middle_end/inlining_transforms.mli deleted file mode 100644 index e31d1b08..00000000 --- a/middle_end/inlining_transforms.mli +++ /dev/null @@ -1,105 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Source code transformations used during inlining. *) - -(** Inline a function by substituting its body (which may be subject to - further transformation) at a call site. The function's declaration is - not copied. - - This transformation is used when: - - inlining a call to a non-recursive function; - - inlining a call, within a recursive or mutually-recursive function, to - the same or another function being defined simultaneously ("unrolling"). - The maximum depth of unrolling is bounded (see [E.unrolling_allowed]). - - In both cases, the body of the function is copied, within a sequence of - [let]s that bind the function parameters, the variables "bound by the - closure" (see flambda.mli), and any function identifiers introduced by the - set of closures. These stages are delimited below by comments. - - As an example, suppose we are inlining the following function: - - let f x = x + y - ... - let p = f, f in - (fst p) 42 - - The call site [ (fst p) 42] will be transformed to: - - let clos_id = fst p in (* must eventually yield a closure *) - let y = in - let x' = 42 in - let x = x' in - x + y - - When unrolling a recursive function we rename the arguments to the - recursive call in order to avoid clashes with existing bindings. For - example, suppose we are inlining the following call to [f], which lies - within its own declaration: - - let rec f x y = - f (fst x) (y + snd x) - - This will be transformed to: - - let rec f x y = - let clos_id = f in (* not used this time, since [f] has no free vars *) - let x' = fst x in - let y' = y + snd x in - f (fst x') (y' + snd x') (* body of [f] with parameters freshened *) -*) -val inline_by_copying_function_body - : env:Inline_and_simplify_aux.Env.t - -> r:Inline_and_simplify_aux.Result.t - -> lhs_of_application:Variable.t - -> inline_requested:Lambda.inline_attribute - -> specialise_requested:Lambda.specialise_attribute - -> closure_id_being_applied:Closure_id.t - -> function_decl:Simple_value_approx.function_declaration - -> function_body:Simple_value_approx.function_body - -> fun_vars:Variable.Set.t - -> args:Variable.t list - -> dbg:Debuginfo.t - -> simplify:Inlining_decision_intf.simplify - -> Flambda.t * Inline_and_simplify_aux.Result.t - -(** Inlining of recursive function(s) yields a copy of the functions' - definitions (not just their bodies, unlike the non-recursive case) and - a direct application of the new body. - Note: the function really does need to be recursive (but possibly only via - some mutual recursion) to end up in here; a simultaneous binding [that is - non-recursive] is not sufficient. -*) -val inline_by_copying_function_declaration - : env:Inline_and_simplify_aux.Env.t - -> r:Inline_and_simplify_aux.Result.t - -> function_decls:Simple_value_approx.function_declarations - -> lhs_of_application:Variable.t - -> inline_requested:Lambda.inline_attribute - -> closure_id_being_applied:Closure_id.t - -> function_decl:Simple_value_approx.function_declaration - -> args:Variable.t list - -> args_approxs:Simple_value_approx.t list - -> invariant_params:Variable.Set.t Variable.Map.t lazy_t - -> specialised_args:Flambda.specialised_to Variable.Map.t - -> free_vars:Flambda.specialised_to Variable.Map.t - -> direct_call_surrogates:Closure_id.t Closure_id.Map.t - -> dbg:Debuginfo.t - -> simplify:Inlining_decision_intf.simplify - -> (Flambda.t * Inline_and_simplify_aux.Result.t) option diff --git a/middle_end/int_replace_polymorphic_compare.ml b/middle_end/int_replace_polymorphic_compare.ml deleted file mode 100644 index 7cd6bf10..00000000 --- a/middle_end/int_replace_polymorphic_compare.ml +++ /dev/null @@ -1,8 +0,0 @@ -let ( = ) : int -> int -> bool = Stdlib.( = ) -let ( <> ) : int -> int -> bool = Stdlib.( <> ) -let ( < ) : int -> int -> bool = Stdlib.( < ) -let ( > ) : int -> int -> bool = Stdlib.( > ) -let ( <= ) : int -> int -> bool = Stdlib.( <= ) -let ( >= ) : int -> int -> bool = Stdlib.( >= ) - -let compare : int -> int -> int = Stdlib.compare diff --git a/middle_end/int_replace_polymorphic_compare.mli b/middle_end/int_replace_polymorphic_compare.mli deleted file mode 100644 index 689e741b..00000000 --- a/middle_end/int_replace_polymorphic_compare.mli +++ /dev/null @@ -1,8 +0,0 @@ -val ( = ) : int -> int -> bool -val ( <> ) : int -> int -> bool -val ( < ) : int -> int -> bool -val ( > ) : int -> int -> bool -val ( <= ) : int -> int -> bool -val ( >= ) : int -> int -> bool - -val compare : int -> int -> int diff --git a/middle_end/internal_variable_names.ml b/middle_end/internal_variable_names.ml index ee400856..b87e73f7 100644 --- a/middle_end/internal_variable_names.ml +++ b/middle_end/internal_variable_names.ml @@ -55,6 +55,7 @@ let get_symbol_field = "get_symbol_field" let const_immstring = "const_immstring" let const_int32 = "const_int32" let const_int64 = "const_int64" +let ignore = "ignore" let is_zero = "is_zero" let lifted_let_rec_block = "lifted_let_rec_block" let meth = "meth" @@ -288,6 +289,7 @@ let symbol_field_block = "symbol_field_block" let the_dead_constant = "the_dead_constant" let toplevel_substitution_named = "toplevel_substitution_named" let unbox_free_vars_of_closures = "unbox_free_vars_of_closures" +let unit = "unit" let zero = "zero" let anon_fn_with_loc (loc: Location.t) = @@ -297,8 +299,8 @@ let anon_fn_with_loc (loc: Location.t) = if startchar >= 0 then Format.fprintf ppf ",%i--%i" startchar endchar in if loc.Location.loc_ghost then "anon_fn" else - Format.asprintf "anon_fn[%a:%i%t]" - Location.print_filename file line pp_chars + Format.asprintf "anon_fn[%s:%i%t]" + (Filename.basename file) line pp_chars let of_primitive : Lambda.primitive -> string = function | Pidentity -> pidentity diff --git a/middle_end/internal_variable_names.mli b/middle_end/internal_variable_names.mli index 24712e89..11a8231e 100644 --- a/middle_end/internal_variable_names.mli +++ b/middle_end/internal_variable_names.mli @@ -54,6 +54,7 @@ val get_symbol_field : t val const_immstring : t val const_int32 : t val const_int64 : t +val ignore : t val is_zero : t val lifted_let_rec_block : t val meth : t @@ -86,6 +87,7 @@ val symbol_field_block : t val the_dead_constant : t val toplevel_substitution_named : t val unbox_free_vars_of_closures : t +val unit : t val zero : t val of_primitive : Lambda.primitive -> t diff --git a/middle_end/invariant_params.ml b/middle_end/invariant_params.ml deleted file mode 100755 index a43cfdac..00000000 --- a/middle_end/invariant_params.ml +++ /dev/null @@ -1,420 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -(* CR-someday pchambart to pchambart: in fact partial application doesn't - work because there are no 'known' partial application left: they are - converted to applications new partial function declaration. - That can be improved (and many other cases) by keeping track of aliases in - closure of functions. *) - -(* These analyses are computed in two steps: - * accumulate the atomic <- relations - * compute the least-fixed point - - The <- relation is represented by the type - - t Variable.Pair.Map.t - - if [Variable.Pair.Map.find (f, x) relation = Top] then (f, x) <- Top - is in the relation. - - if [Variable.Pair.Map.find (f, x) relation = Implication s] and - [Variable.Pair.Set.mem (g, y) s] then (f, x) <- (g, y) is in the - relation. -*) - -type t = - | Top - | Implication of Variable.Pair.Set.t - -let _print ppf = function - | Top -> Format.fprintf ppf "Top" - | Implication args -> - Format.fprintf ppf "Implication: @[%a@]" - Variable.Pair.Set.print args - -let top relation p = - Variable.Pair.Map.add p Top relation - -let implies relation from to_ = - match Variable.Pair.Map.find to_ relation with - | Top -> relation - | Implication set -> - Variable.Pair.Map.add to_ - (Implication (Variable.Pair.Set.add from set)) - relation - | exception Not_found -> - Variable.Pair.Map.add to_ - (Implication (Variable.Pair.Set.singleton from)) - relation - -let transitive_closure state = - let union s1 s2 = - match s1, s2 with - | Top, _ | _, Top -> Top - | Implication s1, Implication s2 -> - Implication (Variable.Pair.Set.union s1 s2) - in - let equal s1 s2 = - match s1, s2 with - | Top, Implication _ | Implication _, Top -> false - | Top, Top -> true - | Implication s1, Implication s2 -> Variable.Pair.Set.equal s1 s2 - in - let update arg state = - let original_set = - try Variable.Pair.Map.find arg state with - | Not_found -> Implication Variable.Pair.Set.empty - in - match original_set with - | Top -> state - | Implication arguments -> - let set = - Variable.Pair.Set.fold - (fun orig acc-> - let set = - try Variable.Pair.Map.find orig state with - | Not_found -> Implication Variable.Pair.Set.empty in - union set acc) - arguments original_set - in - Variable.Pair.Map.add arg set state - in - let once state = - Variable.Pair.Map.fold (fun arg _ state -> update arg state) state state - in - let rec fp state = - let state' = once state in - if Variable.Pair.Map.equal equal state state' - then state - else fp state' - in - fp state - -(* CR-soon pchambart: to move to Flambda_utils and document - mshinwell: I think this calculation is basically the same as - [Flambda_utils.fun_vars_referenced_in_decls], so we should try - to share code. However let's defer until after 4.03. (And note CR - below.) -*) -(* Finds variables that represent the functions. - In a construction like: - let f x = - let g = Symbol f_closure in - .. - the variable g is bound to the symbol f_closure which - is the current closure. - The result of [function_variable_alias] will contain - the association [g -> f] -*) -let function_variable_alias - (function_decls : Flambda.function_declarations) - ~backend = - let fun_vars = Variable.Map.keys function_decls.funs in - let symbols_to_fun_vars = - let module Backend = (val backend : Backend_intf.S) in - Variable.Set.fold (fun fun_var symbols_to_fun_vars -> - let closure_id = Closure_id.wrap fun_var in - let symbol = Backend.closure_symbol closure_id in - Symbol.Map.add symbol fun_var symbols_to_fun_vars) - fun_vars - Symbol.Map.empty - in - let fun_var_bindings = ref Variable.Map.empty in - Variable.Map.iter (fun _ ( function_decl : Flambda.function_declaration ) -> - Flambda_iterators.iter_all_toplevel_immutable_let_and_let_rec_bindings - ~f:(fun var named -> - (* CR-soon mshinwell: consider having the body passed to this - function and using fv calculation instead of used_variables. - Need to be careful of "let rec" *) - match named with - | Symbol sym -> - begin match Symbol.Map.find sym symbols_to_fun_vars with - | exception Not_found -> () - | fun_var -> - fun_var_bindings := - Variable.Map.add var fun_var !fun_var_bindings - end - | _ -> ()) - function_decl.body) - function_decls.funs; - !fun_var_bindings - -let analyse_functions ~backend ~param_to_param - ~anything_to_param ~param_to_anywhere - (decls : Flambda.function_declarations) = - let function_variable_alias = function_variable_alias ~backend decls in - let param_indexes_by_fun_vars = - Variable.Map.map (fun (decl : Flambda.function_declaration) -> - Array.of_list (Parameter.List.vars decl.params)) - decls.funs - in - let find_callee_arg ~callee ~callee_pos = - match Variable.Map.find callee param_indexes_by_fun_vars with - | exception Not_found -> None (* not a recursive call *) - | arr -> - (* Ignore overapplied parameters: they are applied to a different - function. *) - if callee_pos < Array.length arr then Some arr.(callee_pos) - else None - in - let escaping_functions = Variable.Tbl.create 13 in - let escaping_function fun_var = - let fun_var = - match Variable.Map.find fun_var function_variable_alias with - | exception Not_found -> fun_var - | fun_var -> fun_var - in - if Variable.Map.mem fun_var decls.funs - then Variable.Tbl.add escaping_functions fun_var (); - in - let used_variables = Variable.Tbl.create 42 in - let used_variable var = Variable.Tbl.add used_variables var () in - let relation = ref Variable.Pair.Map.empty in - (* If the called closure is in the current set of closures, record the - relation (callee, callee_arg) <- (caller, caller_arg) *) - let check_argument ~caller ~callee ~callee_pos ~caller_arg = - escaping_function caller_arg; - match find_callee_arg ~callee ~callee_pos with - | None -> used_variable caller_arg (* not a recursive call *) - | Some callee_arg -> - match Variable.Map.find caller decls.funs with - | exception Not_found -> - assert false - | { params } -> - let new_relation = - (* We only track dataflow for parameters of functions, not - arbitrary variables. *) - if List.exists - (fun param -> Variable.equal (Parameter.var param) caller_arg) - params - then - param_to_param ~caller ~caller_arg ~callee ~callee_arg !relation - else begin - used_variable caller_arg; - anything_to_param ~callee ~callee_arg !relation - end - in - relation := new_relation - in - let arity ~callee = - match Variable.Map.find callee decls.funs with - | exception Not_found -> 0 - | func -> Flambda_utils.function_arity func - in - let check_expr ~caller (expr : Flambda.t) = - match expr with - | Apply { func; args } -> - used_variable func; - let callee = - match Variable.Map.find func function_variable_alias with - | exception Not_found -> func - | callee -> callee - in - let num_args = List.length args in - for callee_pos = num_args to (arity ~callee) - 1 do - (* If a function is partially applied, consider all missing - arguments as "anything". *) - match find_callee_arg ~callee ~callee_pos with - | None -> () - | Some callee_arg -> - relation := anything_to_param ~callee ~callee_arg !relation - done; - List.iteri (fun callee_pos caller_arg -> - check_argument ~caller ~callee ~callee_pos ~caller_arg) - args - | _ -> () - in - Variable.Map.iter (fun caller (decl : Flambda.function_declaration) -> - Flambda_iterators.iter (check_expr ~caller) - (fun (_ : Flambda.named) -> ()) - decl.body; - Variable.Set.iter - (fun var -> escaping_function var; used_variable var) - (* CR-soon mshinwell: we should avoid recomputing this, cache in - [function_declaration]. See also comment on - [only_via_symbols] in [Flambda_utils]. *) - (Flambda.free_variables ~ignore_uses_as_callee:() - ~ignore_uses_as_argument:() decl.body)) - decls.funs; - Variable.Map.iter - (fun func_var ({ params } : Flambda.function_declaration) -> - List.iter - (fun (param : Parameter.t) -> - if Variable.Tbl.mem used_variables (Parameter.var param) then - relation := - param_to_anywhere ~caller:func_var - ~caller_arg:(Parameter.var param) !relation; - if Variable.Tbl.mem escaping_functions func_var then - relation := - anything_to_param ~callee:func_var - ~callee_arg:(Parameter.var param) !relation) - params) - decls.funs; - transitive_closure !relation - - -(* A parameter [x] of the function [f] is considered as unchanging if - during an 'external' (call from outside the set of closures) call of - [f], every recursive call of [f] all the instances of [x] are aliased - to the original one. This function computes an underapproximation of - that set by computing the flow of parameters between the different - functions of the set of closures. - - We record [(f, x) <- (g, y)] when the function g calls f and - the y parameter of g is used as argument for the x parameter of f. For - instance in - - let rec f x = ... - and g y = f x - - We record [(f, x) <- Top] when some unknown values can flow to the - [y] parameter. - - let rec f x = f 1 - - We record also [(f, x) <- Top] if [f] could escape. This is over - approximated by considering that a function escape when its variable is used - for something else than an application: - - let rec f x = (f, f) - - [x] is not unchanging if either - (f, x) <- Top - or (f, x) <- (f, y) with x != y - - Notice that having (f, x) <- (g, a) and (f, x) <- (g, b) does not make - x not unchanging. This is because (g, a) and (g, b) represent necessarily - different values only if g is the externaly called function. If some - value where created during the execution of the function that could - flow to (g, a), then (g, a) <- Top, so (f, x) <- Top. - - *) - -let invariant_params_in_recursion (decls : Flambda.function_declarations) - ~backend = - let param_to_param ~caller ~caller_arg ~callee ~callee_arg relation = - implies relation (caller, caller_arg) (callee, callee_arg) - in - let anything_to_param ~callee ~callee_arg relation = - top relation (callee, callee_arg) - in - let param_to_anywhere ~caller:_ ~caller_arg:_ relation = relation in - let relation = - analyse_functions ~backend ~param_to_param - ~anything_to_param ~param_to_anywhere - decls - in - let not_unchanging = - Variable.Pair.Map.fold (fun (func, var) set not_unchanging -> - match set with - | Top -> Variable.Set.add var not_unchanging - | Implication set -> - if Variable.Pair.Set.exists (fun (func', var') -> - Variable.equal func func' && not (Variable.equal var var')) - set - then Variable.Set.add var not_unchanging - else not_unchanging) - relation Variable.Set.empty - in - let params = Variable.Map.fold (fun _ - ({ params } : Flambda.function_declaration) set -> - Variable.Set.union (Parameter.Set.vars params) set) - decls.funs Variable.Set.empty - in - let unchanging = Variable.Set.diff params not_unchanging in - let aliased_to = - Variable.Pair.Map.fold (fun (_, var) set aliases -> - match set with - | Implication set - when Variable.Set.mem var unchanging -> - Variable.Pair.Set.fold (fun (_, caller_args) aliases -> - if Variable.Set.mem caller_args unchanging then - let alias_set = - match Variable.Map.find caller_args aliases with - | exception Not_found -> - Variable.Set.singleton var - | alias_set -> - Variable.Set.add var alias_set - in - Variable.Map.add caller_args alias_set aliases - else - aliases) - set aliases - | Top | Implication _ -> aliases) - relation Variable.Map.empty - in - (* We complete the set of aliases such that there does not miss any - unchanging param *) - Variable.Map.of_set (fun var -> - match Variable.Map.find var aliased_to with - | exception Not_found -> Variable.Set.empty - | set -> set) - unchanging - -let invariant_param_sources decls ~backend = - let param_to_param ~caller ~caller_arg ~callee ~callee_arg relation = - implies relation (caller, caller_arg) (callee, callee_arg) - in - let anything_to_param ~callee:_ ~callee_arg:_ relation = relation in - let param_to_anywhere ~caller:_ ~caller_arg:_ relation = relation in - let relation = - analyse_functions ~backend ~param_to_param - ~anything_to_param ~param_to_anywhere - decls - in - Variable.Pair.Map.fold (fun (_, var) set relation -> - match set with - | Top -> relation - | Implication set -> Variable.Map.add var set relation) - relation Variable.Map.empty - -let pass_name = "unused-arguments" -let () = Clflags.all_passes := pass_name :: !Clflags.all_passes - -let unused_arguments (decls : Flambda.function_declarations) ~backend = - let dump = Clflags.dumped_pass pass_name in - let param_to_param ~caller ~caller_arg ~callee ~callee_arg relation = - implies relation (callee, callee_arg) (caller, caller_arg) - in - let anything_to_param ~callee:_ ~callee_arg:_ relation = relation in - let param_to_anywhere ~caller ~caller_arg relation = - top relation (caller, caller_arg) - in - let relation = - analyse_functions ~backend ~param_to_param - ~anything_to_param ~param_to_anywhere - decls - in - let arguments = - Variable.Map.fold - (fun fun_var decl acc -> - List.fold_left - (fun acc param -> - match Variable.Pair.Map.find (fun_var, param) relation with - | exception Not_found -> Variable.Set.add param acc - | Implication _ -> Variable.Set.add param acc - | Top -> acc) - acc (Parameter.List.vars decl.Flambda.params)) - decls.funs Variable.Set.empty - in - if dump then begin - Format.printf "Unused arguments: %a@." Variable.Set.print arguments - end; - arguments diff --git a/middle_end/invariant_params.mli b/middle_end/invariant_params.mli deleted file mode 100644 index c6851420..00000000 --- a/middle_end/invariant_params.mli +++ /dev/null @@ -1,57 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(* [invariant_params_in_recursion] calculates the set of parameters whose - values are known not to change during the execution of a recursive - function. As such, occurrences of the parameters may always be replaced - by the corresponding values. - - For example, [x] would be in [invariant_params] for both of the following - functions: - - let rec f x y = (f x y) + (f x (y+1)) - - let rec f x l = List.iter (f x) l - - For invariant parameters it also computes the set of parameters of functions - in the set of closures that are always aliased to it. For example in the set - of closures: - - let rec f x y = (f x y) + (f x (y+1)) + g x - and g z = z + 1 - - The map of aliases is - - x -> { x; z } -*) -val invariant_params_in_recursion - : Flambda.function_declarations - -> backend:(module Backend_intf.S) - -> Variable.Set.t Variable.Map.t - -val invariant_param_sources - : Flambda.function_declarations - -> backend:(module Backend_intf.S) - -> Variable.Pair.Set.t Variable.Map.t - -(* CR-soon mshinwell: think about whether this function should - be in this file. Should it be called "unused_parameters"? *) -val unused_arguments - : Flambda.function_declarations - -> backend:(module Backend_intf.S) - -> Variable.Set.t diff --git a/middle_end/lift_code.ml b/middle_end/lift_code.ml deleted file mode 100644 index 02292c46..00000000 --- a/middle_end/lift_code.ml +++ /dev/null @@ -1,163 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type lifter = Flambda.program -> Flambda.program - -let rebuild_let - (defs : (Variable.t * Flambda.named Flambda.With_free_variables.t) list) - (body : Flambda.t) = - let module W = Flambda.With_free_variables in - List.fold_left (fun body (var, def) -> - W.create_let_reusing_defining_expr var def body) - body defs - -let rec extract_lets - (acc:(Variable.t * Flambda.named Flambda.With_free_variables.t) list) - (let_expr:Flambda.let_expr) : - (Variable.t * Flambda.named Flambda.With_free_variables.t) list * - Flambda.t Flambda.With_free_variables.t = - let module W = Flambda.With_free_variables in - match let_expr with - | { var = v1; defining_expr = Expr (Let let2); _ } -> - let acc, body2 = extract_lets acc let2 in - let acc = (v1, W.expr body2) :: acc in - let body = W.of_body_of_let let_expr in - extract acc body - | { var = v; _ } -> - let acc = (v, W.of_defining_expr_of_let let_expr) :: acc in - let body = W.of_body_of_let let_expr in - extract acc body - -and extract acc (expr : Flambda.t Flambda.With_free_variables.t) = - let module W = Flambda.With_free_variables in - match W.contents expr with - | Let let_expr -> - extract_lets acc let_expr - | _ -> - acc, expr - -let rec lift_lets_expr (expr:Flambda.t) ~toplevel : Flambda.t = - let module W = Flambda.With_free_variables in - match expr with - | Let let_expr -> - let defs, body = extract_lets [] let_expr in - let rev_defs = - List.rev_map (lift_lets_named_with_free_variables ~toplevel) defs - in - let body = lift_lets_expr (W.contents body) ~toplevel in - rebuild_let (List.rev rev_defs) body - | e -> - Flambda_iterators.map_subexpressions - (lift_lets_expr ~toplevel) - (lift_lets_named ~toplevel) - e - -and lift_lets_named_with_free_variables - ((var, named):Variable.t * Flambda.named Flambda.With_free_variables.t) - ~toplevel : Variable.t * Flambda.named Flambda.With_free_variables.t = - let module W = Flambda.With_free_variables in - match W.contents named with - | Expr e -> - var, W.expr (W.of_expr (lift_lets_expr e ~toplevel)) - | Set_of_closures set when not toplevel -> - var, - W.of_named - (Set_of_closures - (Flambda_iterators.map_function_bodies - ~f:(lift_lets_expr ~toplevel) set)) - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field (_, _) | Project_closure _ | Move_within_set_of_closures _ - | Project_var _ | Prim _ | Set_of_closures _ -> - var, named - -and lift_lets_named _var (named:Flambda.named) ~toplevel : Flambda.named = - let module W = Flambda.With_free_variables in - match named with - | Expr e -> - Expr (lift_lets_expr e ~toplevel) - | Set_of_closures set when not toplevel -> - Set_of_closures - (Flambda_iterators.map_function_bodies ~f:(lift_lets_expr ~toplevel) set) - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field (_, _) | Project_closure _ | Move_within_set_of_closures _ - | Project_var _ | Prim _ | Set_of_closures _ -> - named - -module Sort_lets = Strongly_connected_components.Make (Variable) - -let rebuild_let_rec (defs:(Variable.t * Flambda.named) list) body = - let map = Variable.Map.of_list defs in - let graph = - Variable.Map.map - (fun named -> - Variable.Set.filter (fun v -> Variable.Map.mem v map) - (Flambda.free_variables_named named)) - map - in - let components = - Sort_lets.connected_components_sorted_from_roots_to_leaf graph - in - Array.fold_left (fun body (component:Sort_lets.component) -> - match component with - | No_loop v -> - let def = Variable.Map.find v map in - Flambda.create_let v def body - | Has_loop l -> - Flambda.Let_rec - (List.map (fun v -> v, Variable.Map.find v map) l, - body)) - body components - -let lift_let_rec program = - Flambda_iterators.map_exprs_at_toplevel_of_program program - ~f:(Flambda_iterators.map_expr - (fun expr -> match expr with - | Let_rec (defs, body) -> - rebuild_let_rec defs body - | expr -> expr)) - -let lift_lets program = - let program = lift_let_rec program in - Flambda_iterators.map_exprs_at_toplevel_of_program program - ~f:(lift_lets_expr ~toplevel:false) - -let lifting_helper exprs ~evaluation_order ~create_body ~name = - let vars, lets = - (* [vars] corresponds elementwise to [exprs]; the order is unchanged. *) - List.fold_right (fun (flam : Flambda.t) (vars, lets) -> - match flam with - | Var v -> - (* Note that [v] is (statically) always an immutable variable. *) - v::vars, lets - | expr -> - let v = - Variable.create name ~current_compilation_unit: - (Compilation_unit.get_current_exn ()) - in - v::vars, (v, expr)::lets) - exprs ([], []) - in - let lets = - match evaluation_order with - | `Right_to_left -> lets - | `Left_to_right -> List.rev lets - in - List.fold_left (fun body (v, expr) -> - Flambda.create_let v (Expr expr) body) - (create_body vars) lets diff --git a/middle_end/lift_code.mli b/middle_end/lift_code.mli deleted file mode 100644 index 92ecda01..00000000 --- a/middle_end/lift_code.mli +++ /dev/null @@ -1,43 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -type lifter = Flambda.program -> Flambda.program - -(** Lift [let] bindings to attempt to increase the length of scopes, as an - aid to further optimizations. For example: - let c = let b = in b, b in fst c - would be transformed to: - let b = in let c = b, b in fst c - which is then clearly just: - -*) -val lift_lets : lifter - -val lift_lets_expr : Flambda.t -> toplevel:bool -> Flambda.t - -(* CR-someday mshinwell: Rename to [bind]? Also see Flambda_utils.bind. *) -(* [create_body] always receives the variables corresponding to [evaluate] - in the same order. However [evaluation_order] specifies in which order - the (possibly complex) expressions bound to those variables are - evaluated. *) -val lifting_helper - : Flambda.t list - -> evaluation_order:[ `Left_to_right | `Right_to_left ] - -> create_body:(Variable.t list -> Flambda.t) - -> name:Internal_variable_names.t - -> Flambda.t diff --git a/middle_end/lift_constants.ml b/middle_end/lift_constants.ml deleted file mode 100644 index dd60de9c..00000000 --- a/middle_end/lift_constants.ml +++ /dev/null @@ -1,1019 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -(* CR-someday mshinwell: move to Flambda_utils *) -let rec tail_variable : Flambda.t -> Variable.t option = function - | Var v -> Some v - | Let_rec (_, e) - | Let_mutable { body = e } - | Let { body = e; _ } -> tail_variable e - | _ -> None - -let closure_symbol ~(backend : (module Backend_intf.S)) closure_id = - let module Backend = (val backend) in - Backend.closure_symbol closure_id - -(** Traverse the given expression assigning symbols to [let]- and [let rec]- - bound constant variables. At the same time collect the definitions of - such variables. *) -let assign_symbols_and_collect_constant_definitions - ~(backend : (module Backend_intf.S)) - ~(program : Flambda.program) - ~(inconstants : Inconstant_idents.result) = - let var_to_symbol_tbl = Variable.Tbl.create 42 in - let var_to_definition_tbl = Variable.Tbl.create 42 in - let module AA = Alias_analysis in - let assign_symbol var (named : Flambda.named) = - if not (Inconstant_idents.variable var inconstants) then begin - let assign_symbol () = - let symbol = Symbol.of_variable (Variable.rename var) in - Variable.Tbl.add var_to_symbol_tbl var symbol - in - let assign_existing_symbol = Variable.Tbl.add var_to_symbol_tbl var in - let record_definition = Variable.Tbl.add var_to_definition_tbl var in - match named with - | Symbol symbol -> - assign_existing_symbol symbol; - record_definition (AA.Symbol symbol) - | Const const -> record_definition (AA.Const const) - | Allocated_const const -> - assign_symbol (); - record_definition (AA.Allocated_const (Normal const)) - | Read_mutable _ -> - (* [Inconstant_idents] always marks these expressions as - inconstant, so we should never get here. *) - assert false - | Prim (Pmakeblock (tag, _, _value_kind), fields, _) -> - assign_symbol (); - record_definition (AA.Block (Tag.create_exn tag, fields)) - | Read_symbol_field (symbol, field) -> - record_definition (AA.Symbol_field (symbol, field)) - | Set_of_closures ( - { function_decls = { funs; set_of_closures_id; _ }; - _ } as set) -> - assert (not (Inconstant_idents.closure set_of_closures_id - inconstants)); - assign_symbol (); - record_definition (AA.Set_of_closures set); - Variable.Map.iter (fun fun_var _ -> - let closure_id = Closure_id.wrap fun_var in - let closure_symbol = closure_symbol ~backend closure_id in - Variable.Tbl.add var_to_symbol_tbl fun_var closure_symbol; - let project_closure = - Alias_analysis.Project_closure - { set_of_closures = var; closure_id } - in - Variable.Tbl.add var_to_definition_tbl fun_var - project_closure) - funs - | Move_within_set_of_closures ({ closure = _; start_from = _; move_to; } - as move) -> - assign_existing_symbol (closure_symbol ~backend move_to); - record_definition (AA.Move_within_set_of_closures move) - | Project_closure ({ closure_id } as project_closure) -> - assign_existing_symbol (closure_symbol ~backend closure_id); - record_definition (AA.Project_closure project_closure) - | Prim (Pfield index, [block], _) -> - record_definition (AA.Field (block, index)) - | Prim (Pfield _, _, _) -> - Misc.fatal_errorf "[Pfield] with the wrong number of arguments" - Flambda.print_named named - | Prim (Pmakearray (Pfloatarray as kind, mutability), args, _) -> - assign_symbol (); - record_definition (AA.Allocated_const (Array (kind, mutability, args))) - | Prim (Pduparray (kind, mutability), [arg], _) -> - assign_symbol (); - record_definition (AA.Allocated_const ( - Duplicate_array (kind, mutability, arg))) - | Prim _ -> - Misc.fatal_errorf "Primitive not expected to be constant: @.%a@." - Flambda.print_named named - | Project_var project_var -> - record_definition (AA.Project_var project_var) - | Expr e -> - match tail_variable e with - | None -> assert false (* See [Inconstant_idents]. *) - | Some v -> record_definition (AA.Variable v) - end - in - let assign_symbol_program expr = - Flambda_iterators.iter_all_immutable_let_and_let_rec_bindings expr - ~f:assign_symbol - in - Flambda_iterators.iter_exprs_at_toplevel_of_program program - ~f:assign_symbol_program; - let let_symbol_to_definition_tbl = Symbol.Tbl.create 42 in - let initialize_symbol_to_definition_tbl = Symbol.Tbl.create 42 in - let rec collect_let_and_initialize_symbols (program : Flambda.program_body) = - match program with - | Let_symbol (symbol, decl, program) -> - Symbol.Tbl.add let_symbol_to_definition_tbl symbol decl; - collect_let_and_initialize_symbols program - | Let_rec_symbol (decls, program) -> - List.iter (fun (symbol, decl) -> - Symbol.Tbl.add let_symbol_to_definition_tbl symbol decl) - decls; - collect_let_and_initialize_symbols program - | Effect (_, program) -> collect_let_and_initialize_symbols program - | Initialize_symbol (symbol,_tag,fields,program) -> - collect_let_and_initialize_symbols program; - let fields = List.map tail_variable fields in - Symbol.Tbl.add initialize_symbol_to_definition_tbl symbol fields - | End _ -> () - in - collect_let_and_initialize_symbols program.program_body; - let record_set_of_closure_equalities - (set_of_closures : Flambda.set_of_closures) = - Variable.Map.iter (fun arg (var : Flambda.specialised_to) -> - if not (Inconstant_idents.variable arg inconstants) then - Variable.Tbl.add var_to_definition_tbl arg (AA.Variable var.var)) - set_of_closures.free_vars; - Variable.Map.iter (fun arg (spec_to : Flambda.specialised_to) -> - if not (Inconstant_idents.variable arg inconstants) then - Variable.Tbl.add var_to_definition_tbl arg - (AA.Variable spec_to.var)) - set_of_closures.specialised_args - in - Flambda_iterators.iter_on_set_of_closures_of_program program - ~f:(fun ~constant set_of_closures -> - record_set_of_closure_equalities set_of_closures; - if constant then begin - Variable.Map.iter (fun fun_var _ -> - let closure_id = Closure_id.wrap fun_var in - let closure_symbol = closure_symbol ~backend closure_id in - Variable.Tbl.add var_to_definition_tbl fun_var - (AA.Symbol closure_symbol); - Variable.Tbl.add var_to_symbol_tbl fun_var closure_symbol) - set_of_closures.Flambda.function_decls.funs - end); - var_to_symbol_tbl, var_to_definition_tbl, - let_symbol_to_definition_tbl, initialize_symbol_to_definition_tbl - -let variable_field_definition - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl : - Alias_analysis.constant_defining_value Variable.Tbl.t) - (var : Variable.t) : Flambda.constant_defining_value_block_field = - try - Symbol (Variable.Tbl.find var_to_symbol_tbl var) - with Not_found -> - match Variable.Tbl.find var_to_definition_tbl var with - | Const c -> Const c - | const_defining_value -> - Misc.fatal_errorf "Unexpected pattern for a constant: %a: %a" - Variable.print var - Alias_analysis.print_constant_defining_value const_defining_value - | exception Not_found -> - Misc.fatal_errorf "No associated symbol for the constant %a" - Variable.print var - -let resolve_variable - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl : - Alias_analysis.constant_defining_value Variable.Tbl.t) - (var : Variable.t) : Flambda.constant_defining_value_block_field = - match Variable.Map.find var aliases with - | exception Not_found -> - variable_field_definition var_to_symbol_tbl var_to_definition_tbl var - | Symbol s -> Symbol s - | Variable aliased_variable -> - variable_field_definition var_to_symbol_tbl var_to_definition_tbl - aliased_variable - -let translate_set_of_closures - (inconstants : Inconstant_idents.result) - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl: - Alias_analysis.constant_defining_value Variable.Tbl.t) - (set_of_closures : Flambda.set_of_closures) = - let f var (named : Flambda.named) : Flambda.named = - if Inconstant_idents.variable var inconstants then - named - else - let resolved = - resolve_variable - aliases - var_to_symbol_tbl - var_to_definition_tbl - var - in - match resolved with - | Symbol s -> Symbol s - | Const c -> Const c - in - Flambda_iterators.map_function_bodies set_of_closures - ~f:(Flambda_iterators.map_all_immutable_let_and_let_rec_bindings ~f) - -let translate_constant_set_of_closures - (inconstants : Inconstant_idents.result) - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl: - Alias_analysis.constant_defining_value Variable.Tbl.t) - (constant_defining_values : Flambda.constant_defining_value Symbol.Map.t) = - Symbol.Map.map (fun (const : Flambda.constant_defining_value) -> - match const with - | Flambda.Allocated_const _ - | Flambda.Block _ - | Flambda.Project_closure _ -> - const - | Flambda.Set_of_closures set_of_closures -> - let set_of_closures = - translate_set_of_closures - (inconstants : Inconstant_idents.result) - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl: - Alias_analysis.constant_defining_value Variable.Tbl.t) - (set_of_closures : Flambda.set_of_closures) - in - Flambda.Set_of_closures set_of_closures) - constant_defining_values - -let find_original_set_of_closure - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl: - Alias_analysis.constant_defining_value Variable.Tbl.t) - project_closure_map - var = - let rec loop var = - match Variable.Map.find var aliases with - | Variable var -> - begin match Variable.Tbl.find var_to_definition_tbl var with - | Project_closure { set_of_closures = var } - | Move_within_set_of_closures { closure = var } -> - loop var - | Set_of_closures _ -> begin - match Variable.Tbl.find var_to_symbol_tbl var with - | s -> - s - | exception Not_found -> - Format.eprintf "var: %a@." Variable.print var; - assert false - end - | _ -> assert false - end - | Symbol s -> - match Symbol.Map.find s project_closure_map with - | exception Not_found -> - Misc.fatal_errorf "find_original_set_of_closure: cannot find \ - symbol %a in the project-closure map" - Symbol.print s - | s -> s - in - loop var - -let translate_definition_and_resolve_alias inconstants - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl : - Alias_analysis.constant_defining_value Variable.Tbl.t) - (symbol_definition_map : Flambda.constant_defining_value Symbol.Map.t) - (project_closure_map : Symbol.t Symbol.Map.t) - (definition : Alias_analysis.constant_defining_value) - ~(backend : (module Backend_intf.S)) - : Flambda.constant_defining_value option = - let resolve_float_array_involving_variables - ~(mutability : Asttypes.mutable_flag) ~vars = - (* Resolve an [Allocated_const] of the form: - [Array (Pfloatarray, _, _)] - (which references its contents via variables; it does not contain - manifest floats). *) - let find_float_var_definition var = - match Variable.Tbl.find var_to_definition_tbl var with - | Allocated_const (Normal (Float f)) -> f - | const_defining_value -> - Misc.fatal_errorf "Bad definition for float array member %a: %a" - Variable.print var - Alias_analysis.print_constant_defining_value - const_defining_value - in - let find_float_symbol_definition sym = - match Symbol.Map.find sym symbol_definition_map with - | Allocated_const (Float f) -> f - | const_defining_value -> - Misc.fatal_errorf "Bad definition for float array member %a: %a" - Symbol.print sym - Flambda.print_constant_defining_value - const_defining_value - in - let floats = - List.map (fun var -> - match Variable.Map.find var aliases with - | exception Not_found -> find_float_var_definition var - | Variable var -> find_float_var_definition var - | Symbol sym -> find_float_symbol_definition sym) - vars - in - let const : Allocated_const.t = - match mutability with - | Immutable -> Immutable_float_array floats - | Mutable -> Float_array floats - in - Some (Flambda.Allocated_const const) - in - match definition with - | Block (tag, fields) -> - Some (Flambda.Block (tag, - List.map (resolve_variable aliases var_to_symbol_tbl - var_to_definition_tbl) - fields)) - | Allocated_const (Normal const) -> Some (Flambda.Allocated_const const) - | Allocated_const (Duplicate_array (Pfloatarray, mutability, var)) -> - (* CR-someday mshinwell: This next section could do with cleanup. - What happens is: - - Duplicate contains a variable, which is resolved to - a float array thing full of variables; - - We send that value back through this function again so the - individual members of that array are resolved from variables to - floats. - - Then we can build the Flambda.name term containing the - Allocated_const (full of floats). - We should maybe factor out the code from the - Allocated_const (Array (...)) case below so this function doesn't have - to be recursive. *) - let (constant_defining_value : Alias_analysis.constant_defining_value) = - match Variable.Map.find var aliases with - | exception Not_found -> - Variable.Tbl.find var_to_definition_tbl var - | Variable var -> - Variable.Tbl.find var_to_definition_tbl var - | Symbol sym -> - match Symbol.Map.find sym symbol_definition_map with - | Allocated_const ((Immutable_float_array _) as const) -> - Alias_analysis.Allocated_const (Normal const) - | (Allocated_const _ | Block _ | Set_of_closures _ - | Project_closure _) as wrong -> - Misc.fatal_errorf - "Lift_constants.translate_definition_and_resolve_alias: \ - Duplicate Pfloatarray %a with symbol %a mapping to \ - wrong constant defining value %a" - Variable.print var - Alias_analysis.print_constant_defining_value definition - Flambda.print_constant_defining_value wrong - | exception Not_found -> - let module Backend = (val backend) in - match (Backend.import_symbol sym).descr with - | Value_unresolved _ -> - Misc.fatal_errorf - "Lift_constants.translate_definition_and_resolve_alias: \ - Duplicate Pfloatarray %a with unknown symbol: %a" - Variable.print var - Alias_analysis.print_constant_defining_value definition - | Value_float_array value_float_array -> - let contents = - Simple_value_approx.float_array_as_constant value_float_array - in - begin match contents with - | None -> - Misc.fatal_errorf - "Lift_constants.translate_definition_and_resolve_alias: \ - Duplicate Pfloatarray %a with not completely known float \ - array from symbol: %a" - Variable.print var - Alias_analysis.print_constant_defining_value definition - | Some l -> - Alias_analysis.Allocated_const (Normal (Immutable_float_array l)) - end - | wrong -> - (* CR-someday mshinwell: we might hit this if we ever duplicate - a mutable array across compilation units (e.g. "snapshotting" - an array). We do not currently generate such code. *) - Misc.fatal_errorf - "Lift_constants.translate_definition_and_resolve_alias: \ - Duplicate Pfloatarray %a with symbol %a that does not \ - have an export description of an immutable array" - Variable.print var - Alias_analysis.print_constant_defining_value definition - Simple_value_approx.print_descr wrong - in - begin match constant_defining_value with - | Allocated_const (Normal (Float_array _)) -> - (* This example from pchambart illustrates why we do not allow - the duplication of mutable arrays: - - {| - let_symbol a = Allocated_const (Immutable_float_array [|0.|]) - initialize_symbol b = Duparray(Mutable, a) - effect b.(0) <- 1. - initialize_symbol c = Duparray(Mutable, b) - |} - - This will be converted to: - {| - let_symbol a = Allocated_const (Immutable_float_array [|0.|]) - let_symbol b = Allocated_const (Float_array [|0.|]) - effect b.(0) <- 1. - let_symbol c = Allocated_const (Float_array [|0.|]) - |} - - We can't encounter that currently, but it's scary. - *) - Misc.fatal_error "Pduparray is not allowed on mutable arrays" - | Allocated_const (Normal (Immutable_float_array floats)) -> - let const : Allocated_const.t = - match mutability with - | Immutable -> Immutable_float_array floats - | Mutable -> Float_array floats - in - Some (Flambda.Allocated_const const) - | Allocated_const (Array (Pfloatarray, _, vars)) -> - (* Important: [mutability] is from the [Duplicate_array] - construction above. *) - resolve_float_array_involving_variables ~mutability ~vars - | const -> - Misc.fatal_errorf - "Lift_constants.translate_definition_and_resolve_alias: \ - Duplicate Pfloatarray %a with wrong argument: %a" - Variable.print var - Alias_analysis.print_constant_defining_value const - end - | Allocated_const (Duplicate_array (_, _, _)) -> - Misc.fatal_errorf "Lift_constants.translate_definition_and_resolve_alias: \ - Duplicate_array with non-Pfloatarray kind: %a" - Alias_analysis.print_constant_defining_value definition - | Allocated_const (Array (Pfloatarray, mutability, vars)) -> - resolve_float_array_involving_variables ~mutability ~vars - | Allocated_const (Array (_, _, _)) -> - Misc.fatal_errorf "Lift_constants.translate_definition_and_resolve_alias: \ - Array with non-Pfloatarray kind: %a" - Alias_analysis.print_constant_defining_value definition - | Project_closure { set_of_closures; closure_id } -> - begin match Variable.Map.find set_of_closures aliases with - | Symbol s -> - Some (Flambda.Project_closure (s, closure_id)) - (* If a closure projection is a constant, the set of closures must - be assigned to a symbol. *) - | exception Not_found -> - assert false - | Variable v -> - match Variable.Tbl.find var_to_symbol_tbl v with - | s -> - Some (Flambda.Project_closure (s, closure_id)) - | exception Not_found -> - Format.eprintf "var: %a@." Variable.print v; - assert false - end - | Move_within_set_of_closures { closure; move_to } -> - let set_of_closure_symbol = - find_original_set_of_closure - aliases - var_to_symbol_tbl - var_to_definition_tbl - project_closure_map - closure - in - Some (Flambda.Project_closure (set_of_closure_symbol, move_to)) - | Set_of_closures set_of_closures -> - let set_of_closures = - translate_set_of_closures - inconstants - aliases - var_to_symbol_tbl - var_to_definition_tbl - set_of_closures - in - Some (Flambda.Set_of_closures set_of_closures) - | Project_var _ -> None - | Field (_,_) | Symbol_field _ -> None - | Const _ -> None - | Symbol _ -> None - | Variable _ -> None - -let translate_definitions_and_resolve_alias - inconstants - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl: - Alias_analysis.constant_defining_value Variable.Tbl.t) - symbol_definition_map - project_closure_map - ~backend = - Variable.Tbl.fold (fun var def map -> - match - translate_definition_and_resolve_alias inconstants aliases ~backend - var_to_symbol_tbl var_to_definition_tbl symbol_definition_map - project_closure_map def - with - | None -> map - | Some def -> - let symbol = Variable.Tbl.find var_to_symbol_tbl var in - Symbol.Map.add symbol def map) - var_to_definition_tbl Symbol.Map.empty - -(* Resorting of graph including Initialize_symbol *) -let constant_dependencies ~backend:_ - (const : Flambda.constant_defining_value) = - match const with - | Allocated_const _ -> Symbol.Set.empty - | Block (_, fields) -> - let symbol_fields = - List.filter_map - (function - | (Symbol s : Flambda.constant_defining_value_block_field) -> Some s - | Flambda.Const _ -> None) - fields - in - Symbol.Set.of_list symbol_fields - | Set_of_closures set_of_closures -> - Flambda.free_symbols_named (Set_of_closures set_of_closures) - | Project_closure (s, _) -> - Symbol.Set.singleton s - -module Symbol_SCC = Strongly_connected_components.Make (Symbol) - -let program_graph ~backend imported_symbols symbol_to_constant - (initialize_symbol_tbl : - (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t) - (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t) = - let expression_symbol_dependencies expr = Flambda.free_symbols expr in - let graph_with_only_constant_parts = - Symbol.Map.map (fun const -> - Symbol.Set.diff (constant_dependencies ~backend const) - imported_symbols) - symbol_to_constant - in - let graph_with_initialisation = - Symbol.Tbl.fold (fun sym (_tag, fields, previous) -> - let order_dep = - match previous with - | None -> Symbol.Set.empty - | Some previous -> Symbol.Set.singleton previous - in - let deps = List.fold_left (fun set field -> - Symbol.Set.union (expression_symbol_dependencies field) set) - order_dep fields - in - let deps = Symbol.Set.diff deps imported_symbols in - Symbol.Map.add sym deps) - initialize_symbol_tbl graph_with_only_constant_parts - in - let graph = - Symbol.Tbl.fold (fun sym (expr, previous) -> - let order_dep = - match previous with - | None -> Symbol.Set.empty - | Some previous -> Symbol.Set.singleton previous - in - let deps = - Symbol.Set.union (expression_symbol_dependencies expr) order_dep - in - let deps = Symbol.Set.diff deps imported_symbols in - Symbol.Map.add sym deps - ) - effect_tbl graph_with_initialisation - in - let components = - Symbol_SCC.connected_components_sorted_from_roots_to_leaf - graph - in - components - -(* rebuilding the program *) -let add_definition_of_symbol constant_definitions - (initialize_symbol_tbl : - (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t) - (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t) - (program : Flambda.program_body) component : Flambda.program_body = - let symbol_declaration sym = - (* A symbol declared through an Initialize_symbol construct - cannot be recursive, this is not allowed in the construction. - This also couldn't have been introduced by this pass, so we can - safely assert that this is not possible here *) - assert(not (Symbol.Tbl.mem initialize_symbol_tbl sym)); - (sym, Symbol.Map.find sym constant_definitions) - in - match component with - | Symbol_SCC.Has_loop l -> - let l = List.map symbol_declaration l in - Let_rec_symbol (l, program) - | Symbol_SCC.No_loop sym -> - match Symbol.Tbl.find initialize_symbol_tbl sym with - | (tag, fields, _previous) -> - Initialize_symbol (sym, tag, fields, program) - | exception Not_found -> - match Symbol.Tbl.find effect_tbl sym with - | (expr, _previous) -> - Effect (expr, program) - | exception Not_found -> - let decl = Symbol.Map.find sym constant_definitions in - Let_symbol (sym, decl, program) - -let add_definitions_of_symbols constant_definitions initialize_symbol_tbl - effect_tbl program components = - Array.fold_left - (add_definition_of_symbol constant_definitions initialize_symbol_tbl - effect_tbl) - program components - -let introduce_free_variables_in_set_of_closures - (var_to_block_field_tbl : - Flambda.constant_defining_value_block_field Variable.Tbl.t) - ({ Flambda.function_decls; free_vars; specialised_args; - direct_call_surrogates; } - as set_of_closures) = - let add_definition_and_make_substitution var (expr, subst) = - let searched_var = - match Variable.Map.find var specialised_args with - | exception Not_found -> var - | external_var -> - (* specialised arguments bound to constant can be rewritten *) - external_var.var - in - match Variable.Tbl.find var_to_block_field_tbl searched_var with - | def -> - let fresh = Variable.rename var in - let named : Flambda.named = match def with - | Symbol sym -> Symbol sym - | Const c -> Const c - in - (Flambda.create_let fresh named expr), Variable.Map.add var fresh subst - | exception Not_found -> - (* The variable is bound by the closure or the arguments or not - constant. In either case it does not need to be bound *) - expr, subst - in - let done_something = ref false in - let function_decls : Flambda.function_declarations = - Flambda.update_function_declarations function_decls - ~funs:(Variable.Map.map - (fun (func_decl : Flambda.function_declaration) -> - let variables_to_bind = - (* Closures from the same set must not be bound. *) - Variable.Set.diff func_decl.free_variables - (Variable.Map.keys function_decls.funs) - in - let body, subst = - Variable.Set.fold add_definition_and_make_substitution - variables_to_bind - (func_decl.body, Variable.Map.empty) - in - if Variable.Map.is_empty subst then begin - func_decl - end else begin - done_something := true; - let body = Flambda_utils.toplevel_substitution subst body in - Flambda.update_body_of_function_declaration func_decl ~body - end) - function_decls.funs) - in - let free_vars = - (* Keep only those that are not rewritten to constants. *) - Variable.Map.filter (fun v _ -> - let keep = not (Variable.Tbl.mem var_to_block_field_tbl v) in - if not keep then done_something := true; - keep) - free_vars - in - let free_vars = - Flambda_utils.clean_projections ~which_variables:free_vars - in - let specialised_args = - (* Keep only those that are not rewritten to constants. *) - Variable.Map.filter (fun _ (spec_to : Flambda.specialised_to) -> - let keep = - not (Variable.Tbl.mem var_to_block_field_tbl spec_to.var) - in - if not keep then begin - done_something := true - end; - keep) - specialised_args - in - let specialised_args = - Flambda_utils.clean_projections ~which_variables:specialised_args - in - if not !done_something then - set_of_closures - else - Flambda.create_set_of_closures ~function_decls ~free_vars - ~specialised_args ~direct_call_surrogates - -let rewrite_project_var - (var_to_block_field_tbl - : Flambda.constant_defining_value_block_field Variable.Tbl.t) - (project_var : Flambda.project_var) ~original : Flambda.named = - let var = Var_within_closure.unwrap project_var.var in - match Variable.Tbl.find var_to_block_field_tbl var with - | exception Not_found -> original - | Symbol sym -> Symbol sym - | Const const -> Const const - -let introduce_free_variables_in_sets_of_closures - (var_to_block_field_tbl: - Flambda.constant_defining_value_block_field Variable.Tbl.t) - (translate_definition : Flambda.constant_defining_value Symbol.Map.t) = - Symbol.Map.map (fun (def : Flambda.constant_defining_value) -> - match def with - | Allocated_const _ - | Block _ - | Project_closure _ -> def - | Set_of_closures set_of_closures -> - Flambda.Set_of_closures - (introduce_free_variables_in_set_of_closures - var_to_block_field_tbl - set_of_closures)) - translate_definition - -let var_to_block_field - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl : - Alias_analysis.constant_defining_value Variable.Tbl.t) = - let var_to_block_field_tbl = Variable.Tbl.create 42 in - Variable.Tbl.iter (fun var _ -> - let def = - resolve_variable aliases var_to_symbol_tbl var_to_definition_tbl var - in - Variable.Tbl.add var_to_block_field_tbl var def) - var_to_definition_tbl; - var_to_block_field_tbl - -let program_symbols ~backend (program : Flambda.program) = - let new_fake_symbol () = - let var = Variable.create Internal_variable_names.fake_effect_symbol in - Symbol.of_variable var - in - let initialize_symbol_tbl = Symbol.Tbl.create 42 in - let effect_tbl = Symbol.Tbl.create 42 in - let symbol_definition_tbl = Symbol.Tbl.create 42 in - let add_project_closure_definitions def_symbol - (const : Flambda.constant_defining_value) = - match const with - | Set_of_closures { function_decls = { funs } } -> - Variable.Map.iter (fun fun_var _ -> - let closure_id = Closure_id.wrap fun_var in - let closure_symbol = closure_symbol ~backend closure_id in - let project_closure = - Flambda.Project_closure (def_symbol, closure_id) - in - Symbol.Tbl.add symbol_definition_tbl closure_symbol - project_closure) - funs - | Project_closure _ - | Allocated_const _ - | Block _ -> () - in - let rec loop (program : Flambda.program_body) previous_effect = - match program with - | Flambda.Let_symbol (symbol, def, program) -> - add_project_closure_definitions symbol def; - Symbol.Tbl.add symbol_definition_tbl symbol def; - loop program previous_effect - | Flambda.Let_rec_symbol (defs, program) -> - List.iter (fun (symbol, def) -> - add_project_closure_definitions symbol def; - Symbol.Tbl.add symbol_definition_tbl symbol def) - defs; - loop program previous_effect - | Flambda.Initialize_symbol (symbol, tag, fields, program) -> - (* previous_effect is used to keep the order of initialize and effect - values. Their effects order must be kept ordered. - it is used as an extra dependency when sorting the symbols. *) - (* CR-someday pchambart: if the fields expressions are pure, we could - drop this dependency - mshinwell: deferred CR *) - Symbol.Tbl.add initialize_symbol_tbl symbol - (tag, fields, previous_effect); - loop program (Some symbol) - | Flambda.Effect (expr, program) -> - (* Used to ensure that effects are correctly ordered *) - let fake_effect_symbol = new_fake_symbol () in - Symbol.Tbl.add effect_tbl fake_effect_symbol (expr, previous_effect); - loop program (Some fake_effect_symbol) - | Flambda.End _ -> () - in - loop program.program_body None; - initialize_symbol_tbl, symbol_definition_tbl, effect_tbl - -let replace_definitions_in_initialize_symbol_and_effects - (inconstants : Inconstant_idents.result) - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl : - Alias_analysis.constant_defining_value Variable.Tbl.t) - (initialize_symbol_tbl : - (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t) - (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t) = - let rewrite_expr expr = - Flambda_iterators.map_all_immutable_let_and_let_rec_bindings expr - ~f:(fun var (named : Flambda.named) : Flambda.named -> - if Inconstant_idents.variable var inconstants then - named - else - let resolved = - resolve_variable - aliases - var_to_symbol_tbl - var_to_definition_tbl - var - in - match named, resolved with - | Symbol s1, Symbol s2 -> - assert (s1 == s2); (* physical equality for speed *) - named; - | Const c1, Const c2 -> - assert (c1 == c2); - named - | _, Symbol s -> Symbol s - | _, Const c -> Const c) - in - (* This is safe because we only [replace] the current key during - iteration (cf. https://github.com/ocaml/ocaml/pull/337) *) - Symbol.Tbl.iter - (fun symbol (tag, fields, previous) -> - let fields = List.map rewrite_expr fields in - Symbol.Tbl.replace initialize_symbol_tbl symbol (tag, fields, previous)) - initialize_symbol_tbl; - Symbol.Tbl.iter - (fun symbol (expr, previous) -> - Symbol.Tbl.replace effect_tbl symbol (rewrite_expr expr, previous)) - effect_tbl - -(* CR-soon mshinwell: Update the name of [project_closure_map]. *) -let project_closure_map symbol_definition_map = - Symbol.Map.fold (fun sym (const : Flambda.constant_defining_value) acc -> - match const with - | Project_closure (set_of_closures, _) -> - Symbol.Map.add sym set_of_closures acc - | Set_of_closures _ -> - Symbol.Map.add sym sym acc - | Allocated_const _ - | Block _ -> acc) - symbol_definition_map - Symbol.Map.empty - -let lift_constants (program : Flambda.program) ~backend = - let the_dead_constant = - let var = Variable.create Internal_variable_names.the_dead_constant in - Symbol.of_variable var - in - let program_body : Flambda.program_body = - Let_symbol (the_dead_constant, Allocated_const (Nativeint 0n), - program.program_body) - in - let program : Flambda.program = - { program with program_body; } - in - let inconstants = - Inconstant_idents.inconstants_on_program program ~backend - ~compilation_unit:(Compilation_unit.get_current_exn ()) - in - let initialize_symbol_tbl, symbol_definition_tbl, effect_tbl = - program_symbols ~backend program - in - let var_to_symbol_tbl, var_to_definition_tbl, let_symbol_to_definition_tbl, - initialize_symbol_to_definition_tbl = - assign_symbols_and_collect_constant_definitions ~backend ~program - ~inconstants - in - let aliases = - Alias_analysis.run var_to_definition_tbl - initialize_symbol_to_definition_tbl - let_symbol_to_definition_tbl - ~the_dead_constant - in - replace_definitions_in_initialize_symbol_and_effects - (inconstants : Inconstant_idents.result) - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl - : Alias_analysis.constant_defining_value Variable.Tbl.t) - initialize_symbol_tbl - effect_tbl; - let symbol_definition_map = - translate_constant_set_of_closures - (inconstants : Inconstant_idents.result) - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl - : Alias_analysis.constant_defining_value Variable.Tbl.t) - (Symbol.Tbl.to_map symbol_definition_tbl) - in - let project_closure_map = project_closure_map symbol_definition_map in - let translated_definitions = - translate_definitions_and_resolve_alias - inconstants - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl - : Alias_analysis.constant_defining_value Variable.Tbl.t) - symbol_definition_map - project_closure_map - ~backend - in - let var_to_block_field_tbl = - var_to_block_field - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl - : Alias_analysis.constant_defining_value Variable.Tbl.t) - in - let translated_definitions = - introduce_free_variables_in_sets_of_closures var_to_block_field_tbl - translated_definitions - in - let constant_definitions = - (* Add previous Let_symbol to the newly discovered ones *) - Symbol.Map.union - (fun _sym - (c1:Flambda.constant_defining_value) - (c2:Flambda.constant_defining_value) -> - match c1, c2 with - | Project_closure (s1, closure_id1), - Project_closure (s2, closure_id2) when - Symbol.equal s1 s2 && - Closure_id.equal closure_id1 closure_id2 -> - Some c1 - | Project_closure (s1, closure_id1), - Project_closure (s2, closure_id2) -> - Format.eprintf "not equal project closure@. s %a %a@. cid %a %a@." - Symbol.print s1 Symbol.print s2 - Closure_id.print closure_id1 Closure_id.print closure_id2; - assert false - | _ -> - assert false - ) - symbol_definition_map - translated_definitions - in - (* Upon the [Initialize_symbol]s, the [Effect]s and the constant definitions, - do the following: - 1. Introduce [Let]s to bind variables that are going to be replaced - by constants. - 2. If a variable bound by a closure gets replaced by a symbol and - thus eliminated from the [free_vars] set of the closure, we need to - rewrite any subsequent [Project_var] expressions that project that - variable. *) - let rewrite_expr expr = - Flambda_iterators.map_named (function - | (Set_of_closures set_of_closures) as named -> - let new_set_of_closures = - introduce_free_variables_in_set_of_closures - var_to_block_field_tbl set_of_closures - in - if new_set_of_closures == set_of_closures then - named - else - Set_of_closures new_set_of_closures - | (Project_var project_var) as original -> - rewrite_project_var var_to_block_field_tbl project_var ~original - | (Symbol _ | Const _ | Allocated_const _ | Project_closure _ - | Move_within_set_of_closures _ | Prim _ | Expr _ - | Read_mutable _ | Read_symbol_field _) as named -> named) - expr - in - let constant_definitions = - Symbol.Map.map (fun (const : Flambda.constant_defining_value) -> - match const with - | Allocated_const _ | Block _ | Project_closure _ -> const - | Set_of_closures set_of_closures -> - let set_of_closures = - Flambda_iterators.map_function_bodies set_of_closures - ~f:rewrite_expr - in - Flambda.Set_of_closures - (introduce_free_variables_in_set_of_closures - var_to_block_field_tbl set_of_closures)) - constant_definitions - in - let effect_tbl = - Symbol.Tbl.map effect_tbl (fun (effect, dep) -> rewrite_expr effect, dep) - in - let initialize_symbol_tbl = - Symbol.Tbl.map initialize_symbol_tbl (fun (tag, fields, dep) -> - let fields = List.map rewrite_expr fields in - tag, fields, dep) - in - let imported_symbols = Flambda_utils.imported_symbols program in - let components = - program_graph ~backend imported_symbols constant_definitions - initialize_symbol_tbl effect_tbl - in - let program_body = - add_definitions_of_symbols constant_definitions - initialize_symbol_tbl - effect_tbl - (End (Flambda_utils.root_symbol program)) - components - in - Flambda_utils.introduce_needed_import_symbols { program with program_body; } diff --git a/middle_end/lift_constants.mli b/middle_end/lift_constants.mli deleted file mode 100644 index 969c365e..00000000 --- a/middle_end/lift_constants.mli +++ /dev/null @@ -1,65 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** The aim of this pass is to assign symbols to values known to be - constant (in other words, whose values we know at compile time), with - appropriate sharing of constants, and replace the occurrences of the - constants with their corresponding symbols. - - This pass uses the results of two other passes, [Inconstant_idents] and - [Alias_analysis]. The relationship between these two deserves some - attention. - - [Inconstant_idents] is a "backwards" analysis that propagates implications - about inconstantness of variables and set of closures IDs. - - [Alias_analysis] is a "forwards" analysis that is analogous to the - propagation of [Simple_value_approx.t] values during [Inline_and_simplify]. - It gives us information about relationships between values but not actually - about their constantness. - - Combining these two into a single pass has been attempted previously, - but was not thought to be successful; this experiment could be repeated in - the future. (If "constant" is considered as "top" and "inconstant" is - considered as "bottom", then [Alias_analysis] corresponds to a least fixed - point and [Inconstant_idents] corresponds to a greatest fixed point.) - - At a high level, this pass operates as follows. Symbols are assigned to - variables known to be constant and their defining expressions examined. - Based on the results of [Alias_analysis], we simplify the destructive - elements within the defining expressions (specifically, projection of - fields from blocks), to eventually yield [Flambda.constant_defining_value]s - that are entirely constructive. These will be bound to symbols in the - resulting program. - - Another approach to this pass could be to only use the results of - [Inconstant_idents] and then repeatedly lift constants and run - [Inline_and_simplify] until a fixpoint. It was thought more robust to - instead use [Alias_analysis], where the fixpointing involves a less - complicated function. - - We still run [Inline_and_simplify] once after this pass since the lifting - of constants may enable more functions to become closed; the simplification - pass provides an easy way of cleaning up (e.g. making sure [free_vars] - maps in sets of closures are correct). -*) - -val lift_constants - : Flambda.program - -> backend:(module Backend_intf.S) - -> Flambda.program diff --git a/middle_end/lift_let_to_initialize_symbol.ml b/middle_end/lift_let_to_initialize_symbol.ml deleted file mode 100644 index ccef0d8a..00000000 --- a/middle_end/lift_let_to_initialize_symbol.ml +++ /dev/null @@ -1,298 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type ('a, 'b) kind = - | Initialisation of (Symbol.t * Tag.t * Flambda.t list) - | Effect of 'b - -let should_copy (named:Flambda.named) = - match named with - | Symbol _ | Read_symbol_field _ | Const _ -> true - | _ -> false - -type extracted = - | Expr of Variable.t * Flambda.t - | Exprs of Variable.t list * Flambda.t - | Block of Variable.t * Tag.t * Variable.t list - -type accumulated = { - copied_lets : (Variable.t * Flambda.named) list; - extracted_lets : extracted list; - terminator : Flambda.expr; -} - -let rec accumulate ~substitution ~copied_lets ~extracted_lets - (expr : Flambda.t) = - match expr with - | Let { var; body = Var var'; _ } | Let_rec ([var, _], Var var') - when Variable.equal var var' -> - { copied_lets; extracted_lets; - terminator = Flambda_utils.toplevel_substitution substitution expr; - } - (* If the pattern is what lifting let_rec generates, prevent it from being - lifted again. *) - | Let_rec (defs, - Let { var; body = Var var'; - defining_expr = Prim (Pmakeblock _, fields, _); }) - when - Variable.equal var var' - && List.for_all (fun field -> - List.exists (fun (def_var, _) -> Variable.equal def_var field) defs) - fields -> - { copied_lets; extracted_lets; - terminator = Flambda_utils.toplevel_substitution substitution expr; - } - | Let { var; defining_expr = Expr (Var alias); body; _ } - | Let_rec ([var, Expr (Var alias)], body) -> - let alias = - match Variable.Map.find alias substitution with - | exception Not_found -> alias - | original_alias -> original_alias - in - accumulate - ~substitution:(Variable.Map.add var alias substitution) - ~copied_lets - ~extracted_lets - body - | Let { var; defining_expr = named; body; _ } - | Let_rec ([var, named], body) - when should_copy named -> - accumulate body - ~substitution - ~copied_lets:((var, named)::copied_lets) - ~extracted_lets - | Let { var; defining_expr = named; body; _ } -> - let extracted = - let renamed = Variable.rename var in - match named with - | Prim (Pmakeblock (tag, Asttypes.Immutable, _value_kind), args, _dbg) -> - let tag = Tag.create_exn tag in - let args = - List.map (fun v -> - try Variable.Map.find v substitution - with Not_found -> v) - args - in - Block (var, tag, args) - | named -> - let expr = - Flambda_utils.toplevel_substitution substitution - (Flambda.create_let renamed named (Var renamed)) - in - Expr (var, expr) - in - accumulate body - ~substitution - ~copied_lets - ~extracted_lets:(extracted::extracted_lets) - | Let_rec ([var, named], body) -> - let renamed = Variable.rename var in - let def_substitution = Variable.Map.add var renamed substitution in - let expr = - Flambda_utils.toplevel_substitution def_substitution - (Let_rec ([renamed, named], Var renamed)) - in - let extracted = Expr (var, expr) in - accumulate body - ~substitution - ~copied_lets - ~extracted_lets:(extracted::extracted_lets) - | Let_rec (defs, body) -> - let renamed_defs, def_substitution = - List.fold_right (fun (var, def) (acc, substitution) -> - let new_var = Variable.rename var in - (new_var, def) :: acc, - Variable.Map.add var new_var substitution) - defs ([], substitution) - in - let extracted = - let expr = - let name = Internal_variable_names.lifted_let_rec_block in - Flambda_utils.toplevel_substitution def_substitution - (Let_rec (renamed_defs, - Flambda_utils.name_expr ~name - (Prim (Pmakeblock (0, Immutable, None), - List.map fst renamed_defs, - Debuginfo.none)))) - in - Exprs (List.map fst defs, expr) - in - accumulate body - ~substitution - ~copied_lets - ~extracted_lets:(extracted::extracted_lets) - | _ -> - { copied_lets; - extracted_lets; - terminator = Flambda_utils.toplevel_substitution substitution expr; - } - -let rebuild_expr - ~(extracted_definitions : (Symbol.t * int list) Variable.Map.t) - ~(copied_definitions : Flambda.named Variable.Map.t) - ~(substitute : bool) - (expr : Flambda.t) = - let expr_with_read_symbols = - Flambda_utils.substitute_read_symbol_field_for_variables - extracted_definitions expr - in - let free_variables = Flambda.free_variables expr_with_read_symbols in - let substitution = - if substitute then - Variable.Map.of_set (fun x -> Variable.rename x) free_variables - else - Variable.Map.of_set (fun x -> x) free_variables - in - let expr_with_read_symbols = - Flambda_utils.toplevel_substitution substitution - expr_with_read_symbols - in - Variable.Map.fold (fun var declaration body -> - let definition = Variable.Map.find var copied_definitions in - Flambda.create_let declaration definition body) - substitution expr_with_read_symbols - -let rebuild (used_variables:Variable.Set.t) (accumulated:accumulated) = - let copied_definitions = Variable.Map.of_list accumulated.copied_lets in - let accumulated_extracted_lets = - List.map (fun decl -> - match decl with - | Block (var, _, _) | Expr (var, _) -> - Symbol.of_variable (Variable.rename var), decl - | Exprs _ -> - let name = Internal_variable_names.lifted_let_rec_block in - let var = Variable.create name in - Symbol.of_variable var, decl) - accumulated.extracted_lets - in - let extracted_definitions = - (* Blocks are lifted to direct top-level Initialize_block: - accessing the value be done directly through the symbol. - Other let bound variables are initialized inside a size - one static block: - accessing the value is done directly through the field 0 - of the symbol. - let rec of size more than one is represented as a block of - all the bound variables allocated inside a size one static - block: - accessing the value is done directly through the right - field of the field 0 of the symbol. *) - List.fold_left (fun map (symbol, decl) -> - match decl with - | Block (var, _tag, _fields) -> - Variable.Map.add var (symbol, []) map - | Expr (var, _expr) -> - Variable.Map.add var (symbol, [0]) map - | Exprs (vars, _expr) -> - let map, _ = - List.fold_left (fun (map, field) var -> - Variable.Map.add var (symbol, [field; 0]) map, - field + 1) - (map, 0) vars - in - map) - Variable.Map.empty accumulated_extracted_lets - in - let extracted = - List.map (fun (symbol, decl) -> - match decl with - | Expr (var, decl) -> - let expr = - rebuild_expr ~extracted_definitions ~copied_definitions - ~substitute:true decl - in - if Variable.Set.mem var used_variables then - Initialisation - (symbol, - Tag.create_exn 0, - [expr]) - else - Effect expr - | Exprs (_vars, decl) -> - let expr = - rebuild_expr ~extracted_definitions ~copied_definitions - ~substitute:true decl - in - Initialisation (symbol, Tag.create_exn 0, [expr]) - | Block (_var, tag, fields) -> - let fields = - List.map (fun var -> - rebuild_expr ~extracted_definitions ~copied_definitions - ~substitute:true (Var var)) - fields - in - Initialisation (symbol, tag, fields)) - accumulated_extracted_lets - in - let terminator = - (* We don't need to substitute the variables in the terminator, we - suppose that we did for every other occurrence. Avoiding this - substitution allows this transformation to be idempotent. *) - rebuild_expr ~extracted_definitions ~copied_definitions - ~substitute:false accumulated.terminator - in - List.rev extracted, terminator - -let introduce_symbols expr = - let accumulated = - accumulate expr - ~substitution:Variable.Map.empty - ~copied_lets:[] ~extracted_lets:[] - in - let used_variables = Flambda.used_variables expr in - let extracted, terminator = rebuild used_variables accumulated in - extracted, terminator - -let add_extracted introduced program = - List.fold_right (fun extracted program -> - match extracted with - | Initialisation (symbol, tag, def) -> - Flambda.Initialize_symbol (symbol, tag, def, program) - | Effect effect -> - Flambda.Effect (effect, program)) - introduced program - -let rec split_program (program : Flambda.program_body) : Flambda.program_body = - match program with - | End s -> End s - | Let_symbol (s, def, program) -> - Let_symbol (s, def, split_program program) - | Let_rec_symbol (defs, program) -> - Let_rec_symbol (defs, split_program program) - | Effect (expr, program) -> - let program = split_program program in - let introduced, expr = introduce_symbols expr in - add_extracted introduced (Flambda.Effect (expr, program)) - | Initialize_symbol (symbol, tag, ((_::_::_) as fields), program) -> - (* CR-someday pchambart: currently the only initialize_symbol with more - than 1 field is the module block. This could evolve, in that case - this pattern should be handled properly. *) - Initialize_symbol (symbol, tag, fields, split_program program) - | Initialize_symbol (sym, tag, [], program) -> - Let_symbol (sym, Block (tag, []), split_program program) - | Initialize_symbol (symbol, tag, [field], program) -> - let program = split_program program in - let introduced, field = introduce_symbols field in - add_extracted introduced - (Flambda.Initialize_symbol (symbol, tag, [field], program)) - -let lift ~backend:_ (program : Flambda.program) = - { program with - program_body = split_program program.program_body; - } diff --git a/middle_end/lift_let_to_initialize_symbol.mli b/middle_end/lift_let_to_initialize_symbol.mli deleted file mode 100644 index afb1c60f..00000000 --- a/middle_end/lift_let_to_initialize_symbol.mli +++ /dev/null @@ -1,38 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Lift toplevel [Let]-expressions to Flambda [program] constructions such - that the results of evaluation of such expressions may be accessed - directly, through symbols, rather than through closures. The - [Let]-expressions typically come from the compilation of modules (using - the bytecode strategy) in [Translmod]. - - This means of compilation supersedes the old "transl_store_" methodology - for native code. - - An [Initialize_symbol] construction generated by this pass may be - subsequently rewritten to [Let_symbol] if it is discovered that the - initializer is in fact constant. (See [Initialize_symbol_to_let_symbol].) - - The [program] constructions generated by this pass will be joined by - others that arise from the lifting of constants (see [Lift_constants]). -*) -val lift - : backend:(module Backend_intf.S) - -> Flambda.program - -> Flambda.program diff --git a/middle_end/linkage_name.ml b/middle_end/linkage_name.ml new file mode 100644 index 00000000..46febfba --- /dev/null +++ b/middle_end/linkage_name.ml @@ -0,0 +1,30 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type t = string + +include Identifiable.Make (struct + include String + let hash = Hashtbl.hash + let print ppf t = Format.pp_print_string ppf t + let output chan t = output_string chan t +end) + +let create t = t +let to_string t = t diff --git a/middle_end/linkage_name.mli b/middle_end/linkage_name.mli new file mode 100644 index 00000000..58731917 --- /dev/null +++ b/middle_end/linkage_name.mli @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +include Identifiable.S + +val create : string -> t +val to_string : t -> string diff --git a/middle_end/middle_end.ml b/middle_end/middle_end.ml deleted file mode 100644 index e604a328..00000000 --- a/middle_end/middle_end.ml +++ /dev/null @@ -1,200 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let _dump_function_sizes flam ~backend = - let module Backend = (val backend : Backend_intf.S) in - let than = max_int in - Flambda_iterators.iter_on_set_of_closures_of_program flam - ~f:(fun ~constant:_ (set_of_closures : Flambda.set_of_closures) -> - Variable.Map.iter (fun fun_var - (function_decl : Flambda.function_declaration) -> - let closure_id = Closure_id.wrap fun_var in - let symbol = Backend.closure_symbol closure_id in - match Inlining_cost.lambda_smaller' function_decl.body ~than with - | Some size -> Format.eprintf "%a %d\n" Symbol.print symbol size - | None -> assert false) - set_of_closures.function_decls.funs) - -let middle_end ~ppf_dump ~prefixname ~backend - ~size - ~filename - ~module_ident - ~module_initializer = - Profile.record_call "flambda" (fun () -> - let previous_warning_reporter = !Location.warning_reporter in - let module WarningSet = - Set.Make (struct - type t = Location.t * Warnings.t - let compare = Stdlib.compare - end) - in - let warning_set = ref WarningSet.empty in - let flambda_warning_reporter loc w = - let elt = loc, w in - if not (WarningSet.mem elt !warning_set) then begin - warning_set := WarningSet.add elt !warning_set; - previous_warning_reporter loc w - end else None - in - Misc.protect_refs - [Misc.R (Location.warning_reporter, flambda_warning_reporter)] - (fun () -> - let pass_number = ref 0 in - let round_number = ref 0 in - let check flam = - if !Clflags.flambda_invariant_checks then begin - try Flambda_invariants.check_exn flam - with exn -> - Misc.fatal_errorf "After Flambda pass %d, round %d:@.%s:@.%a" - !pass_number !round_number (Printexc.to_string exn) - Flambda.print_program flam - end - in - let (+-+) flam (name, pass) = - incr pass_number; - if !Clflags.dump_flambda_verbose then begin - Format.fprintf ppf_dump "@.PASS: %s@." name; - Format.fprintf ppf_dump "Before pass %d, round %d:@ %a@." - !pass_number !round_number Flambda.print_program flam; - Format.fprintf ppf_dump "\n@?" - end; - let flam = Profile.record ~accumulate:true name pass flam in - if !Clflags.flambda_invariant_checks then begin - Profile.record ~accumulate:true "check" check flam - end; - flam - in - Profile.record_call ~accumulate:true "middle_end" (fun () -> - let flam = - Profile.record_call ~accumulate:true "closure_conversion" - (fun () -> - module_initializer - |> Closure_conversion.lambda_to_flambda ~backend - ~module_ident ~size ~filename) - in - if !Clflags.dump_rawflambda - then - Format.fprintf ppf_dump "After closure conversion:@ %a@." - Flambda.print_program flam; - check flam; - let fast_mode flam = - pass_number := 0; - let round = 0 in - flam - +-+ ("lift_lets 1", Lift_code.lift_lets) - +-+ ("Lift_constants", Lift_constants.lift_constants ~backend) - +-+ ("Share_constants", Share_constants.share_constants) - +-+ ("Lift_let_to_initialize_symbol", - Lift_let_to_initialize_symbol.lift ~backend) - +-+ ("Inline_and_simplify", - Inline_and_simplify.run ~never_inline:false ~backend - ~prefixname ~round ~ppf_dump) - +-+ ("Remove_unused_closure_vars 2", - Remove_unused_closure_vars.remove_unused_closure_variables - ~remove_direct_call_surrogates:false) - +-+ ("Ref_to_variables", - Ref_to_variables.eliminate_ref) - +-+ ("Initialize_symbol_to_let_symbol", - Initialize_symbol_to_let_symbol.run) - in - let rec loop flam = - pass_number := 0; - let round = !round_number in - incr round_number; - if !round_number > (Clflags.rounds ()) then flam - else - flam - (* Beware: [Lift_constants] must be run before any pass that - might duplicate strings. *) - +-+ ("lift_lets 1", Lift_code.lift_lets) - +-+ ("Lift_constants", Lift_constants.lift_constants ~backend) - +-+ ("Share_constants", Share_constants.share_constants) - +-+ ("Remove_unused_program_constructs", - Remove_unused_program_constructs.remove_unused_program_constructs) - +-+ ("Lift_let_to_initialize_symbol", - Lift_let_to_initialize_symbol.lift ~backend) - +-+ ("lift_lets 2", Lift_code.lift_lets) - +-+ ("Remove_unused_closure_vars 1", - Remove_unused_closure_vars.remove_unused_closure_variables - ~remove_direct_call_surrogates:false) - +-+ ("Inline_and_simplify", - Inline_and_simplify.run ~never_inline:false ~backend - ~prefixname ~round ~ppf_dump) - +-+ ("Remove_unused_closure_vars 2", - Remove_unused_closure_vars.remove_unused_closure_variables - ~remove_direct_call_surrogates:false) - +-+ ("lift_lets 3", Lift_code.lift_lets) - +-+ ("Inline_and_simplify noinline", - Inline_and_simplify.run ~never_inline:true ~backend - ~prefixname ~round ~ppf_dump) - +-+ ("Remove_unused_closure_vars 3", - Remove_unused_closure_vars.remove_unused_closure_variables - ~remove_direct_call_surrogates:false) - +-+ ("Ref_to_variables", - Ref_to_variables.eliminate_ref) - +-+ ("Initialize_symbol_to_let_symbol", - Initialize_symbol_to_let_symbol.run) - |> loop - in - let back_end flam = - flam - +-+ ("Remove_unused_closure_vars", - Remove_unused_closure_vars.remove_unused_closure_variables - ~remove_direct_call_surrogates:true) - +-+ ("Lift_constants", Lift_constants.lift_constants ~backend) - +-+ ("Share_constants", Share_constants.share_constants) - +-+ ("Remove_unused_program_constructs", - Remove_unused_program_constructs.remove_unused_program_constructs) - in - let flam = - if !Clflags.classic_inlining then - fast_mode flam - else - loop flam - in - let flam = back_end flam in - (* Check that there aren't any unused "always inline" attributes. *) - Flambda_iterators.iter_apply_on_program flam ~f:(fun apply -> - match apply.inline with - | Default_inline | Never_inline -> () - | Always_inline -> - (* CR-someday mshinwell: consider a different error message if - this triggers as a result of the propagation of a user's - attribute into the second part of an over application - (inline_and_simplify.ml line 710). *) - Location.prerr_warning (Debuginfo.to_location apply.dbg) - (Warnings.Inlining_impossible - "[@inlined] attribute was not used on this function \ - application (the optimizer did not know what function \ - was being applied)") - | Unroll _ -> - Location.prerr_warning (Debuginfo.to_location apply.dbg) - (Warnings.Inlining_impossible - "[@unroll] attribute was not used on this function \ - application (the optimizer did not know what function \ - was being applied)")); - if !Clflags.dump_flambda - then - Format.fprintf ppf_dump "End of middle end:@ %a@." - Flambda.print_program flam; - check flam; - (* CR-someday mshinwell: add -d... option for this *) - (* dump_function_sizes flam ~backend; *) - flam)) - ) diff --git a/middle_end/middle_end.mli b/middle_end/middle_end.mli deleted file mode 100644 index 584cb45a..00000000 --- a/middle_end/middle_end.mli +++ /dev/null @@ -1,29 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(* Translate Lambda code to Flambda code and then optimize it. *) - -val middle_end - : ppf_dump:Format.formatter - -> prefixname:string - -> backend:(module Backend_intf.S) - -> size:int - -> filename:string - -> module_ident:Ident.t - -> module_initializer:Lambda.lambda - -> Flambda.program diff --git a/middle_end/parameter.ml b/middle_end/parameter.ml deleted file mode 100644 index 0c916dd7..00000000 --- a/middle_end/parameter.ml +++ /dev/null @@ -1,69 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -[@@@ocaml.warning "+9"] -(* Warning 9 is enabled to ensure correct update of each function when - a field is added to type parameter *) - -type parameter = { - var : Variable.t; -} - -let wrap var = { var } - -let var p = p.var - -module M = - Identifiable.Make (struct - type t = parameter - - let compare { var = var1 } { var = var2 } = - Variable.compare var1 var2 - - let equal { var = var1 } { var = var2 } = - Variable.equal var1 var2 - - let hash { var } = - Variable.hash var - - let print ppf { var } = - Variable.print ppf var - - let output o { var } = - Variable.output o var - end) - -module T = M.T -include T - -module Map = M.Map -module Tbl = M.Tbl -module Set = struct - include M.Set - let vars l = Variable.Set.of_list (List.map var l) -end - -let rename ?current_compilation_unit p = - { var = Variable.rename ?current_compilation_unit p.var } - -let map_var f { var } = { var = f var } - -module List = struct - let vars params = List.map (fun { var } -> var) params -end diff --git a/middle_end/parameter.mli b/middle_end/parameter.mli deleted file mode 100644 index ceed1678..00000000 --- a/middle_end/parameter.mli +++ /dev/null @@ -1,52 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** [Parameter.t] carries a unique [Variable.t] used as function parameter. - It can also carry annotations about the usage of the variable. *) - -type t -type parameter = t - -(** Make a parameter from a variable with default attributes *) -val wrap : Variable.t -> t - -val var : t -> Variable.t - -(** Rename the inner variable of the parameter *) -val rename - : ?current_compilation_unit:Compilation_unit.t - -> t - -> t - -val map_var : (Variable.t -> Variable.t) -> t -> t - -module T : Identifiable.Thing with type t = t - -module Set : sig - include Identifiable.Set with module T := T - val vars : parameter list -> Variable.Set.t -end - -include Identifiable.S with type t := t - and module T := T - and module Set := Set - -module List : sig - (** extract variables from a list of parameters, preserving the order *) - val vars : t list -> Variable.t list -end diff --git a/middle_end/pass_wrapper.ml b/middle_end/pass_wrapper.ml deleted file mode 100644 index a2005332..00000000 --- a/middle_end/pass_wrapper.ml +++ /dev/null @@ -1,35 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let register ~pass_name = - Clflags.all_passes := pass_name :: !Clflags.all_passes - -let with_dump ~ppf_dump ~pass_name ~f ~input ~print_input ~print_output = - let dump = Clflags.dumped_pass pass_name in - let result = f () in - match result with - | None -> - if dump then Format.fprintf ppf_dump "%s: no-op.\n\n%!" pass_name; - None - | Some result -> - if dump then begin - Format.fprintf ppf_dump "Before %s:@ %a@.@." pass_name print_input input; - Format.fprintf ppf_dump "After %s:@ %a@.@." pass_name print_output result; - end; - Some result diff --git a/middle_end/pass_wrapper.mli b/middle_end/pass_wrapper.mli deleted file mode 100644 index 3a30e61d..00000000 --- a/middle_end/pass_wrapper.mli +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -val register : pass_name:string -> unit - -val with_dump - : ppf_dump:Format.formatter - -> pass_name:string - -> f:(unit -> 'b option) - -> input:'a - -> print_input:(Format.formatter -> 'a -> unit) - -> print_output:(Format.formatter -> 'b -> unit) - -> 'b option diff --git a/middle_end/printclambda.ml b/middle_end/printclambda.ml new file mode 100644 index 00000000..fceb3485 --- /dev/null +++ b/middle_end/printclambda.ml @@ -0,0 +1,272 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + +open Format +open Asttypes +open Clambda + +module V = Backend_var +module VP = Backend_var.With_provenance + +let mutable_flag = function + | Mutable-> "[mut]" + | Immutable -> "" + +let value_kind = + let open Lambda in + function + | Pgenval -> "" + | Pintval -> ":int" + | Pfloatval -> ":float" + | Pboxedintval Pnativeint -> ":nativeint" + | Pboxedintval Pint32 -> ":int32" + | Pboxedintval Pint64 -> ":int64" + +let rec structured_constant ppf = function + | Uconst_float x -> fprintf ppf "%F" x + | Uconst_int32 x -> fprintf ppf "%ldl" x + | Uconst_int64 x -> fprintf ppf "%LdL" x + | Uconst_nativeint x -> fprintf ppf "%ndn" x + | Uconst_block (tag, l) -> + fprintf ppf "block(%i" tag; + List.iter (fun u -> fprintf ppf ",%a" uconstant u) l; + fprintf ppf ")" + | Uconst_float_array [] -> + fprintf ppf "floatarray()" + | Uconst_float_array (f1 :: fl) -> + fprintf ppf "floatarray(%F" f1; + List.iter (fun f -> fprintf ppf ",%F" f) fl; + fprintf ppf ")" + | Uconst_string s -> fprintf ppf "%S" s + | Uconst_closure(clos, sym, fv) -> + let funs ppf = + List.iter (fprintf ppf "@ %a" one_fun) in + let sconsts ppf scl = + List.iter (fun sc -> fprintf ppf "@ %a" uconstant sc) scl in + fprintf ppf "@[<2>(const_closure%a %s@ %a)@]" funs clos sym sconsts fv + +and one_fun ppf f = + let idents ppf = + List.iter + (fun (x, k) -> + fprintf ppf "@ %a%a" + VP.print x + Printlambda.value_kind k + ) + in + fprintf ppf "(fun@ %s%s@ %d@ @[<2>%a@]@ @[<2>%a@])" + f.label (value_kind f.return) f.arity idents f.params lam f.body + +and phantom_defining_expr ppf = function + | Uphantom_const const -> uconstant ppf const + | Uphantom_var var -> Ident.print ppf var + | Uphantom_offset_var { var; offset_in_words; } -> + Format.fprintf ppf "%a+(%d)" Backend_var.print var offset_in_words + | Uphantom_read_field { var; field; } -> + Format.fprintf ppf "%a[%d]" Backend_var.print var field + | Uphantom_read_symbol_field { sym; field; } -> + Format.fprintf ppf "%s[%d]" sym field + | Uphantom_block { tag; fields; } -> + Format.fprintf ppf "[%d: " tag; + List.iter (fun field -> + Format.fprintf ppf "%a; " Backend_var.print field) + fields; + Format.fprintf ppf "]" + +and phantom_defining_expr_opt ppf = function + | None -> Format.fprintf ppf "DEAD" + | Some expr -> phantom_defining_expr ppf expr + +and uconstant ppf = function + | Uconst_ref (s, Some c) -> + fprintf ppf "%S=%a" s structured_constant c + | Uconst_ref (s, None) -> fprintf ppf "%S"s + | Uconst_int i -> fprintf ppf "%i" i + | Uconst_ptr i -> fprintf ppf "%ia" i + +and lam ppf = function + | Uvar id -> + V.print ppf id + | Uconst c -> uconstant ppf c + | Udirect_apply(f, largs, _) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(apply*@ %s %a)@]" f lams largs + | Ugeneric_apply(lfun, largs, _) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs + | Uclosure(clos, fv) -> + let funs ppf = + List.iter (fprintf ppf "@ @[<2>%a@]" one_fun) in + let lams ppf = + List.iter (fprintf ppf "@ %a" lam) in + fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv + | Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i + | Ulet(mut, kind, id, arg, body) -> + let rec letbody ul = match ul with + | Ulet(mut, kind, id, arg, body) -> + fprintf ppf "@ @[<2>%a%s%s@ %a@]" + VP.print id + (mutable_flag mut) (value_kind kind) lam arg; + letbody body + | _ -> ul in + fprintf ppf "@[<2>(let@ @[(@[<2>%a%s%s@ %a@]" + VP.print id (mutable_flag mut) + (value_kind kind) lam arg; + let expr = letbody body in + fprintf ppf ")@]@ %a)@]" lam expr + | Uphantom_let (id, defining_expr, body) -> + let rec letbody ul = match ul with + | Uphantom_let (id, defining_expr, body) -> + fprintf ppf "@ @[<2>%a@ %a@]" + Backend_var.With_provenance.print id + phantom_defining_expr_opt defining_expr; + letbody body + | _ -> ul in + fprintf ppf "@[<2>(phantom_let@ @[(@[<2>%a@ %a@]" + Backend_var.With_provenance.print id + phantom_defining_expr_opt defining_expr; + let expr = letbody body in + fprintf ppf ")@]@ %a)@]" lam expr + | Uletrec(id_arg_list, body) -> + let bindings ppf id_arg_list = + let spc = ref false in + List.iter + (fun (id, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<2>%a@ %a@]" + VP.print id + lam l) + id_arg_list in + fprintf ppf + "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body + | Uprim(prim, largs, _) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(%a%a)@]" + Printclambda_primitives.primitive prim lams largs + | Uswitch(larg, sw, _dbg) -> + let print_case tag index i ppf = + for j = 0 to Array.length index - 1 do + if index.(j) = i then fprintf ppf "case %s %i:" tag j + done in + let print_cases tag index cases ppf = + for i = 0 to Array.length cases - 1 do + fprintf ppf "@ @[<2>%t@ %a@]" + (print_case tag index i) sequence cases.(i) + done in + let switch ppf sw = + print_cases "int" sw.us_index_consts sw.us_actions_consts ppf ; + print_cases "tag" sw.us_index_blocks sw.us_actions_blocks ppf in + fprintf ppf + "@[@[<2>(switch@ %a@ @]%a)@]" + lam larg switch sw + | Ustringswitch(larg,sw,d) -> + let switch ppf sw = + let spc = ref false in + List.iter + (fun (s,l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case \"%s\":@ %a@]" + (String.escaped s) lam l) + sw ; + begin match d with + | Some d -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam d + | None -> () + end in + fprintf ppf + "@[<1>(switch %a@ @[%a@])@]" lam larg switch sw + | Ustaticfail (i, ls) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls; + | Ucatch(i, vars, lbody, lhandler) -> + fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" + lam lbody i + (fun ppf vars -> + List.iter + (fun (x, k) -> + fprintf ppf " %a%a" + VP.print x + Printlambda.value_kind k + ) + vars + ) + vars + lam lhandler + | Utrywith(lbody, param, lhandler) -> + fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" + lam lbody VP.print param lam lhandler + | Uifthenelse(lcond, lif, lelse) -> + fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse + | Usequence(l1, l2) -> + fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 + | Uwhile(lcond, lbody) -> + fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody + | Ufor(param, lo, hi, dir, body) -> + fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" + VP.print param lam lo + (match dir with Upto -> "to" | Downto -> "downto") + lam hi lam body + | Uassign(id, expr) -> + fprintf ppf "@[<2>(assign@ %a@ %a)@]" V.print id lam expr + | Usend (k, met, obj, largs, _) -> + let args ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + let kind = + if k = Lambda.Self then "self" + else if k = Lambda.Cached then "cache" + else "" in + fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs + | Uunreachable -> + fprintf ppf "unreachable" + +and sequence ppf ulam = match ulam with + | Usequence(l1, l2) -> + fprintf ppf "%a@ %a" sequence l1 sequence l2 + | _ -> lam ppf ulam + +let clambda ppf ulam = + fprintf ppf "%a@." lam ulam + + +let rec approx ppf = function + Value_closure(fundesc, a) -> + Format.fprintf ppf "@[<2>function %s@ arity %i" + fundesc.fun_label fundesc.fun_arity; + if fundesc.fun_closed then begin + Format.fprintf ppf "@ (closed)" + end; + if fundesc.fun_inline <> None then begin + Format.fprintf ppf "@ (inline)" + end; + Format.fprintf ppf "@ -> @ %a@]" approx a + | Value_tuple a -> + let tuple ppf a = + for i = 0 to Array.length a - 1 do + if i > 0 then Format.fprintf ppf ";@ "; + Format.fprintf ppf "%i: %a" i approx a.(i) + done in + Format.fprintf ppf "@[(%a)@]" tuple a + | Value_unknown -> + Format.fprintf ppf "_" + | Value_const c -> + fprintf ppf "@[const(%a)@]" uconstant c + | Value_global_field (s, i) -> + fprintf ppf "@[global(%s,%i)@]" s i diff --git a/middle_end/printclambda.mli b/middle_end/printclambda.mli new file mode 100644 index 00000000..121667e2 --- /dev/null +++ b/middle_end/printclambda.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Clambda +open Format + +val clambda: formatter -> ulambda -> unit +val approx: formatter -> value_approximation -> unit +val structured_constant: formatter -> ustructured_constant -> unit + +val phantom_defining_expr_opt + : formatter + -> uphantom_defining_expr option + -> unit diff --git a/middle_end/printclambda_primitives.ml b/middle_end/printclambda_primitives.ml new file mode 100644 index 00000000..3f627063 --- /dev/null +++ b/middle_end/printclambda_primitives.ml @@ -0,0 +1,202 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + +open Format +open Asttypes + +let boxed_integer_name = function + | Lambda.Pnativeint -> "nativeint" + | Lambda.Pint32 -> "int32" + | Lambda.Pint64 -> "int64" + +let boxed_integer_mark name = function + | Lambda.Pnativeint -> Printf.sprintf "Nativeint.%s" name + | Lambda.Pint32 -> Printf.sprintf "Int32.%s" name + | Lambda.Pint64 -> Printf.sprintf "Int64.%s" name + +let print_boxed_integer name ppf bi = + fprintf ppf "%s" (boxed_integer_mark name bi);; + +let array_kind array_kind = + let open Lambda in + match array_kind with + | Pgenarray -> "gen" + | Paddrarray -> "addr" + | Pintarray -> "int" + | Pfloatarray -> "float" + +let access_size size = + let open Clambda_primitives in + match size with + | Sixteen -> "16" + | Thirty_two -> "32" + | Sixty_four -> "64" + +let access_safety safety = + let open Lambda in + match safety with + | Safe -> "" + | Unsafe -> "unsafe_" + +let primitive ppf (prim:Clambda_primitives.primitive) = + let open Lambda in + let open Clambda_primitives in + match prim with + | Pread_symbol sym -> + fprintf ppf "read_symbol %s" sym + | Pmakeblock(tag, Immutable, shape) -> + fprintf ppf "makeblock %i%a" tag Printlambda.block_shape shape + | Pmakeblock(tag, Mutable, shape) -> + fprintf ppf "makemutable %i%a" tag Printlambda.block_shape shape + | Pfield n -> fprintf ppf "field %i" n + | Pfield_computed -> fprintf ppf "field_computed" + | Psetfield(n, ptr, init) -> + let instr = + match ptr with + | Pointer -> "ptr" + | Immediate -> "imm" + in + let init = + match init with + | Heap_initialization -> "(heap-init)" + | Root_initialization -> "(root-init)" + | Assignment -> "" + in + fprintf ppf "setfield_%s%s %i" instr init n + | Psetfield_computed (ptr, init) -> + let instr = + match ptr with + | Pointer -> "ptr" + | Immediate -> "imm" + in + let init = + match init with + | Heap_initialization -> "(heap-init)" + | Root_initialization -> "(root-init)" + | Assignment -> "" + in + fprintf ppf "setfield_%s%s_computed" instr init + | Pfloatfield n -> fprintf ppf "floatfield %i" n + | Psetfloatfield (n, init) -> + let init = + match init with + | Heap_initialization -> "(heap-init)" + | Root_initialization -> "(root-init)" + | Assignment -> "" + in + fprintf ppf "setfloatfield%s %i" init n + | Pduprecord (rep, size) -> + fprintf ppf "duprecord %a %i" Printlambda.record_rep rep size + | Pccall p -> fprintf ppf "%s" p.Primitive.prim_name + | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) + | Psequand -> fprintf ppf "&&" + | Psequor -> fprintf ppf "||" + | Pnot -> fprintf ppf "not" + | Pnegint -> fprintf ppf "~" + | Paddint -> fprintf ppf "+" + | Psubint -> fprintf ppf "-" + | Pmulint -> fprintf ppf "*" + | Pdivint Safe -> fprintf ppf "/" + | Pdivint Unsafe -> fprintf ppf "/u" + | Pmodint Safe -> fprintf ppf "mod" + | Pmodint Unsafe -> fprintf ppf "mod_unsafe" + | Pandint -> fprintf ppf "and" + | Porint -> fprintf ppf "or" + | Pxorint -> fprintf ppf "xor" + | Plslint -> fprintf ppf "lsl" + | Plsrint -> fprintf ppf "lsr" + | Pasrint -> fprintf ppf "asr" + | Pintcomp(cmp) -> Printlambda.integer_comparison ppf cmp + | Poffsetint n -> fprintf ppf "%i+" n + | Poffsetref n -> fprintf ppf "+:=%i"n + | Pintoffloat -> fprintf ppf "int_of_float" + | Pfloatofint -> fprintf ppf "float_of_int" + | Pnegfloat -> fprintf ppf "~." + | Pabsfloat -> fprintf ppf "abs." + | Paddfloat -> fprintf ppf "+." + | Psubfloat -> fprintf ppf "-." + | Pmulfloat -> fprintf ppf "*." + | Pdivfloat -> fprintf ppf "/." + | Pfloatcomp(cmp) -> Printlambda.float_comparison ppf cmp + | Pstringlength -> fprintf ppf "string.length" + | Pstringrefu -> fprintf ppf "string.unsafe_get" + | Pstringrefs -> fprintf ppf "string.get" + | Pbyteslength -> fprintf ppf "bytes.length" + | Pbytesrefu -> fprintf ppf "bytes.unsafe_get" + | Pbytessetu -> fprintf ppf "bytes.unsafe_set" + | Pbytesrefs -> fprintf ppf "bytes.get" + | Pbytessets -> fprintf ppf "bytes.set" + + | Parraylength k -> fprintf ppf "array.length[%s]" (array_kind k) + | Pmakearray (k, Mutable) -> fprintf ppf "makearray[%s]" (array_kind k) + | Pmakearray (k, Immutable) -> fprintf ppf "makearray_imm[%s]" (array_kind k) + | Pduparray (k, Mutable) -> fprintf ppf "duparray[%s]" (array_kind k) + | Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k) + | Parrayrefu k -> fprintf ppf "array.unsafe_get[%s]" (array_kind k) + | Parraysetu k -> fprintf ppf "array.unsafe_set[%s]" (array_kind k) + | Parrayrefs k -> fprintf ppf "array.get[%s]" (array_kind k) + | Parraysets k -> fprintf ppf "array.set[%s]" (array_kind k) + | Pisint -> fprintf ppf "isint" + | Pisout -> fprintf ppf "isout" + | Pbintofint bi -> print_boxed_integer "of_int" ppf bi + | Pintofbint bi -> print_boxed_integer "to_int" ppf bi + | Pcvtbint (bi1, bi2) -> + fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1) + | Pnegbint bi -> print_boxed_integer "neg" ppf bi + | Paddbint bi -> print_boxed_integer "add" ppf bi + | Psubbint bi -> print_boxed_integer "sub" ppf bi + | Pmulbint bi -> print_boxed_integer "mul" ppf bi + | Pdivbint { size = bi; is_safe = Safe } -> + print_boxed_integer "div" ppf bi + | Pdivbint { size = bi; is_safe = Unsafe } -> + print_boxed_integer "div_unsafe" ppf bi + | Pmodbint { size = bi; is_safe = Safe } -> + print_boxed_integer "mod" ppf bi + | Pmodbint { size = bi; is_safe = Unsafe } -> + print_boxed_integer "mod_unsafe" ppf bi + | Pandbint bi -> print_boxed_integer "and" ppf bi + | Porbint bi -> print_boxed_integer "or" ppf bi + | Pxorbint bi -> print_boxed_integer "xor" ppf bi + | Plslbint bi -> print_boxed_integer "lsl" ppf bi + | Plsrbint bi -> print_boxed_integer "lsr" ppf bi + | Pasrbint bi -> print_boxed_integer "asr" ppf bi + | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi + | Pbintcomp(bi, Cne) -> print_boxed_integer "!=" ppf bi + | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi + | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi + | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi + | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi + | Pbigarrayref(unsafe, _n, kind, layout) -> + Printlambda.print_bigarray "get" unsafe kind ppf layout + | Pbigarrayset(unsafe, _n, kind, layout) -> + Printlambda.print_bigarray "set" unsafe kind ppf layout + | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n + | Pstring_load(size, safety) -> + fprintf ppf "string.%sget%s" (access_safety safety) (access_size size) + | Pbytes_load(size, safety) -> + fprintf ppf "bytes.%sget%s" (access_safety safety) (access_size size) + | Pbytes_set(size, safety) -> + fprintf ppf "bytes.%sset%s" (access_safety safety) (access_size size) + | Pbigstring_load(size, safety) -> + fprintf ppf "bigarray.array1.%sget%s" + (access_safety safety) (access_size size) + | Pbigstring_set(size, safety) -> + fprintf ppf "bigarray.array1.%sset%s" + (access_safety safety) (access_size size) + | Pbswap16 -> fprintf ppf "bswap16" + | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi + | Pint_as_pointer -> fprintf ppf "int_as_pointer" + | Popaque -> fprintf ppf "opaque" diff --git a/middle_end/printclambda_primitives.mli b/middle_end/printclambda_primitives.mli new file mode 100644 index 00000000..07db5a1c --- /dev/null +++ b/middle_end/printclambda_primitives.mli @@ -0,0 +1,18 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Format + +val primitive: formatter -> Clambda_primitives.primitive -> unit diff --git a/middle_end/projection.ml b/middle_end/projection.ml deleted file mode 100644 index 2c660a2a..00000000 --- a/middle_end/projection.ml +++ /dev/null @@ -1,170 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -(* CR-someday mshinwell: Move these three types into their own modules. *) - -type project_closure = { - set_of_closures : Variable.t; - closure_id : Closure_id.t; -} - -type move_within_set_of_closures = { - closure : Variable.t; - start_from : Closure_id.t; - move_to : Closure_id.t; -} - -type project_var = { - closure : Variable.t; - closure_id : Closure_id.t; - var : Var_within_closure.t; -} - -let compare_project_var - ({ closure = closure1; closure_id = closure_id1; var = var1; } - : project_var) - ({ closure = closure2; closure_id = closure_id2; var = var2; } - : project_var) = - let c = Variable.compare closure1 closure2 in - if c <> 0 then c - else - let c = Closure_id.compare closure_id1 closure_id2 in - if c <> 0 then c - else - Var_within_closure.compare var1 var2 - -let compare_move_within_set_of_closures - ({ closure = closure1; start_from = start_from1; move_to = move_to1; } - : move_within_set_of_closures) - ({ closure = closure2; start_from = start_from2; move_to = move_to2; } - : move_within_set_of_closures) = - let c = Variable.compare closure1 closure2 in - if c <> 0 then c - else - let c = Closure_id.compare start_from1 start_from2 in - if c <> 0 then c - else - Closure_id.compare move_to1 move_to2 - -let compare_project_closure - ({ set_of_closures = set_of_closures1; closure_id = closure_id1; } - : project_closure) - ({ set_of_closures = set_of_closures2; closure_id = closure_id2; } - : project_closure) = - let c = Variable.compare set_of_closures1 set_of_closures2 in - if c <> 0 then c - else - Closure_id.compare closure_id1 closure_id2 - -let print_project_closure ppf (project_closure : project_closure) = - Format.fprintf ppf "@[<2>(project_closure@ %a@ from@ %a)@]" - Closure_id.print project_closure.closure_id - Variable.print project_closure.set_of_closures - -let print_move_within_set_of_closures ppf - (move_within_set_of_closures : move_within_set_of_closures) = - Format.fprintf ppf - "@[<2>(move_within_set_of_closures@ %a <-- %a@ (closure = %a))@]" - Closure_id.print move_within_set_of_closures.move_to - Closure_id.print move_within_set_of_closures.start_from - Variable.print move_within_set_of_closures.closure - -let print_project_var ppf (project_var : project_var) = - Format.fprintf ppf "@[<2>(project_var@ %a@ from %a=%a)@]" - Var_within_closure.print project_var.var - Closure_id.print project_var.closure_id - Variable.print project_var.closure - -type t = - | Project_var of project_var - | Project_closure of project_closure - | Move_within_set_of_closures of move_within_set_of_closures - | Field of int * Variable.t - -include Identifiable.Make (struct - type nonrec t = t - - let compare t1 t2 = - match t1, t2 with - | Project_var project_var1, Project_var project_var2 -> - compare_project_var project_var1 project_var2 - | Project_closure project_closure1, Project_closure project_closure2 -> - compare_project_closure project_closure1 project_closure2 - | Move_within_set_of_closures move1, Move_within_set_of_closures move2 -> - compare_move_within_set_of_closures move1 move2 - | Field (index1, var1), Field (index2, var2) -> - let c = compare index1 index2 in - if c <> 0 then c - else Variable.compare var1 var2 - | Project_var _, _ -> -1 - | _, Project_var _ -> 1 - | Project_closure _, _ -> -1 - | _, Project_closure _ -> 1 - | Move_within_set_of_closures _, _ -> -1 - | _, Move_within_set_of_closures _ -> 1 - - let equal t1 t2 = - (compare t1 t2) = 0 - - let hash = Hashtbl.hash - - let print ppf t = - match t with - | Project_closure (project_closure) -> - print_project_closure ppf project_closure - | Project_var (project_var) -> print_project_var ppf project_var - | Move_within_set_of_closures (move_within_set_of_closures) -> - print_move_within_set_of_closures ppf move_within_set_of_closures - | Field (field_index, var) -> - Format.fprintf ppf "Field %d of %a" field_index Variable.print var - - let output _ _ = failwith "Projection.output: not yet implemented" -end) - -let projecting_from t = - match t with - | Project_var { closure; _ } -> closure - | Project_closure { set_of_closures; _ } -> set_of_closures - | Move_within_set_of_closures { closure; _ } -> closure - | Field (_, var) -> var - -let map_projecting_from t ~f : t = - match t with - | Project_var project_var -> - let project_var : project_var = - { project_var with - closure = f project_var.closure; - } - in - Project_var project_var - | Project_closure project_closure -> - let project_closure : project_closure = - { project_closure with - set_of_closures = f project_closure.set_of_closures; - } - in - Project_closure project_closure - | Move_within_set_of_closures move -> - let move : move_within_set_of_closures = - { move with - closure = f move.closure; - } - in - Move_within_set_of_closures move - | Field (field_index, var) -> Field (field_index, f var) diff --git a/middle_end/projection.mli b/middle_end/projection.mli deleted file mode 100644 index 1b251ca2..00000000 --- a/middle_end/projection.mli +++ /dev/null @@ -1,80 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Representation of projections from closures and blocks. *) - -(** The selection of one closure given a set of closures, required before - a function defined by said set of closures can be applied. See more - detailed documentation below on [set_of_closures]. *) -type project_closure = { - set_of_closures : Variable.t; (** must yield a set of closures *) - closure_id : Closure_id.t; -} - -(** The selection of one closure given another closure in the same set of - closures. See more detailed documentation below on [set_of_closures]. - The [move_to] closure must be part of the free variables of - [start_from]. *) -type move_within_set_of_closures = { - closure : Variable.t; (** must yield a closure *) - start_from : Closure_id.t; - move_to : Closure_id.t; -} - -(** The selection from a closure of a variable bound by said closure. - In other words, access to a function's environment. Also see more - detailed documentation below on [set_of_closures]. *) -type project_var = { - closure : Variable.t; (** must yield a closure *) - closure_id : Closure_id.t; - var : Var_within_closure.t; -} - -val print_project_closure - : Format.formatter - -> project_closure - -> unit - -val print_move_within_set_of_closures - : Format.formatter - -> move_within_set_of_closures - -> unit - -val print_project_var - : Format.formatter - -> project_var - -> unit - -val compare_project_var : project_var -> project_var -> int -val compare_project_closure : project_closure -> project_closure -> int -val compare_move_within_set_of_closures - : move_within_set_of_closures - -> move_within_set_of_closures - -> int - -type t = - | Project_var of project_var - | Project_closure of project_closure - | Move_within_set_of_closures of move_within_set_of_closures - | Field of int * Variable.t - -include Identifiable.S with type t := t - -(** Return which variable the given projection projects from. *) -val projecting_from : t -> Variable.t - -(** Change the variable that the given projection projects from. *) -val map_projecting_from : t -> f:(Variable.t -> Variable.t) -> t diff --git a/middle_end/ref_to_variables.ml b/middle_end/ref_to_variables.ml deleted file mode 100644 index f93948f9..00000000 --- a/middle_end/ref_to_variables.ml +++ /dev/null @@ -1,199 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let variables_not_used_as_local_reference (tree:Flambda.t) = - let set = ref Variable.Set.empty in - let rec loop_named (flam : Flambda.named) = - match flam with - (* Directly used block: does not prevent use as a variable *) - | Prim(Pfield _, [_], _) - | Prim(Poffsetref _, [_], _) -> () - | Prim(Psetfield _, [_block; v], _) -> - (* block is not prevented to be used as a local reference, but v is *) - set := Variable.Set.add v !set - | Prim(_, _, _) - | Symbol _ |Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ | Project_closure _ - | Move_within_set_of_closures _ | Project_var _ -> - set := Variable.Set.union !set (Flambda.free_variables_named flam) - | Set_of_closures set_of_closures -> - set := Variable.Set.union !set (Flambda.free_variables_named flam); - Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) -> - loop function_decl.body) - set_of_closures.function_decls.funs - | Expr e -> - loop e - and loop (flam : Flambda.t) = - match flam with - | Let { defining_expr; body; _ } -> - loop_named defining_expr; - loop body - | Let_rec (defs, body) -> - List.iter (fun (_var, named) -> loop_named named) defs; - loop body - | Var v -> - set := Variable.Set.add v !set - | Let_mutable { initial_value = v; body } -> - set := Variable.Set.add v !set; - loop body - | If_then_else (cond, ifso, ifnot) -> - set := Variable.Set.add cond !set; - loop ifso; - loop ifnot - | Switch (cond, { consts; blocks; failaction }) -> - set := Variable.Set.add cond !set; - List.iter (fun (_, branch) -> loop branch) consts; - List.iter (fun (_, branch) -> loop branch) blocks; - Misc.may loop failaction - | String_switch (cond, branches, default) -> - set := Variable.Set.add cond !set; - List.iter (fun (_, branch) -> loop branch) branches; - Misc.may loop default - | Static_catch (_, _, body, handler) -> - loop body; - loop handler - | Try_with (body, _, handler) -> - loop body; - loop handler - | While (cond, body) -> - loop cond; - loop body - | For { bound_var = _; from_value; to_value; direction = _; body; } -> - set := Variable.Set.add from_value !set; - set := Variable.Set.add to_value !set; - loop body - | Static_raise (_, args) -> - set := Variable.Set.union (Variable.Set.of_list args) !set - | Proved_unreachable | Apply _ | Send _ | Assign _ -> - set := Variable.Set.union !set (Flambda.free_variables flam) - in - loop tree; - !set - -let variables_containing_ref (flam:Flambda.t) = - let map = ref Variable.Map.empty in - let aux (flam : Flambda.t) = - match flam with - | Let { var; - defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable, _), l, _); - } -> - map := Variable.Map.add var (List.length l) !map - | _ -> () - in - Flambda_iterators.iter aux (fun _ -> ()) flam; - !map - -let eliminate_ref_of_expr flam = - let variables_not_used_as_local_reference = - variables_not_used_as_local_reference flam - in - let convertible_variables = - Variable.Map.filter - (fun v _ -> - not (Variable.Set.mem v variables_not_used_as_local_reference)) - (variables_containing_ref flam) - in - if Variable.Map.cardinal convertible_variables = 0 then flam - else - let convertible_variables = - Variable.Map.mapi (fun v size -> - Array.init size (fun _ -> Mutable_variable.create_from_variable v)) - convertible_variables - in - let convertible_variable v = Variable.Map.mem v convertible_variables in - let get_variable v field = - let arr = try Variable.Map.find v convertible_variables - with Not_found -> assert false in - if Array.length arr <= field - then None (* This case could apply when inlining code containing GADTS *) - else Some (arr.(field), Array.length arr) - in - let aux (flam : Flambda.t) : Flambda.t = - match flam with - | Let { var; - defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable, shape), l,_); - body } - when convertible_variable var -> - let shape = match shape with - | None -> List.map (fun _ -> Lambda.Pgenval) l - | Some shape -> shape - in - let _, expr = - List.fold_left2 (fun (field,body) init kind -> - match get_variable var field with - | None -> assert false - | Some (field_var, _) -> - field+1, - (Let_mutable { var = field_var; - initial_value = init; - body; - contents_kind = kind } : Flambda.t)) - (0,body) l shape in - expr - | Let _ | Let_mutable _ - | Assign _ | Var _ | Apply _ - | Let_rec _ | Switch _ | String_switch _ - | Static_raise _ | Static_catch _ - | Try_with _ | If_then_else _ - | While _ | For _ | Send _ | Proved_unreachable -> - flam - and aux_named (named : Flambda.named) : Flambda.named = - match named with - | Prim(Pfield field, [v], _) - when convertible_variable v -> - (match get_variable v field with - | None -> Expr Proved_unreachable - | Some (var,_) -> Read_mutable var) - | Prim(Poffsetref delta, [v], dbg) - when convertible_variable v -> - (match get_variable v 0 with - | None -> Expr Proved_unreachable - | Some (var,size) -> - if size = 1 - then begin - let mut_name = Internal_variable_names.read_mutable in - let mut = Variable.create mut_name in - let new_value_name = Internal_variable_names.offsetted in - let new_value = Variable.create new_value_name in - let expr = - Flambda.create_let mut (Read_mutable var) - (Flambda.create_let new_value - (Prim(Poffsetint delta, [mut], dbg)) - (Assign { being_assigned = var; new_value })) - in - Expr expr - end - else - Expr Proved_unreachable) - | Prim(Psetfield (field, _, _), [v; new_value], _) - when convertible_variable v -> - (match get_variable v field with - | None -> Expr Proved_unreachable - | Some (being_assigned,_) -> - Expr (Assign { being_assigned; new_value })) - | Prim _ | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ | Set_of_closures _ | Project_closure _ - | Move_within_set_of_closures _ | Project_var _ | Expr _ -> - named - in - Flambda_iterators.map aux aux_named flam - -let eliminate_ref (program:Flambda.program) = - Flambda_iterators.map_exprs_at_toplevel_of_program program - ~f:eliminate_ref_of_expr diff --git a/middle_end/ref_to_variables.mli b/middle_end/ref_to_variables.mli deleted file mode 100644 index 38d36889..00000000 --- a/middle_end/ref_to_variables.mli +++ /dev/null @@ -1,23 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Transform [let]-bound references into variables. *) - -val eliminate_ref - : Flambda.program - -> Flambda.program diff --git a/middle_end/remove_free_vars_equal_to_args.ml b/middle_end/remove_free_vars_equal_to_args.ml deleted file mode 100755 index 6327d30c..00000000 --- a/middle_end/remove_free_vars_equal_to_args.ml +++ /dev/null @@ -1,99 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let pass_name = "remove-free-vars-equal-to-args" -let () = Pass_wrapper.register ~pass_name - -let rewrite_one_function_decl ~(function_decl : Flambda.function_declaration) - ~back_free_vars ~specialised_args = - let params_for_equal_free_vars = - List.fold_left (fun subst param -> - match Variable.Map.find param specialised_args with - | exception Not_found -> - (* param is not specialised *) - subst - | (spec_to : Flambda.specialised_to) -> - let outside_var = spec_to.var in - match Variable.Map.find outside_var back_free_vars with - | exception Not_found -> - (* No free variables equal to the param *) - subst - | set -> - (* Replace the free variables equal to a parameter *) - Variable.Set.fold (fun free_var subst -> - Variable.Map.add free_var param subst) - set subst) - Variable.Map.empty (Parameter.List.vars function_decl.params) - in - if Variable.Map.is_empty params_for_equal_free_vars then - function_decl - else - let body = - Flambda_utils.toplevel_substitution - params_for_equal_free_vars - function_decl.body - in - Flambda.update_function_declaration function_decl - ~params:function_decl.params ~body:body - -let rewrite_one_set_of_closures (set_of_closures : Flambda.set_of_closures) = - let back_free_vars = - Variable.Map.fold (fun var (outside_var : Flambda.specialised_to) map -> - let set = - match Variable.Map.find outside_var.var map with - | exception Not_found -> Variable.Set.singleton var - | set -> Variable.Set.add var set - in - Variable.Map.add outside_var.var set map) - set_of_closures.free_vars Variable.Map.empty - in - let done_something = ref false in - let funs = - Variable.Map.map (fun function_decl -> - let new_function_decl = - rewrite_one_function_decl ~function_decl ~back_free_vars - ~specialised_args:set_of_closures.specialised_args - in - if not (new_function_decl == function_decl) then begin - done_something := true - end; - new_function_decl) - set_of_closures.function_decls.funs - in - if not !done_something then - None - else - let function_decls = - Flambda.update_function_declarations - set_of_closures.function_decls ~funs - in - let set_of_closures = - Flambda.create_set_of_closures - ~function_decls - ~free_vars:set_of_closures.free_vars - ~specialised_args:set_of_closures.specialised_args - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - Some set_of_closures - -let run ~ppf_dump set_of_closures = - Pass_wrapper.with_dump ~ppf_dump ~pass_name ~input:set_of_closures - ~print_input:Flambda.print_set_of_closures - ~print_output:Flambda.print_set_of_closures - ~f:(fun () -> rewrite_one_set_of_closures set_of_closures) diff --git a/middle_end/remove_free_vars_equal_to_args.mli b/middle_end/remove_free_vars_equal_to_args.mli deleted file mode 100644 index 49f25ac1..00000000 --- a/middle_end/remove_free_vars_equal_to_args.mli +++ /dev/null @@ -1,23 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Replace free variables in closures known to be equal to specialised - arguments of such closures with those specialised arguments. *) - -val run - : ppf_dump:Format.formatter - -> Flambda.set_of_closures - -> Flambda.set_of_closures option diff --git a/middle_end/remove_unused_arguments.ml b/middle_end/remove_unused_arguments.ml deleted file mode 100644 index f70da729..00000000 --- a/middle_end/remove_unused_arguments.ml +++ /dev/null @@ -1,242 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let pass_name = "remove-unused-arguments" -let () = Clflags.all_passes := pass_name :: !Clflags.all_passes - -let rename_var var = - Variable.rename var - ~current_compilation_unit:(Compilation_unit.get_current_exn ()) - -let remove_params unused (fun_decl: Flambda.function_declaration) - ~new_fun_var = - let unused_params, used_params = - List.partition (fun v -> Variable.Set.mem (Parameter.var v) unused) - fun_decl.params - in - let unused_params = List.filter (fun v -> - Variable.Set.mem (Parameter.var v) fun_decl.free_variables) unused_params - in - let body = - List.fold_left (fun body param -> - Flambda.create_let (Parameter.var param) (Const (Const_pointer 0)) body) - fun_decl.body - unused_params - in - Flambda.create_function_declaration ~params:used_params ~body - ~stub:fun_decl.stub ~dbg:fun_decl.dbg ~inline:fun_decl.inline - ~specialise:fun_decl.specialise ~is_a_functor:fun_decl.is_a_functor - ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var)) - -let make_stub unused var (fun_decl : Flambda.function_declaration) - ~specialised_args ~additional_specialised_args = - let renamed = rename_var var in - let args' = - List.map (fun param -> param, Parameter.rename param) fun_decl.params - in - let used_args' = - List.filter (fun (param, _) -> - not (Variable.Set.mem (Parameter.var param) unused)) args' - in - let args'_var = - List.map (fun (p1, p2) -> Parameter.var p1, Parameter.var p2) args' - in - let args_renaming = Variable.Map.of_list args'_var in - let additional_specialised_args = - List.fold_left (fun additional_specialised_args (original_arg,arg) -> - match Variable.Map.find original_arg specialised_args with - | exception Not_found -> additional_specialised_args - | (outer_var : Flambda.specialised_to) -> - (* CR-soon mshinwell: share with Augment_specialised_args *) - let outer_var : Flambda.specialised_to = - match outer_var.projection with - | None -> outer_var - | Some projection -> - let projection = - Projection.map_projecting_from projection ~f:(fun var -> - match Variable.Map.find var args_renaming with - | exception Not_found -> - (* Must always be a parameter of this - [function_decl]. *) - assert false - | wrapper_arg -> wrapper_arg) - in - { outer_var with - projection = Some projection; - } - in - Variable.Map.add arg outer_var additional_specialised_args) - additional_specialised_args args'_var - in - let args = List.map (fun (_, var) -> var) used_args' in - let kind = Flambda.Direct (Closure_id.wrap renamed) in - let body : Flambda.t = - Apply { - func = renamed; - args = Parameter.List.vars args; - kind; - dbg = fun_decl.dbg; - inline = Default_inline; - specialise = Default_specialise; - } - in - let function_decl = - Flambda.create_function_declaration ~params:(List.map snd args') ~body - ~stub:true ~dbg:fun_decl.dbg ~inline:Default_inline - ~specialise:Default_specialise ~is_a_functor:fun_decl.is_a_functor - ~closure_origin:fun_decl.closure_origin - in - function_decl, renamed, additional_specialised_args - -let separate_unused_arguments ~only_specialised - ~backend ~(set_of_closures : Flambda.set_of_closures) = - let function_decls = set_of_closures.function_decls in - let unused = Invariant_params.unused_arguments ~backend function_decls in - let non_stub_arguments = - Variable.Map.fold (fun _ (decl : Flambda.function_declaration) acc -> - if decl.stub then - acc - else - Variable.Set.union acc (Parameter.Set.vars decl.Flambda.params)) - function_decls.funs Variable.Set.empty - in - let unused = Variable.Set.inter non_stub_arguments unused in - let specialised_args = Variable.Map.keys set_of_closures.specialised_args in - let unused = - if only_specialised then Variable.Set.inter specialised_args unused - else unused - in - if Variable.Set.is_empty unused - then None - else begin - let funs, additional_specialised_args = - Variable.Map.fold (fun fun_id (fun_decl : Flambda.function_declaration) - (funs, additional_specialised_args) -> - if List.exists (fun v -> Variable.Set.mem (Parameter.var v) unused) - fun_decl.params - then begin - let stub, renamed_fun_id, additional_specialised_args = - make_stub unused fun_id fun_decl - ~specialised_args:set_of_closures.specialised_args - ~additional_specialised_args - in - let cleaned = - remove_params unused fun_decl ~new_fun_var:renamed_fun_id - in - Variable.Map.add fun_id stub - (Variable.Map.add renamed_fun_id cleaned funs), - additional_specialised_args - end - else - Variable.Map.add fun_id fun_decl funs, - additional_specialised_args - ) - function_decls.funs (Variable.Map.empty, Variable.Map.empty) - in - let specialised_args = - Variable.Map.disjoint_union additional_specialised_args - (Variable.Map.filter (fun param _ -> - not (Variable.Set.mem param unused)) - set_of_closures.specialised_args) - in - let specialised_args = - Flambda_utils.clean_projections ~which_variables:specialised_args - in - let function_decls = - Flambda.update_function_declarations function_decls ~funs - in - let set_of_closures = - Flambda.create_set_of_closures ~function_decls - ~free_vars:set_of_closures.free_vars ~specialised_args - (* CR-soon mshinwell: Use direct_call_surrogates for this - transformation. *) - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - Some set_of_closures - end - -(* Splitting is not always beneficial. For instance when a function - is only indirectly called, suppressing unused arguments does not - benefit, and introduce an useless intermediate call. Specialised - args should always be beneficial since they should not be used in - indirect calls. *) -let should_split_only_specialised_args - (fun_decls : Flambda.function_declarations) - ~backend = - if not !Clflags.remove_unused_arguments then begin - true - end else begin - let no_recursive_functions = - Variable.Set.is_empty - (Find_recursive_functions.in_function_declarations fun_decls ~backend) - in - let number_of_non_stub_functions = - Variable.Map.cardinal - (Variable.Map.filter (fun _ { Flambda.stub } -> not stub) - fun_decls.funs) - in - (* CR-soon lwhite: this criteria could use some justification. - mshinwell: pchambart cannot remember how these criteria arose, - but we're going to leave this as-is for 4.03. *) - no_recursive_functions && (number_of_non_stub_functions <= 1) - end - -let separate_unused_arguments_in_set_of_closures set_of_closures ~backend = - let dump = Clflags.dumped_pass pass_name in - let only_specialised = - should_split_only_specialised_args - set_of_closures.Flambda.function_decls - ~backend - in - match separate_unused_arguments - ~only_specialised ~backend ~set_of_closures with - | None -> - if dump then - Format.eprintf "No change for Remove_unused_arguments:@ %a@.@." - Flambda.print_set_of_closures set_of_closures; - None - | Some result -> - if dump then - Format.eprintf "Before Remove_unused_arguments:@ %a@.@.\ - After Remove_unused_arguments:@ %a@.@." - Flambda.print_set_of_closures set_of_closures - Flambda.print_set_of_closures result; - Some result - -let separate_unused_arguments_in_closures_expr tree ~backend = - let aux_named (named : Flambda.named) : Flambda.named = - match named with - | Set_of_closures set_of_closures -> begin - let only_specialised = - should_split_only_specialised_args - set_of_closures.function_decls - ~backend - in - match separate_unused_arguments - ~only_specialised ~backend ~set_of_closures with - | None -> named - | Some set_of_closures -> Set_of_closures set_of_closures - end - | e -> e - in - Flambda_iterators.map_named aux_named tree - -let separate_unused_arguments_in_closures program ~backend = - Flambda_iterators.map_exprs_at_toplevel_of_program program ~f:(fun expr -> - separate_unused_arguments_in_closures_expr expr ~backend) diff --git a/middle_end/remove_unused_arguments.mli b/middle_end/remove_unused_arguments.mli deleted file mode 100644 index 759b32f2..00000000 --- a/middle_end/remove_unused_arguments.mli +++ /dev/null @@ -1,39 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Introduce a stub function to avoid depending on unused arguments. - - For instance, it turns - [let rec fact n unused = - if n = 0 then 1 - else n * fact (n-1) unused] - into - [let rec fact' n = - if n = 0 then 1 - else n * fact' (n-1) - and fact n unused = fact' n] -*) -val separate_unused_arguments_in_closures - : Flambda.program - -> backend:(module Backend_intf.S) - -> Flambda.program - -val separate_unused_arguments_in_set_of_closures - : Flambda.set_of_closures - -> backend:(module Backend_intf.S) - -> Flambda.set_of_closures option diff --git a/middle_end/remove_unused_closure_vars.ml b/middle_end/remove_unused_closure_vars.ml deleted file mode 100644 index 0d4ad621..00000000 --- a/middle_end/remove_unused_closure_vars.ml +++ /dev/null @@ -1,125 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -(** A variable in a closure can either be used by the closure itself - or by an inlined version of the function. *) -let remove_unused_closure_variables ~remove_direct_call_surrogates program = - let used_vars_within_closure, used_closure_ids = - let used = Var_within_closure.Tbl.create 13 in - let used_fun = Closure_id.Tbl.create 13 in - let aux_named (named : Flambda.named) = - match named with - | Project_closure { set_of_closures = _; closure_id } -> - Closure_id.Tbl.add used_fun closure_id () - | Project_var { closure_id; var } -> - Var_within_closure.Tbl.add used var (); - Closure_id.Tbl.add used_fun closure_id () - | Move_within_set_of_closures { closure = _; start_from; move_to } -> - Closure_id.Tbl.add used_fun start_from (); - Closure_id.Tbl.add used_fun move_to () - | Symbol _ | Const _ | Set_of_closures _ | Prim _ | Expr _ - | Allocated_const _ | Read_mutable _ | Read_symbol_field _ -> () - in - Flambda_iterators.iter_named_of_program ~f:aux_named program; - used, used_fun - in - let aux_named _ (named : Flambda.named) : Flambda.named = - match named with - | Set_of_closures ({ function_decls; free_vars; _ } as set_of_closures) -> - let direct_call_surrogates = - if remove_direct_call_surrogates then Variable.Set.empty - else - Variable.Set.of_list - (Variable.Map.data set_of_closures.direct_call_surrogates) - in - let rec add_needed needed_funs remaining_funs free_vars_of_kept_funs = - let new_needed_funs, remaining_funs = - (* Keep a function if it is used either by the rest of the code, - (in used_closure_ids), or by any other kept function - (in free_vars_of_kept_funs) *) - Variable.Map.partition (fun fun_id _ -> - Variable.Set.mem fun_id free_vars_of_kept_funs - || Closure_id.Tbl.mem used_closure_ids - (Closure_id.wrap fun_id) - || Variable.Set.mem fun_id direct_call_surrogates) - remaining_funs - in - if Variable.Map.is_empty new_needed_funs then - (* If no new function is needed, we reached fixpoint *) - needed_funs, free_vars_of_kept_funs - else begin - let needed_funs = - Variable.Map.disjoint_union needed_funs new_needed_funs - in - let free_vars_of_kept_funs = - Variable.Map.fold (fun _ { Flambda. free_variables } acc -> - Variable.Set.union free_variables acc) - new_needed_funs - free_vars_of_kept_funs - in - add_needed needed_funs remaining_funs free_vars_of_kept_funs - end - in - let funs, free_vars_of_kept_funs = - add_needed Variable.Map.empty function_decls.funs Variable.Set.empty - in - let free_vars = - Variable.Map.filter (fun id _var -> - Variable.Set.mem id free_vars_of_kept_funs - || Var_within_closure.Tbl.mem - used_vars_within_closure - (Var_within_closure.wrap id)) - free_vars - in - let function_decls = - Flambda.update_function_declarations function_decls ~funs - in - let specialised_args = - (* Remove specialised args that are used by removed functions *) - let all_remaining_arguments = - Variable.Map.fold (fun _ { Flambda.params } set -> - Variable.Set.union set (Parameter.Set.vars params)) - funs Variable.Set.empty - in - Variable.Map.filter (fun arg _ -> - Variable.Set.mem arg all_remaining_arguments) - set_of_closures.specialised_args - in - let free_vars = - Flambda_utils.clean_projections ~which_variables:free_vars - in - let direct_call_surrogates = - (* Remove direct call surrogates where either the existing function - or the surrogate has been eliminated. *) - Variable.Map.fold (fun existing surrogate surrogates -> - if not (Variable.Map.mem existing funs) - || not (Variable.Map.mem surrogate funs) - then surrogates - else Variable.Map.add existing surrogate surrogates) - set_of_closures.direct_call_surrogates - Variable.Map.empty - in - let set_of_closures = - Flambda.create_set_of_closures ~function_decls - ~free_vars ~specialised_args ~direct_call_surrogates - in - Set_of_closures set_of_closures - | e -> e - in - Flambda_iterators.map_named_of_program ~f:aux_named program diff --git a/middle_end/remove_unused_closure_vars.mli b/middle_end/remove_unused_closure_vars.mli deleted file mode 100644 index 225697a8..00000000 --- a/middle_end/remove_unused_closure_vars.mli +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(* CR-soon mshinwell: Rename this module. *) - -(** Eliminate variables bound by sets of closures that are not required. - Also eliminate functions within sets of closures that are not required. *) -val remove_unused_closure_variables - : remove_direct_call_surrogates:bool - -> Flambda.program - -> Flambda.program diff --git a/middle_end/remove_unused_program_constructs.ml b/middle_end/remove_unused_program_constructs.ml deleted file mode 100644 index 059d68bc..00000000 --- a/middle_end/remove_unused_program_constructs.ml +++ /dev/null @@ -1,111 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let dependency (expr:Flambda.t) = Flambda.free_symbols expr - -(* CR-soon pchambart: copied from lift_constant. Needs remerging *) -let constant_dependencies (const:Flambda.constant_defining_value) = - let closure_dependencies (set_of_closures:Flambda.set_of_closures) = - Flambda.free_symbols_named (Set_of_closures set_of_closures) - in - match const with - | Allocated_const _ -> Symbol.Set.empty - | Block (_, fields) -> - let symbol_fields = - List.filter_map (function - | (Symbol s : Flambda.constant_defining_value_block_field) -> - Some s - | Flambda.Const _ -> None) - fields - in - Symbol.Set.of_list symbol_fields - | Set_of_closures set_of_closures -> closure_dependencies set_of_closures - | Project_closure (s, _) -> Symbol.Set.singleton s - -let let_rec_dep defs dep = - let add_deps l dep = - List.fold_left (fun dep (sym, sym_dep) -> - if Symbol.Set.mem sym dep then Symbol.Set.union dep sym_dep - else dep) - dep l - in - let defs_deps = - List.map (fun (sym, def) -> sym, constant_dependencies def) defs - in - let rec fixpoint dep = - let new_dep = add_deps defs_deps dep in - if Symbol.Set.equal dep new_dep then dep - else fixpoint new_dep - in - fixpoint dep - -let rec loop (program : Flambda.program_body) - : Flambda.program_body * Symbol.Set.t = - match program with - | Let_symbol (sym, def, program) -> - let program, dep = loop program in - if Symbol.Set.mem sym dep then - Let_symbol (sym, def, program), - Symbol.Set.union dep (constant_dependencies def) - else - program, dep - | Let_rec_symbol (defs, program) -> - let program, dep = loop program in - let dep = let_rec_dep defs dep in - let defs = - List.filter (fun (sym, _) -> Symbol.Set.mem sym dep) defs - in begin match defs with - | [] -> program, dep - | _ -> Let_rec_symbol (defs, program), dep - end - | Initialize_symbol (sym, tag, fields, program) -> - let program, dep = loop program in - if Symbol.Set.mem sym dep then - let dep = - List.fold_left (fun dep field -> - Symbol.Set.union dep (dependency field)) - dep fields - in - Initialize_symbol (sym, tag, fields, program), dep - else begin - List.fold_left - (fun (program, dep) field -> - if Effect_analysis.no_effects field then - program, dep - else - let new_dep = dependency field in - let dep = Symbol.Set.union new_dep dep in - Flambda.Effect (field, program), dep) - (program, dep) fields - end - | Effect (effect, program) -> - let program, dep = loop program in - if Effect_analysis.no_effects effect then begin - program, dep - end else begin - let new_dep = dependency effect in - let dep = Symbol.Set.union new_dep dep in - Effect (effect, program), dep - end - | End symbol -> program, Symbol.Set.singleton symbol - -let remove_unused_program_constructs (program : Flambda.program) = - { program with - program_body = fst (loop program.program_body); - } diff --git a/middle_end/remove_unused_program_constructs.mli b/middle_end/remove_unused_program_constructs.mli deleted file mode 100644 index 3a722011..00000000 --- a/middle_end/remove_unused_program_constructs.mli +++ /dev/null @@ -1,24 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(* Remove unused [Flambda.program] constructs from the given program. - - Symbols (whose defining expressions have no effects) are eliminated - if unused. - - [Effect] constructs that turn out to have no effects are eliminated. -*) -val remove_unused_program_constructs : Flambda.program -> Flambda.program diff --git a/middle_end/semantics_of_primitives.ml b/middle_end/semantics_of_primitives.ml new file mode 100644 index 00000000..2daf167e --- /dev/null +++ b/middle_end/semantics_of_primitives.ml @@ -0,0 +1,153 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +type effects = No_effects | Only_generative_effects | Arbitrary_effects +type coeffects = No_coeffects | Has_coeffects + +let for_primitive (prim : Clambda_primitives.primitive) = + match prim with + | Pmakeblock _ + | Pmakearray (_, Mutable) -> Only_generative_effects, No_coeffects + | Pmakearray (_, Immutable) -> No_effects, No_coeffects + | Pduparray (_, Immutable) -> + No_effects, No_coeffects (* Pduparray (_, Immutable) is allowed only on + immutable arrays. *) + | Pduparray (_, Mutable) | Pduprecord _ -> + Only_generative_effects, Has_coeffects + | Pccall { prim_name = + ( "caml_format_float" | "caml_format_int" | "caml_int32_format" + | "caml_nativeint_format" | "caml_int64_format" ) } -> + No_effects, No_coeffects + | Pccall _ -> Arbitrary_effects, Has_coeffects + | Praise _ -> Arbitrary_effects, No_coeffects + | Pnot + | Pnegint + | Paddint + | Psubint + | Pmulint + | Pandint + | Porint + | Pxorint + | Plslint + | Plsrint + | Pasrint + | Pintcomp _ -> No_effects, No_coeffects + | Pdivbint { is_safe = Unsafe } + | Pmodbint { is_safe = Unsafe } + | Pdivint Unsafe + | Pmodint Unsafe -> + No_effects, No_coeffects (* Will not raise [Division_by_zero]. *) + | Pdivbint { is_safe = Safe } + | Pmodbint { is_safe = Safe } + | Pdivint Safe + | Pmodint Safe -> + Arbitrary_effects, No_coeffects + | Poffsetint _ -> No_effects, No_coeffects + | Poffsetref _ -> Arbitrary_effects, Has_coeffects + | Pintoffloat + | Pfloatofint + | Pnegfloat + | Pabsfloat + | Paddfloat + | Psubfloat + | Pmulfloat + | Pdivfloat + | Pfloatcomp _ -> No_effects, No_coeffects + | Pstringlength | Pbyteslength + | Parraylength _ -> + No_effects, Has_coeffects (* That old chestnut: [Obj.truncate]. *) + | Pisint + | Pisout + | Pbintofint _ + | Pintofbint _ + | Pcvtbint _ + | Pnegbint _ + | Paddbint _ + | Psubbint _ + | Pmulbint _ + | Pandbint _ + | Porbint _ + | Pxorbint _ + | Plslbint _ + | Plsrbint _ + | Pasrbint _ + | Pbintcomp _ -> No_effects, No_coeffects + | Pbigarraydim _ -> + No_effects, Has_coeffects (* Some people resize bigarrays in place. *) + | Pread_symbol _ + | Pfield _ + | Pfield_computed + | Pfloatfield _ + | Parrayrefu _ + | Pstringrefu + | Pbytesrefu + | Pstring_load (_, Unsafe) + | Pbytes_load (_, Unsafe) + | Pbigarrayref (true, _, _, _) + | Pbigstring_load (_, Unsafe) -> + No_effects, Has_coeffects + | Parrayrefs _ + | Pstringrefs + | Pbytesrefs + | Pstring_load (_, Safe) + | Pbytes_load (_, Safe) + | Pbigarrayref (false, _, _, _) + | Pbigstring_load (_, Safe) -> + (* May trigger a bounds check exception. *) + Arbitrary_effects, Has_coeffects + | Psetfield _ + | Psetfield_computed _ + | Psetfloatfield _ + | Parraysetu _ + | Parraysets _ + | Pbytessetu + | Pbytessets + | Pbytes_set _ + | Pbigarrayset _ + | Pbigstring_set _ -> + (* Whether or not some of these are "unsafe" is irrelevant; they always + have an effect. *) + Arbitrary_effects, No_coeffects + | Pbswap16 + | Pbbswap _ -> No_effects, No_coeffects + | Pint_as_pointer -> No_effects, No_coeffects + | Popaque -> Arbitrary_effects, Has_coeffects + | Psequand + | Psequor -> + (* Removed by [Closure_conversion] in the flambda pipeline. *) + No_effects, No_coeffects + +type return_type = + | Float + | Other + +let return_type_of_primitive (prim:Clambda_primitives.primitive) = + match prim with + | Pfloatofint + | Pnegfloat + | Pabsfloat + | Paddfloat + | Psubfloat + | Pmulfloat + | Pdivfloat + | Pfloatfield _ + | Parrayrefu Pfloatarray + | Parrayrefs Pfloatarray -> + Float + | _ -> + Other diff --git a/middle_end/semantics_of_primitives.mli b/middle_end/semantics_of_primitives.mli new file mode 100644 index 00000000..78407df7 --- /dev/null +++ b/middle_end/semantics_of_primitives.mli @@ -0,0 +1,69 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Description of the semantics of primitives, to be used for optimization + purposes. + + "No effects" means that the primitive does not change the observable state + of the world. For example, it must not write to any mutable storage, + call arbitrary external functions or change control flow (e.g. by raising + an exception). Note that allocation is not "No effects" (see below). + + It is assumed in the compiler that applications of primitives with no + effects, whose results are not used, may be eliminated. It is further + assumed that applications of primitives with no effects may be + duplicated (and thus possibly executed more than once). + + (Exceptions arising from allocation points, for example "out of memory" or + exceptions propagated from finalizers or signal handlers, are treated as + "effects out of the ether" and thus ignored for our determination here + of effectfulness. The same goes for floating point operations that may + cause hardware traps on some platforms.) + + "Only generative effects" means that a primitive does not change the + observable state of the world save for possibly affecting the state of + the garbage collector by performing an allocation. Applications of + primitives that only have generative effects and whose results are unused + may be eliminated by the compiler. However, unlike "No effects" + primitives, such applications will never be eligible for duplication. + + "Arbitrary effects" covers all other primitives. + + "No coeffects" means that the primitive does not observe the effects (in + the sense described above) of other expressions. For example, it must not + read from any mutable storage or call arbitrary external functions. + + It is assumed in the compiler that, subject to data dependencies, + expressions with neither effects nor coeffects may be reordered with + respect to other expressions. +*) + +type effects = No_effects | Only_generative_effects | Arbitrary_effects +type coeffects = No_coeffects | Has_coeffects + +(** Describe the semantics of a primitive. This does not take into account of + the (non-)(co)effectfulness of the arguments in a primitive application. + To determine whether such an application is (co)effectful, the arguments + must also be analysed. *) +val for_primitive: Clambda_primitives.primitive -> effects * coeffects + +type return_type = + | Float + | Other + +val return_type_of_primitive: Clambda_primitives.primitive -> return_type diff --git a/middle_end/share_constants.ml b/middle_end/share_constants.ml deleted file mode 100644 index 2bbd7134..00000000 --- a/middle_end/share_constants.ml +++ /dev/null @@ -1,130 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module Constant_defining_value = Flambda.Constant_defining_value - -let update_constant_for_sharing sharing_symbol_tbl const - : Flambda.constant_defining_value = - let substitute_symbol sym = - match Symbol.Tbl.find sharing_symbol_tbl sym with - | exception Not_found -> sym - | symbol -> symbol - in - match (const:Flambda.constant_defining_value) with - | Allocated_const _ -> const - | Block (tag, fields) -> - let subst_field (field:Flambda.constant_defining_value_block_field) : - Flambda.constant_defining_value_block_field = - match field with - | Const _ -> field - | Symbol sym -> - Symbol (substitute_symbol sym) - in - let fields = List.map subst_field fields in - Block (tag, fields) - | Set_of_closures set_of_closures -> - Set_of_closures ( - Flambda_iterators.map_symbols_on_set_of_closures - ~f:substitute_symbol set_of_closures - ) - | Project_closure (sym, closure_id) -> - Project_closure (substitute_symbol sym, closure_id) - -let cannot_share (const : Flambda.constant_defining_value) = - match const with - (* Strings and float arrays are mutable; we never share them. *) - | Allocated_const ((String _) | (Float_array _)) -> true - | Allocated_const _ | Set_of_closures _ | Project_closure _ | Block _ -> - false - -let share_definition constant_to_symbol_tbl sharing_symbol_tbl - symbol def end_symbol = - let def = update_constant_for_sharing sharing_symbol_tbl def in - if cannot_share def || Symbol.equal symbol end_symbol then - (* The symbol exported by the unit (end_symbol), cannot be removed - from the module. We prevent it from being shared to avoid that. *) - Some def - else - begin match Constant_defining_value.Tbl.find constant_to_symbol_tbl def with - | exception Not_found -> - Constant_defining_value.Tbl.add constant_to_symbol_tbl def symbol; - Some def - | equal_symbol -> - Symbol.Tbl.add sharing_symbol_tbl symbol equal_symbol; - None - end - -let rec end_symbol (program : Flambda.program_body) = - match program with - | End symbol -> symbol - | Let_symbol (_, _, program) - | Let_rec_symbol (_, program) - | Initialize_symbol (_, _, _, program) - | Effect (_, program) -> - end_symbol program - -let share_constants (program : Flambda.program) = - let end_symbol = end_symbol program.program_body in - let sharing_symbol_tbl = Symbol.Tbl.create 42 in - let constant_to_symbol_tbl = Constant_defining_value.Tbl.create 42 in - let rec loop (program : Flambda.program_body) : Flambda.program_body = - match program with - | Let_symbol (symbol,def,program) -> - begin match - share_definition constant_to_symbol_tbl sharing_symbol_tbl symbol - def end_symbol - with - | None -> - loop program - | Some def' -> - Let_symbol (symbol,def',loop program) - end - | Let_rec_symbol (defs,program) -> - let defs = - List.map (fun (symbol, def) -> - let def = update_constant_for_sharing sharing_symbol_tbl def in - symbol, def) - defs - in - Let_rec_symbol (defs, loop program) - | Initialize_symbol (symbol,tag,fields,program) -> - let fields = - List.map (fun field -> - Flambda_iterators.map_symbols - ~f:(fun symbol -> - try Symbol.Tbl.find sharing_symbol_tbl symbol with - | Not_found -> symbol) - field) - fields - in - Initialize_symbol (symbol,tag,fields,loop program) - | Effect (expr,program) -> - let expr = - Flambda_iterators.map_symbols - ~f:(fun symbol -> - try Symbol.Tbl.find sharing_symbol_tbl symbol with - | Not_found -> symbol) - expr - in - Effect (expr, loop program) - | End root -> End root - in - { program with - program_body = loop program.program_body; - } diff --git a/middle_end/share_constants.mli b/middle_end/share_constants.mli deleted file mode 100644 index 7fec22bc..00000000 --- a/middle_end/share_constants.mli +++ /dev/null @@ -1,22 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Share lifted constants that are eligible for sharing (e.g. not strings) - and have equal definitions. *) - -val share_constants : Flambda.program -> Flambda.program diff --git a/middle_end/simple_value_approx.ml b/middle_end/simple_value_approx.ml deleted file mode 100644 index 34fc5ce0..00000000 --- a/middle_end/simple_value_approx.ml +++ /dev/null @@ -1,1043 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module U = Flambda_utils - -type 'a boxed_int = - | Int32 : int32 boxed_int - | Int64 : int64 boxed_int - | Nativeint : nativeint boxed_int - -type value_string = { - (* CR-soon mshinwell: use variant *) - contents : string option; (* None if unknown or mutable *) - size : int; -} - -type unresolved_value = - | Set_of_closures_id of Set_of_closures_id.t - | Symbol of Symbol.t - -type unknown_because_of = - | Unresolved_value of unresolved_value - | Other - -type t = { - descr : descr; - var : Variable.t option; - symbol : (Symbol.t * int option) option; -} - -and descr = - | Value_block of Tag.t * t array - | Value_int of int - | Value_char of char - | Value_constptr of int - | Value_float of float option - | Value_boxed_int : 'a boxed_int * 'a -> descr - | Value_set_of_closures of value_set_of_closures - | Value_closure of value_closure - | Value_string of value_string - | Value_float_array of value_float_array - | Value_unknown of unknown_because_of - | Value_bottom - | Value_extern of Export_id.t - | Value_symbol of Symbol.t - | Value_unresolved of unresolved_value - (* No description was found for this value *) - -and value_closure = { - set_of_closures : t; - closure_id : Closure_id.t; -} - -and function_declarations = { - is_classic_mode : bool; - set_of_closures_id : Set_of_closures_id.t; - set_of_closures_origin : Set_of_closures_origin.t; - funs : function_declaration Variable.Map.t; -} - -and function_body = { - free_variables : Variable.Set.t; - free_symbols : Symbol.Set.t; - stub : bool; - dbg : Debuginfo.t; - inline : Lambda.inline_attribute; - specialise : Lambda.specialise_attribute; - is_a_functor : bool; - body : Flambda.t; -} - -and function_declaration = { - closure_origin : Closure_origin.t; - params : Parameter.t list; - function_body : function_body option; -} - -and value_set_of_closures = { - function_decls : function_declarations; - bound_vars : t Var_within_closure.Map.t; - free_vars : Flambda.specialised_to Variable.Map.t; - invariant_params : Variable.Set.t Variable.Map.t Lazy.t; - recursive : Variable.Set.t Lazy.t; - size : int option Variable.Map.t Lazy.t; - specialised_args : Flambda.specialised_to Variable.Map.t; - freshening : Freshening.Project_var.t; - direct_call_surrogates : Closure_id.t Closure_id.Map.t; -} - -and value_float_array_contents = - | Contents of t array - | Unknown_or_mutable - -and value_float_array = { - contents : value_float_array_contents; - size : int; -} - -let descr t = t.descr - -let print_value_set_of_closures ppf - { function_decls = { funs }; invariant_params; freshening; size; _ } = - Format.fprintf ppf - "(set_of_closures:@ %a invariant_params=%a freshening=%a size=%a)" - (fun ppf -> Variable.Map.iter (fun id _ -> Variable.print ppf id)) funs - (Variable.Map.print Variable.Set.print) (Lazy.force invariant_params) - Freshening.Project_var.print freshening - (Variable.Map.print (fun ppf some_size -> - match some_size with - | None -> Format.fprintf ppf "None" - | Some size -> Format.fprintf ppf "Some %d" size)) - (Lazy.force size) - -let print_unresolved_value ppf = function - | Set_of_closures_id set -> - Format.fprintf ppf "Set_of_closures_id %a" Set_of_closures_id.print set - | Symbol symbol -> - Format.fprintf ppf "Symbol %a" Symbol.print symbol - -let print_function_declaration ppf var (f : function_declaration) = - let param ppf p = Variable.print ppf (Parameter.var p) in - let params ppf = List.iter (Format.fprintf ppf "@ %a" param) in - match f.function_body with - | None -> - Format.fprintf ppf "@[<2>(%a@ =@ fun@[<2>%a@])@]@ " - Variable.print var params f.params - | Some (b : function_body) -> - let stub = if b.stub then " *stub*" else "" in - let is_a_functor = if b.is_a_functor then " *functor*" else "" in - let inline = - match b.inline with - | Always_inline -> " *inline*" - | Never_inline -> " *never_inline*" - | Unroll _ -> " *unroll*" - | Default_inline -> "" - in - let specialise = - match b.specialise with - | Always_specialise -> " *specialise*" - | Never_specialise -> " *never_specialise*" - | Default_specialise -> "" - in - let print_body ppf _ = - Format.fprintf ppf "" - in - Format.fprintf ppf "@[<2>(%a%s%s%s%s@ =@ fun@[<2>%a@] ->@ @[<2><%a>@])@]@ " - Variable.print var stub is_a_functor inline specialise - params f.params - print_body b - -let print_function_declarations ppf (fd : function_declarations) = - let funs ppf = Variable.Map.iter (print_function_declaration ppf) in - Format.fprintf ppf "@[<2>(%a)@]" funs fd.funs - -let rec print_descr ppf = function - | Value_int i -> Format.pp_print_int ppf i - | Value_char c -> Format.fprintf ppf "%c" c - | Value_constptr i -> Format.fprintf ppf "%ia" i - | Value_block (tag,fields) -> - let p ppf fields = - Array.iter (fun v -> Format.fprintf ppf "%a@ " print v) fields in - Format.fprintf ppf "[%i:@ @[<1>%a@]]" (Tag.to_int tag) p fields - | Value_unknown reason -> - begin match reason with - | Unresolved_value value -> - Format.fprintf ppf "?(due to unresolved %a)" print_unresolved_value value - | Other -> Format.fprintf ppf "?" - end; - | Value_bottom -> Format.fprintf ppf "bottom" - | Value_extern id -> Format.fprintf ppf "_%a_" Export_id.print id - | Value_symbol sym -> Format.fprintf ppf "%a" Symbol.print sym - | Value_closure { set_of_closures; closure_id; } -> - Format.fprintf ppf "(closure:@ %a from@ %a)" Closure_id.print closure_id - print set_of_closures - | Value_set_of_closures set_of_closures -> - print_value_set_of_closures ppf set_of_closures - | Value_unresolved value -> - Format.fprintf ppf "(unresolved %a)" print_unresolved_value value - | Value_float (Some f) -> Format.pp_print_float ppf f - | Value_float None -> Format.pp_print_string ppf "float" - | Value_string { contents; size } -> begin - match contents with - | None -> - Format.fprintf ppf "string %i" size - | Some s -> - let s = - if size > 10 - then String.sub s 0 8 ^ "..." - else s - in - Format.fprintf ppf "string %i %S" size s - end - | Value_float_array float_array -> - begin match float_array.contents with - | Unknown_or_mutable -> - Format.fprintf ppf "float_array %i" float_array.size - | Contents _ -> - Format.fprintf ppf "float_array_imm %i" float_array.size - end - | Value_boxed_int (t, i) -> - match t with - | Int32 -> Format.fprintf ppf "%li" i - | Int64 -> Format.fprintf ppf "%Li" i - | Nativeint -> Format.fprintf ppf "%ni" i - -and print ppf { descr; var; symbol; } = - let print ppf = function - | None -> Symbol.print_opt ppf None - | Some (sym, None) -> Symbol.print ppf sym - | Some (sym, Some field) -> - Format.fprintf ppf "%a.(%i)" Symbol.print sym field - in - Format.fprintf ppf "{ descr=%a var=%a symbol=%a }" - print_descr descr - Variable.print_opt var - print symbol - -let approx descr = { descr; var = None; symbol = None } - -let augment_with_variable t var = { t with var = Some var } -let augment_with_symbol t symbol = { t with symbol = Some (symbol, None) } -let augment_with_symbol_field t symbol field = - match t.symbol with - | None -> { t with symbol = Some (symbol, Some field) } - | Some _ -> t -let replace_description t descr = { t with descr } - -let augment_with_kind t (kind:Lambda.value_kind) = - match kind with - | Pgenval -> t - | Pfloatval -> - begin match t.descr with - | Value_float _ -> - t - | Value_unknown _ | Value_unresolved _ -> - { t with descr = Value_float None } - | Value_block _ - | Value_int _ - | Value_char _ - | Value_constptr _ - | Value_boxed_int _ - | Value_set_of_closures _ - | Value_closure _ - | Value_string _ - | Value_float_array _ - | Value_bottom -> - (* Unreachable *) - { t with descr = Value_bottom } - | Value_extern _ | Value_symbol _ -> - (* We don't know yet *) - t - end - | _ -> t - -let augment_kind_with_approx t (kind:Lambda.value_kind) : Lambda.value_kind = - match t.descr with - | Value_float _ -> Pfloatval - | Value_int _ -> Pintval - | Value_boxed_int (Int32, _) -> Pboxedintval Pint32 - | Value_boxed_int (Int64, _) -> Pboxedintval Pint64 - | Value_boxed_int (Nativeint, _) -> Pboxedintval Pnativeint - | _ -> kind - -let value_unknown reason = approx (Value_unknown reason) -let value_int i = approx (Value_int i) -let value_char i = approx (Value_char i) -let value_constptr i = approx (Value_constptr i) -let value_float f = approx (Value_float (Some f)) -let value_any_float = approx (Value_float None) -let value_boxed_int bi i = approx (Value_boxed_int (bi,i)) - -let value_closure ?closure_var ?set_of_closures_var ?set_of_closures_symbol - value_set_of_closures closure_id = - let approx_set_of_closures = - { descr = Value_set_of_closures value_set_of_closures; - var = set_of_closures_var; - symbol = Misc.may_map (fun s -> s, None) set_of_closures_symbol; - } - in - let value_closure = - { set_of_closures = approx_set_of_closures; - closure_id; - } - in - { descr = Value_closure value_closure; - var = closure_var; - symbol = None; - } - -let create_value_set_of_closures - ~(function_decls : function_declarations) ~bound_vars ~free_vars - ~invariant_params ~recursive ~specialised_args ~freshening - ~direct_call_surrogates = - let size = - lazy ( - let functions = Variable.Map.keys function_decls.funs in - Variable.Map.fold - (fun fun_var function_decl sizes -> - match function_decl.function_body with - | None -> sizes - | Some function_body -> - let params = Parameter.Set.vars function_decl.params in - let free_vars = - Variable.Set.diff - (Variable.Set.diff function_body.free_variables params) - functions - in - let num_free_vars = Variable.Set.cardinal free_vars in - let max_size = - Inlining_cost.maximum_interesting_size_of_function_body - num_free_vars - in - let size = - Inlining_cost.lambda_smaller' function_body.body ~than:max_size - in - Variable.Map.add fun_var size sizes) - function_decls.funs Variable.Map.empty) - in - { function_decls; - bound_vars; - free_vars; - invariant_params; - recursive; - size; - specialised_args; - freshening; - direct_call_surrogates; - } - -let update_freshening_of_value_set_of_closures value_set_of_closures - ~freshening = - (* CR-someday mshinwell: We could maybe check that [freshening] is - reasonable. *) - { value_set_of_closures with freshening; } - -let value_set_of_closures ?set_of_closures_var value_set_of_closures = - { descr = Value_set_of_closures value_set_of_closures; - var = set_of_closures_var; - symbol = None; - } - -let value_block t b = approx (Value_block (t, b)) -let value_extern ex = approx (Value_extern ex) -let value_symbol sym = - { (approx (Value_symbol sym)) with symbol = Some (sym, None) } -let value_bottom = approx Value_bottom -let value_unresolved value = approx (Value_unresolved value) - -let value_string size contents = approx (Value_string {size; contents }) -let value_mutable_float_array ~size = - approx (Value_float_array { contents = Unknown_or_mutable; size; } ) -let value_immutable_float_array (contents:t array) = - let size = Array.length contents in - let contents = - Array.map (fun t -> augment_with_kind t Pfloatval) contents - in - approx (Value_float_array { contents = Contents contents; size; } ) - -let name_expr_fst (named, thing) ~name = - (Flambda_utils.name_expr named ~name), thing - -let make_const_int_named n : Flambda.named * t = - Const (Int n), value_int n -let make_const_int (n : int) = - let name = - match n with - | 0 -> Internal_variable_names.const_zero - | 1 -> Internal_variable_names.const_one - | _ -> Internal_variable_names.const_int - in - name_expr_fst (make_const_int_named n) ~name - -let make_const_char_named n : Flambda.named * t = - Const (Char n), value_char n -let make_const_char n = - let name = Internal_variable_names.const_char in - name_expr_fst (make_const_char_named n) ~name - -let make_const_ptr_named n : Flambda.named * t = - Const (Const_pointer n), value_constptr n -let make_const_ptr (n : int) = - let name = - match n with - | 0 -> Internal_variable_names.const_ptr_zero - | 1 -> Internal_variable_names.const_ptr_one - | _ -> Internal_variable_names.const_ptr - in - name_expr_fst (make_const_ptr_named n) ~name - -let make_const_bool_named b : Flambda.named * t = - make_const_ptr_named (if b then 1 else 0) -let make_const_bool b = - name_expr_fst (make_const_bool_named b) - ~name:Internal_variable_names.const_bool - -let make_const_float_named f : Flambda.named * t = - Allocated_const (Float f), value_float f -let make_const_float f = - name_expr_fst (make_const_float_named f) - ~name:Internal_variable_names.const_float - -let make_const_boxed_int_named (type bi) (t:bi boxed_int) (i:bi) - : Flambda.named * t = - let c : Allocated_const.t = - match t with - | Int32 -> Int32 i - | Int64 -> Int64 i - | Nativeint -> Nativeint i - in - Allocated_const c, value_boxed_int t i -let make_const_boxed_int t i = - name_expr_fst (make_const_boxed_int_named t i) - ~name:Internal_variable_names.const_boxed_int - -type simplification_summary = - | Nothing_done - | Replaced_term - -type simplification_result = Flambda.t * simplification_summary * t -type simplification_result_named = Flambda.named * simplification_summary * t - -let simplify t (lam : Flambda.t) : simplification_result = - if Effect_analysis.no_effects lam then - match t.descr with - | Value_int n -> - let const, approx = make_const_int n in - const, Replaced_term, approx - | Value_char n -> - let const, approx = make_const_char n in - const, Replaced_term, approx - | Value_constptr n -> - let const, approx = make_const_ptr n in - const, Replaced_term, approx - | Value_float (Some f) -> - let const, approx = make_const_float f in - const, Replaced_term, approx - | Value_boxed_int (t, i) -> - let const, approx = make_const_boxed_int t i in - const, Replaced_term, approx - | Value_symbol sym -> - let name = Internal_variable_names.symbol in - U.name_expr (Symbol sym) ~name, Replaced_term, t - | Value_string _ | Value_float_array _ | Value_float None - | Value_block _ | Value_set_of_closures _ | Value_closure _ - | Value_unknown _ | Value_bottom | Value_extern _ | Value_unresolved _ -> - lam, Nothing_done, t - else - lam, Nothing_done, t - -let simplify_named t (named : Flambda.named) : simplification_result_named = - if Effect_analysis.no_effects_named named then - match t.descr with - | Value_int n -> - let const, approx = make_const_int_named n in - const, Replaced_term, approx - | Value_char n -> - let const, approx = make_const_char_named n in - const, Replaced_term, approx - | Value_constptr n -> - let const, approx = make_const_ptr_named n in - const, Replaced_term, approx - | Value_float (Some f) -> - let const, approx = make_const_float_named f in - const, Replaced_term, approx - | Value_boxed_int (t, i) -> - let const, approx = make_const_boxed_int_named t i in - const, Replaced_term, approx - | Value_symbol sym -> - Symbol sym, Replaced_term, t - | Value_string _ | Value_float_array _ | Value_float None - | Value_block _ | Value_set_of_closures _ | Value_closure _ - | Value_unknown _ | Value_bottom | Value_extern _ | Value_unresolved _ -> - named, Nothing_done, t - else - named, Nothing_done, t - -(* CR-soon mshinwell: bad name. This function and its call site in - [Inline_and_simplify] is also messy. *) -let simplify_var t : (Flambda.named * t) option = - match t.descr with - | Value_int n -> Some (make_const_int_named n) - | Value_char n -> Some (make_const_char_named n) - | Value_constptr n -> Some (make_const_ptr_named n) - | Value_float (Some f) -> Some (make_const_float_named f) - | Value_boxed_int (t, i) -> Some (make_const_boxed_int_named t i) - | Value_symbol sym -> Some (Symbol sym, t) - | Value_string _ | Value_float_array _ | Value_float None - | Value_block _ | Value_set_of_closures _ | Value_closure _ - | Value_unknown _ | Value_bottom | Value_extern _ - | Value_unresolved _ -> - match t.symbol with - | Some (sym, None) -> Some (Symbol sym, t) - | Some (sym, Some field) -> Some (Read_symbol_field (sym, field), t) - | None -> None - -let join_summaries summary ~replaced_by_var_or_symbol = - match replaced_by_var_or_symbol, summary with - | true, Nothing_done - | true, Replaced_term - | false, Replaced_term -> Replaced_term - | false, Nothing_done -> Nothing_done - -let simplify_using_env t ~is_present_in_env flam = - let replaced_by_var_or_symbol, flam = - match t.var with - | Some var when is_present_in_env var -> true, Flambda.Var var - | _ -> - match t.symbol with - | Some (sym, None) -> - let name = Internal_variable_names.symbol in - (true, U.name_expr (Symbol sym) ~name) - | Some (sym, Some field) -> - let name = Internal_variable_names.symbol_field in - (true, U.name_expr (Read_symbol_field (sym, field)) ~name) - | None -> false, flam - in - let const, summary, approx = simplify t flam in - const, join_summaries summary ~replaced_by_var_or_symbol, approx - -let simplify_named_using_env t ~is_present_in_env named = - let replaced_by_var_or_symbol, named = - match t.var with - | Some var when is_present_in_env var -> - true, Flambda.Expr (Var var) - | _ -> - match t.symbol with - | Some (sym, None) -> true, (Flambda.Symbol sym:Flambda.named) - | Some (sym, Some field) -> - true, Flambda.Read_symbol_field (sym, field) - | None -> false, named - in - let const, summary, approx = simplify_named t named in - const, join_summaries summary ~replaced_by_var_or_symbol, approx - -let simplify_var_to_var_using_env t ~is_present_in_env = - match t.var with - | Some var when is_present_in_env var -> Some var - | _ -> None - -let known t = - match t.descr with - | Value_unresolved _ - | Value_unknown _ -> false - | Value_string _ | Value_float_array _ - | Value_bottom | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_set_of_closures _ | Value_closure _ - | Value_extern _ | Value_float _ | Value_boxed_int _ | Value_symbol _ -> true - -let useful t = - match t.descr with - | Value_unresolved _ | Value_unknown _ | Value_bottom -> false - | Value_string _ | Value_float_array _ | Value_block _ | Value_int _ - | Value_char _ | Value_constptr _ | Value_set_of_closures _ - | Value_float _ | Value_boxed_int _ | Value_closure _ | Value_extern _ - | Value_symbol _ -> true - -let all_not_useful ts = List.for_all (fun t -> not (useful t)) ts - -let warn_on_mutation t = - match t.descr with - | Value_block(_, fields) -> Array.length fields > 0 - | Value_string { contents = Some _ } - | Value_int _ | Value_char _ | Value_constptr _ - | Value_set_of_closures _ | Value_float _ | Value_boxed_int _ - | Value_closure _ -> true - | Value_string { contents = None } | Value_float_array _ - | Value_unresolved _ | Value_unknown _ | Value_bottom -> false - | Value_extern _ | Value_symbol _ -> assert false - -type get_field_result = - | Ok of t - | Unreachable - -let get_field t ~field_index:i : get_field_result = - match t.descr with - | Value_block (_tag, fields) -> - if i >= 0 && i < Array.length fields then begin - Ok fields.(i) - end else begin - (* This (unfortunately) cannot be a fatal error; it can happen if a - .cmx file is missing. However for debugging the compiler this can - be a useful point to put a [Misc.fatal_errorf]. *) - Unreachable - end - (* CR-someday mshinwell: This should probably return Unreachable in more - cases. I added a couple more. *) - | Value_bottom - | Value_int _ | Value_char _ | Value_constptr _ -> - (* Something seriously wrong is happening: either the user is doing - something exceptionally unsafe, or it is an unreachable branch. - We consider this as unreachable and mark the result accordingly. *) - Ok value_bottom - | Value_float_array _ -> - (* For the moment we return "unknown" even for immutable arrays, since - it isn't possible for user code to project from an immutable array. *) - (* CR-someday mshinwell: If Leo's array's patch lands, then we can - change this, although it's probably not Pfield that is used to - do the projection. *) - Ok (value_unknown Other) - | Value_string _ | Value_float _ | Value_boxed_int _ -> - (* The user is doing something unsafe. *) - Unreachable - | Value_set_of_closures _ | Value_closure _ - (* This is used by [CamlinternalMod]. *) - | Value_symbol _ | Value_extern _ -> - (* These should have been resolved. *) - Ok (value_unknown Other) - | Value_unknown reason -> - Ok (value_unknown reason) - | Value_unresolved value -> - (* We don't know anything, but we must remember that it comes - from another compilation unit in case it contains a closure. *) - Ok (value_unknown (Unresolved_value value)) - -type checked_approx_for_block = - | Wrong - | Ok of Tag.t * t array - -let check_approx_for_block t = - match t.descr with - | Value_block (tag, fields) -> - Ok (tag, fields) - | Value_bottom - | Value_int _ | Value_char _ | Value_constptr _ - | Value_float_array _ - | Value_string _ | Value_float _ | Value_boxed_int _ - | Value_set_of_closures _ | Value_closure _ - | Value_symbol _ | Value_extern _ - | Value_unknown _ - | Value_unresolved _ -> - Wrong - -let descrs approxs = List.map (fun v -> v.descr) approxs - -let equal_boxed_int (type t1) (type t2) - (bi1:t1 boxed_int) (i1:t1) - (bi2:t2 boxed_int) (i2:t2) = - match bi1, bi2 with - | Int32, Int32 -> Int32.equal i1 i2 - | Int64, Int64 -> Int64.equal i1 i2 - | Nativeint, Nativeint -> Nativeint.equal i1 i2 - | _ -> false - -let equal_floats f1 f2 = - match f1, f2 with - | None, None -> true - | None, Some _ | Some _, None -> false - | Some f1, Some f2 -> Allocated_const.compare_floats f1 f2 = 0 - -(* Closures and set of closures descriptions cannot be merged. - - let f x = - let g y -> x + y in - g - in - let v = - if ... - then f 1 - else f 2 - in - v 3 - - The approximation for [f 1] and [f 2] could both contain the - description of [g]. But if [f] where inlined, a new [g] would - be created in each branch, leading to incompatible description. - And we must never make the description for a function less - precise that it used to be: its information are needed for - rewriting [Project_var] and [Project_closure] constructions - in [Flambdainline.loop] -*) -let rec meet_descr ~really_import_approx d1 d2 = match d1, d2 with - | Value_int i, Value_int j when i = j -> - d1 - | Value_constptr i, Value_constptr j when i = j -> - d1 - | Value_symbol s1, Value_symbol s2 when Symbol.equal s1 s2 -> - d1 - | Value_extern e1, Value_extern e2 when Export_id.equal e1 e2 -> - d1 - | Value_float i, Value_float j when equal_floats i j -> - d1 - | Value_boxed_int (bi1, i1), Value_boxed_int (bi2, i2) when - equal_boxed_int bi1 i1 bi2 i2 -> - d1 - | Value_block (tag1, a1), Value_block (tag2, a2) - when Tag.compare tag1 tag2 = 0 && Array.length a1 = Array.length a2 -> - let fields = - Array.mapi (fun i v -> meet ~really_import_approx v a2.(i)) a1 - in - Value_block (tag1, fields) - | _ -> Value_unknown Other - -and meet ~really_import_approx a1 a2 = - match a1, a2 with - | { descr = Value_bottom }, a - | a, { descr = Value_bottom } -> a - | { descr = (Value_symbol _ | Value_extern _) }, _ - | _, { descr = (Value_symbol _ | Value_extern _) } -> - meet ~really_import_approx - (really_import_approx a1) (really_import_approx a2) - | _ -> - let var = - match a1.var, a2.var with - | None, _ | _, None -> None - | Some v1, Some v2 -> - if Variable.equal v1 v2 - then Some v1 - else None - in - let symbol = - match a1.symbol, a2.symbol with - | None, _ | _, None -> None - | Some (v1, field1), Some (v2, field2) -> - if Symbol.equal v1 v2 - then match field1, field2 with - | None, None -> a1.symbol - | Some f1, Some f2 when f1 = f2 -> - a1.symbol - | _ -> None - else None - in - { descr = meet_descr ~really_import_approx a1.descr a2.descr; - var; - symbol } - -(* Given a set-of-closures approximation and a closure ID, apply any - freshening specified in the approximation to the closure ID, and return - that new closure ID. A fatal error is produced if the new closure ID - does not correspond to a function declaration in the given approximation. *) -let freshen_and_check_closure_id - (value_set_of_closures : value_set_of_closures) closure_id = - let closure_id = - Freshening.Project_var.apply_closure_id - value_set_of_closures.freshening closure_id - in - try - ignore ( - Variable.Map.find (Closure_id.unwrap closure_id) - value_set_of_closures.function_decls.funs - ); - closure_id - with Not_found -> - Misc.fatal_error (Format.asprintf - "Function %a not found in the set of closures@ %a@.%a@." - Closure_id.print closure_id - print_value_set_of_closures value_set_of_closures - print_function_declarations value_set_of_closures.function_decls) - -type checked_approx_for_set_of_closures = - | Wrong - | Unresolved of unresolved_value - | Unknown - | Unknown_because_of_unresolved_value of unresolved_value - | Ok of Variable.t option * value_set_of_closures - -let check_approx_for_set_of_closures t : checked_approx_for_set_of_closures = - match t.descr with - | Value_unresolved value -> Unresolved value - | Value_unknown (Unresolved_value value) -> - Unknown_because_of_unresolved_value value - | Value_set_of_closures value_set_of_closures -> - (* Note that [var] might be [None]; we might be reaching the set of - closures via approximations only, with the variable originally bound - to the set now out of scope. *) - Ok (t.var, value_set_of_closures) - | Value_closure _ | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_float _ | Value_boxed_int _ | Value_unknown _ - | Value_bottom | Value_extern _ | Value_string _ | Value_float_array _ - | Value_symbol _ -> - Wrong - -type strict_checked_approx_for_set_of_closures = - | Wrong - | Ok of Variable.t option * value_set_of_closures - -let strict_check_approx_for_set_of_closures t - : strict_checked_approx_for_set_of_closures = - match check_approx_for_set_of_closures t with - | Ok (var, value_set_of_closures) -> Ok (var, value_set_of_closures) - | Wrong | Unresolved _ - | Unknown | Unknown_because_of_unresolved_value _ -> Wrong - -type checked_approx_for_closure_allowing_unresolved = - | Wrong - | Unresolved of unresolved_value - | Unknown - | Unknown_because_of_unresolved_value of unresolved_value - | Ok of value_closure * Variable.t option - * Symbol.t option * value_set_of_closures - -let check_approx_for_closure_allowing_unresolved t - : checked_approx_for_closure_allowing_unresolved = - match t.descr with - | Value_closure value_closure -> - begin match value_closure.set_of_closures.descr with - | Value_set_of_closures value_set_of_closures -> - let symbol = match value_closure.set_of_closures.symbol with - | Some (symbol, None) -> Some symbol - | None | Some (_, Some _) -> None - in - Ok (value_closure, value_closure.set_of_closures.var, - symbol, value_set_of_closures) - | Value_unresolved _ - | Value_closure _ | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_float _ | Value_boxed_int _ | Value_unknown _ - | Value_bottom | Value_extern _ | Value_string _ | Value_float_array _ - | Value_symbol _ -> - Wrong - end - | Value_unknown (Unresolved_value value) -> - Unknown_because_of_unresolved_value value - | Value_unresolved symbol -> Unresolved symbol - | Value_set_of_closures _ | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_float _ | Value_boxed_int _ - | Value_bottom | Value_extern _ | Value_string _ | Value_float_array _ - | Value_symbol _ -> - Wrong - (* CR-soon mshinwell: This should be unwound once the reason for a value - being unknown can be correctly propagated through the export info. *) - | Value_unknown Other -> Unknown - -type checked_approx_for_closure = - | Wrong - | Ok of value_closure * Variable.t option - * Symbol.t option * value_set_of_closures - -let check_approx_for_closure t : checked_approx_for_closure = - match check_approx_for_closure_allowing_unresolved t with - | Ok (value_closure, set_of_closures_var, set_of_closures_symbol, - value_set_of_closures) -> - Ok (value_closure, set_of_closures_var, set_of_closures_symbol, - value_set_of_closures) - | Wrong | Unknown | Unresolved _ | Unknown_because_of_unresolved_value _ -> - Wrong - -let approx_for_bound_var value_set_of_closures var = - try - Var_within_closure.Map.find var value_set_of_closures.bound_vars - with - | Not_found -> - Misc.fatal_errorf "The set-of-closures approximation %a@ does not \ - bind the variable %a@.%s@." - print_value_set_of_closures value_set_of_closures - Var_within_closure.print var - (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int)) - -let check_approx_for_float t : float option = - match t.descr with - | Value_float f -> f - | Value_unresolved _ - | Value_unknown _ | Value_string _ | Value_float_array _ - | Value_bottom | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_set_of_closures _ | Value_closure _ - | Value_extern _ | Value_boxed_int _ | Value_symbol _ -> - None - -let float_array_as_constant (t:value_float_array) : float list option = - match t.contents with - | Unknown_or_mutable -> None - | Contents contents -> - Array.fold_right (fun elt acc -> - match acc, elt.descr with - | Some acc, Value_float (Some f) -> - Some (f :: acc) - | None, _ - | Some _, - (Value_float None | Value_unresolved _ - | Value_unknown _ | Value_string _ | Value_float_array _ - | Value_bottom | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_set_of_closures _ | Value_closure _ - | Value_extern _ | Value_boxed_int _ | Value_symbol _) - -> None) - contents (Some []) - -let check_approx_for_string t : string option = - match t.descr with - | Value_string { contents } -> contents - | Value_float _ - | Value_unresolved _ - | Value_unknown _ | Value_float_array _ - | Value_bottom | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_set_of_closures _ | Value_closure _ - | Value_extern _ | Value_boxed_int _ | Value_symbol _ -> - None - -type switch_branch_selection = - | Cannot_be_taken - | Can_be_taken - | Must_be_taken - -let potentially_taken_const_switch_branch t branch = - match t.descr with - | Value_unresolved _ - | Value_unknown _ - | Value_extern _ - | Value_symbol _ -> - (* In theory symbol cannot contain integers but this shouldn't - matter as this will always be an imported approximation *) - Can_be_taken - | Value_constptr i | Value_int i when i = branch -> - Must_be_taken - | Value_char c when Char.code c = branch -> - Must_be_taken - | Value_constptr _ | Value_int _ | Value_char _ -> - Cannot_be_taken - | Value_block _ | Value_float _ | Value_float_array _ - | Value_string _ | Value_closure _ | Value_set_of_closures _ - | Value_boxed_int _ | Value_bottom -> - Cannot_be_taken - -let potentially_taken_block_switch_branch t tag = - match t.descr with - | (Value_unresolved _ - | Value_unknown _ - | Value_extern _ - | Value_symbol _) -> - Can_be_taken - | (Value_constptr _ | Value_int _| Value_char _) -> - Cannot_be_taken - | Value_block (block_tag, _) when Tag.to_int block_tag = tag -> - Must_be_taken - | Value_float _ when tag = Obj.double_tag -> - Must_be_taken - | Value_float_array _ when tag = Obj.double_array_tag -> - Must_be_taken - | Value_string _ when tag = Obj.string_tag -> - Must_be_taken - | (Value_closure _ | Value_set_of_closures _) - when tag = Obj.closure_tag || tag = Obj.infix_tag -> - Can_be_taken - | Value_boxed_int _ when tag = Obj.custom_tag -> - Must_be_taken - | Value_block _ | Value_float _ | Value_set_of_closures _ | Value_closure _ - | Value_string _ | Value_float_array _ | Value_boxed_int _ -> - Cannot_be_taken - | Value_bottom -> - Cannot_be_taken - -let function_arity (fun_decl : function_declaration) = - List.length fun_decl.params - -let function_declaration_approx ~keep_body fun_var - (fun_decl : Flambda.function_declaration) = - let function_body = - if not (keep_body fun_var fun_decl) then None - else begin - Some { body = fun_decl.body; - stub = fun_decl.stub; - inline = fun_decl.inline; - dbg = fun_decl.dbg; - specialise = fun_decl.specialise; - is_a_functor = fun_decl.is_a_functor; - free_variables = fun_decl.free_variables; - free_symbols = fun_decl.free_symbols; } - end - in - { function_body; - params = fun_decl.params; - closure_origin = fun_decl.closure_origin; } - -let function_declarations_approx ~keep_body - (fun_decls : Flambda.function_declarations) = - let funs = - Variable.Map.mapi (function_declaration_approx ~keep_body) fun_decls.funs - in - { funs; - is_classic_mode = fun_decls.is_classic_mode; - set_of_closures_id = fun_decls.set_of_closures_id; - set_of_closures_origin = fun_decls.set_of_closures_origin; } - -let import_function_declarations_for_pack function_decls - import_set_of_closures_id import_set_of_closures_origin = - { set_of_closures_id = - import_set_of_closures_id function_decls.set_of_closures_id; - set_of_closures_origin = - import_set_of_closures_origin function_decls.set_of_closures_origin; - funs = function_decls.funs; - is_classic_mode = function_decls.is_classic_mode; - } - -let update_function_declarations function_decls ~funs = - let compilation_unit = Compilation_unit.get_current_exn () in - let is_classic_mode = function_decls.is_classic_mode in - let set_of_closures_id = Set_of_closures_id.create compilation_unit in - let set_of_closures_origin = function_decls.set_of_closures_origin in - { is_classic_mode; - set_of_closures_id; - set_of_closures_origin; - funs; - } - -let clear_function_bodies (function_decls : function_declarations) = - let funs = - Variable.Map.map (fun (fun_decl : function_declaration) -> - match fun_decl.function_body with - | None | Some { stub = true; _ } -> - fun_decl - | Some _ -> - { fun_decl with function_body = None }) - function_decls.funs - in - { function_decls with funs } - -let update_function_declaration_body - (function_decl : function_declaration) - (f : Flambda.t -> Flambda.t) = - match function_decl.function_body with - | None -> function_decl - | Some function_body -> - let new_function_body = - let body = f function_body.body in - let free_variables = Flambda.free_variables body in - let free_symbols = Flambda.free_symbols body in - { function_body with free_variables; free_symbols; body; } - in - { function_decl with function_body = Some new_function_body } - -let make_closure_map input = - let map = ref Closure_id.Map.empty in - let add_set_of_closures _ (function_decls : function_declarations) = - Variable.Map.iter (fun var _ -> - let closure_id = Closure_id.wrap var in - map := Closure_id.Map.add closure_id function_decls !map) - function_decls.funs - in - Set_of_closures_id.Map.iter add_set_of_closures input; - !map diff --git a/middle_end/simple_value_approx.mli b/middle_end/simple_value_approx.mli deleted file mode 100644 index dd38652f..00000000 --- a/middle_end/simple_value_approx.mli +++ /dev/null @@ -1,501 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Simple approximations to the runtime results of computations. - This pass is designed for speed rather than accuracy; the performance - is important since it is used heavily during inlining. *) - -type 'a boxed_int = - | Int32 : int32 boxed_int - | Int64 : int64 boxed_int - | Nativeint : nativeint boxed_int - -type value_string = { - contents : string option; (* [None] if unknown or mutable *) - size : int; -} - -type unresolved_value = - | Set_of_closures_id of Set_of_closures_id.t - | Symbol of Symbol.t - -type unknown_because_of = - | Unresolved_value of unresolved_value - | Other - -(** A value of type [t] corresponds to an "approximation" of the result of - a computation in the program being compiled. That is to say, it - represents what knowledge we have about such a result at compile time. - The simplification pass exploits this information to partially evaluate - computations. - - At a high level, an approximation for a value [v] has three parts: - - the "description" (for example, "the constant integer 42"); - - an optional variable; - - an optional symbol or symbol field. - If the variable (resp. symbol) is present then that variable (resp. - symbol) may be used to obtain the value [v]. - - The exact semantics of the variable and symbol fields follows. - - Approximations are deduced at particular points in an expression tree, - but may subsequently be propagated to other locations. - - At the point at which an approximation is built for some value [v], we can - construct a set of variables (call the set [S]) that are known to alias the - same value [v]. Each member of [S] will have the same or a more precise - [descr] field in its approximation relative to the approximation for [v]. - (An increase in precision may currently be introduced for pattern - matches.) If [S] is non-empty then it is guaranteed that there is a - unique member of [S] that was declared in a scope further out ("earlier") - than all other members of [S]. If such a member exists then it is - recorded in the [var] field. Otherwise [var] is [None]. - - Analogous to the construction of the set [S], we can construct a set [T] - consisting of all symbols that are known to alias the value whose - approximation is being constructed. If [T] is non-empty then the - [symbol] field is set to some member of [T]; it does not matter which - one. (There is no notion of scope for symbols.) - - Note about mutable blocks: - - Mutable blocks are always represented by [Value_unknown] or - [Value_bottom]. Any other approximation could leave the door open to - a miscompilation. Such bad scenarios are most likely a user using - [Obj.magic] or [Obj.set_field] in an inappropriate situation. - Such a situation might be: - [let x = (1, 1) in - Obj.set_field (Obj.repr x) 0 (Obj.repr 2); - assert(fst x = 2)] - The user would probably expect the assertion to be true, but the - compiler could in fact propagate the value of [x] across the - [Obj.set_field]. - - Insisting that mutable blocks have [Value_unknown] or [Value_bottom] - approximations certainly won't always prevent this kind of error, but - should help catch many of them. - - It is possible that there may be some false positives, with correct - but unreachable code causing this check to fail. However the likelihood - of this seems sufficiently low, especially compared to the advantages - gained by performing the check, that we include it. - - An example of a pattern that might trigger a false positive is: - [type a = { a : int } - type b = { mutable b : int } - type _ t = - | A : a t - | B : b t - let f (type x) (v:x t) (r:x) = - match v with - | A -> r.a - | B -> r.b <- 2; 3 - - let v = - let r = - ref A in - r := A; (* Some pattern that the compiler can't understand *) - f !r { a = 1 }] - When inlining [f], the B branch is unreachable, yet the compiler - cannot prove it and must therefore keep it. -*) -type t = private { - descr : descr; - var : Variable.t option; - symbol : (Symbol.t * int option) option; -} - -and descr = private - | Value_block of Tag.t * t array - | Value_int of int - | Value_char of char - | Value_constptr of int - | Value_float of float option - | Value_boxed_int : 'a boxed_int * 'a -> descr - | Value_set_of_closures of value_set_of_closures - | Value_closure of value_closure - | Value_string of value_string - | Value_float_array of value_float_array - | Value_unknown of unknown_because_of - | Value_bottom - | Value_extern of Export_id.t - | Value_symbol of Symbol.t - | Value_unresolved of unresolved_value - (* No description was found for this value *) - -and value_closure = { - set_of_closures : t; - closure_id : Closure_id.t; -} - -and function_declarations = private { - is_classic_mode: bool; - set_of_closures_id : Set_of_closures_id.t; - set_of_closures_origin : Set_of_closures_origin.t; - funs : function_declaration Variable.Map.t; -} - -and function_body = private { - free_variables : Variable.Set.t; - free_symbols : Symbol.Set.t; - stub : bool; - dbg : Debuginfo.t; - inline : Lambda.inline_attribute; - specialise : Lambda.specialise_attribute; - is_a_functor : bool; - body : Flambda.t; -} - -and function_declaration = private { - closure_origin : Closure_origin.t; - params : Parameter.t list; - function_body : function_body option; -} - - -(* CR-soon mshinwell: add support for the approximations of the results, so we - can do all of the tricky higher-order cases. *) -(* when [is_classic_mode] is [false], functions in [function_declarations] - are guaranteed to have function bodies (ie: - [function_declaration.function_body] will be of the [Some] variant). - - When it [is_classic_mode] is [true], however, no guarantees about the - function_bodies are given. -*) -and value_set_of_closures = private { - function_decls : function_declarations; - bound_vars : t Var_within_closure.Map.t; - free_vars : Flambda.specialised_to Variable.Map.t; - invariant_params : Variable.Set.t Variable.Map.t Lazy.t; - recursive : Variable.Set.t Lazy.t; - size : int option Variable.Map.t Lazy.t; - (** For functions that are very likely to be inlined, the size of the - function's body. *) - specialised_args : Flambda.specialised_to Variable.Map.t; - (* Any freshening that has been applied to [function_decls]. *) - freshening : Freshening.Project_var.t; - direct_call_surrogates : Closure_id.t Closure_id.Map.t; -} - -and value_float_array_contents = - | Contents of t array - | Unknown_or_mutable - -and value_float_array = { - contents : value_float_array_contents; - size : int; -} - -(** Extraction of the description of approximation(s). *) -val descr : t -> descr -val descrs : t list -> descr list - -(** Pretty-printing of approximations to a formatter. *) -val print : Format.formatter -> t -> unit -val print_descr : Format.formatter -> descr -> unit -val print_value_set_of_closures - : Format.formatter - -> value_set_of_closures - -> unit -val print_function_declarations - : Format.formatter - -> function_declarations - -> unit - -val function_declarations_approx - : keep_body:(Variable.t -> Flambda.function_declaration -> bool) - -> Flambda.function_declarations - -> function_declarations - -val create_value_set_of_closures - : function_decls:function_declarations - -> bound_vars:t Var_within_closure.Map.t - -> free_vars:Flambda.specialised_to Variable.Map.t - -> invariant_params:Variable.Set.t Variable.Map.t lazy_t - -> recursive:Variable.Set.t Lazy.t - -> specialised_args:Flambda.specialised_to Variable.Map.t - -> freshening:Freshening.Project_var.t - -> direct_call_surrogates:Closure_id.t Closure_id.Map.t - -> value_set_of_closures - -val update_freshening_of_value_set_of_closures - : value_set_of_closures - -> freshening:Freshening.Project_var.t - -> value_set_of_closures - -(** Basic construction of approximations. *) -val value_unknown : unknown_because_of -> t -val value_int : int -> t -val value_char : char -> t -val value_float : float -> t -val value_any_float : t -val value_mutable_float_array : size:int -> t -val value_immutable_float_array : t array -> t -val value_string : int -> string option -> t -val value_boxed_int : 'i boxed_int -> 'i -> t -val value_constptr : int -> t -val value_block : Tag.t -> t array -> t -val value_extern : Export_id.t -> t -val value_symbol : Symbol.t -> t -val value_bottom : t -val value_unresolved : unresolved_value -> t - -(** Construct a closure approximation given the approximation of the - corresponding set of closures and the closure ID of the closure to - be projected from such set. [closure_var] and/or [set_of_closures_var] - may be specified to augment the approximation with variables that may - be used to access the closure value itself, so long as they are in - scope at the proposed point of use. *) -val value_closure - : ?closure_var:Variable.t - -> ?set_of_closures_var:Variable.t - -> ?set_of_closures_symbol:Symbol.t - -> value_set_of_closures - -> Closure_id.t - -> t - -(** Construct a set of closures approximation. [set_of_closures_var] is as for - the parameter of the same name in [value_closure], above. *) -val value_set_of_closures - : ?set_of_closures_var:Variable.t - -> value_set_of_closures - -> t - -(** Take the given constant and produce an appropriate approximation for it - together with an Flambda expression representing it. *) -val make_const_int : int -> Flambda.t * t -val make_const_char : char -> Flambda.t * t -val make_const_ptr : int -> Flambda.t * t -val make_const_bool : bool -> Flambda.t * t -val make_const_float : float -> Flambda.t * t -val make_const_boxed_int : 'i boxed_int -> 'i -> Flambda.t * t - -val make_const_int_named : int -> Flambda.named * t -val make_const_char_named : char -> Flambda.named * t -val make_const_ptr_named : int -> Flambda.named * t -val make_const_bool_named : bool -> Flambda.named * t -val make_const_float_named : float -> Flambda.named * t -val make_const_boxed_int_named : 'i boxed_int -> 'i -> Flambda.named * t - -(** Augment an approximation with a given variable (see comment above). - If the approximation was already augmented with a variable, the one - passed to this function replaces it within the approximation. *) -val augment_with_variable : t -> Variable.t -> t - -(** Like [augment_with_variable], but for symbol information. *) -val augment_with_symbol : t -> Symbol.t -> t - -(** Like [augment_with_symbol], but for symbol field information. *) -val augment_with_symbol_field : t -> Symbol.t -> int -> t - -(** Replace the description within an approximation. *) -val replace_description : t -> descr -> t - -(** Improve the description by taking the kind into account *) -val augment_with_kind : t -> Lambda.value_kind -> t - -(** Improve the kind by taking the description into account *) -val augment_kind_with_approx : t -> Lambda.value_kind -> Lambda.value_kind - -val equal_boxed_int : 'a boxed_int -> 'a -> 'b boxed_int -> 'b -> bool - -(* CR-soon mshinwell for pchambart: Add comment describing semantics. (Maybe - we should move the comment from the .ml file into here.) *) -val meet : really_import_approx:(t -> t) -> t -> t -> t - -(** An approximation is "known" iff it is not [Value_unknown]. *) -val known : t -> bool - -(** An approximation is "useful" iff it is neither unknown nor bottom. *) -val useful : t -> bool - -(** Whether all approximations in the given list do *not* satisfy [useful]. *) -val all_not_useful : t list -> bool - -(** Whether to warn on attempts to mutate a value. - It must have been resolved (it cannot be [Value_extern] or - [Value_symbol]). (See comment above for further explanation.) *) -val warn_on_mutation : t -> bool - -type simplification_summary = - | Nothing_done - | Replaced_term - -type simplification_result = Flambda.t * simplification_summary * t -type simplification_result_named = Flambda.named * simplification_summary * t - -(** Given an expression and its approximation, attempt to simplify the - expression to a constant (with associated approximation), taking into - account whether the expression has any side effects. *) -val simplify : t -> Flambda.t -> simplification_result - -(** As for [simplify], but also enables us to simplify based on equalities - between variables. The caller must provide a function that tells us - whether, if we simplify to a given variable, the value of that variable - will be accessible in the current environment. *) -val simplify_using_env - : t - -> is_present_in_env:(Variable.t -> bool) - -> Flambda.t - -> simplification_result - -val simplify_named : t -> Flambda.named -> simplification_result_named - -val simplify_named_using_env - : t - -> is_present_in_env:(Variable.t -> bool) - -> Flambda.named - -> simplification_result_named - -(** If the given approximation identifies another variable and - [is_present_in_env] deems it to be in scope, return that variable (wrapped - in a [Some]), otherwise return [None]. *) -val simplify_var_to_var_using_env - : t - -> is_present_in_env:(Variable.t -> bool) - -> Variable.t option - -val simplify_var : t -> (Flambda.named * t) option - -type get_field_result = - | Ok of t - | Unreachable - -(** Given the approximation [t] of a value, expected to correspond to a block - (in the [Pmakeblock] sense of the word), and a field index then return - an appropriate approximation for that field of the block (or - [Unreachable] if the code with the approximation [t] is unreachable). - N.B. Not all cases of unreachable code are returned as [Unreachable]. -*) -val get_field : t -> field_index:int -> get_field_result - -type checked_approx_for_block = - | Wrong - | Ok of Tag.t * t array - -(** Try to prove that a value with the given approximation may be used - as a block. *) -val check_approx_for_block : t -> checked_approx_for_block - -(** Find the approximation for a bound variable in a set-of-closures - approximation. A fatal error is produced if the variable is not bound in - the given approximation. *) -val approx_for_bound_var : value_set_of_closures -> Var_within_closure.t -> t - -(** Given a set-of-closures approximation and a closure ID, apply any - freshening specified by the approximation to the closure ID, and return - the resulting ID. Causes a fatal error if the resulting closure ID does - not correspond to any function declaration in the approximation. *) -val freshen_and_check_closure_id - : value_set_of_closures - -> Closure_id.t - -> Closure_id.t - -type strict_checked_approx_for_set_of_closures = - | Wrong - | Ok of Variable.t option * value_set_of_closures - -val strict_check_approx_for_set_of_closures - : t - -> strict_checked_approx_for_set_of_closures - -type checked_approx_for_set_of_closures = - | Wrong - | Unresolved of unresolved_value - | Unknown - | Unknown_because_of_unresolved_value of unresolved_value - (* In the [Ok] case, there may not be a variable associated with the set of - closures; it might be out of scope. *) - | Ok of Variable.t option * value_set_of_closures - -(** Try to prove that a value with the given approximation may be used as a - set of closures. Values coming from external compilation units with - unresolved approximations are permitted. *) -val check_approx_for_set_of_closures : t -> checked_approx_for_set_of_closures - -type checked_approx_for_closure = - | Wrong - | Ok of value_closure * Variable.t option - * Symbol.t option * value_set_of_closures - -(** Try to prove that a value with the given approximation may be used as a - closure. Values coming from external compilation units with unresolved - approximations are not permitted. *) -(* CR-someday mshinwell: naming is inconsistent: this is as "strict" - as "strict_check_approx_for_set_of_closures" *) -val check_approx_for_closure : t -> checked_approx_for_closure - -type checked_approx_for_closure_allowing_unresolved = - | Wrong - | Unresolved of unresolved_value - | Unknown - | Unknown_because_of_unresolved_value of unresolved_value - | Ok of value_closure * Variable.t option - * Symbol.t option * value_set_of_closures - -(** As for [check_approx_for_closure], but values coming from external - compilation units with unresolved approximations are permitted. *) -val check_approx_for_closure_allowing_unresolved - : t - -> checked_approx_for_closure_allowing_unresolved - -(** Returns the value if it can be proved to be a constant float *) -val check_approx_for_float : t -> float option - -(** Returns the value if it can be proved to be a constant float array *) -val float_array_as_constant : value_float_array -> float list option - -(** Returns the value if it can be proved to be a constant string *) -val check_approx_for_string : t -> string option - -type switch_branch_selection = - | Cannot_be_taken - | Can_be_taken - | Must_be_taken - -(** Check that the branch is compatible with the approximation *) -val potentially_taken_const_switch_branch : t -> int -> switch_branch_selection -val potentially_taken_block_switch_branch : t -> int -> switch_branch_selection - -val function_arity : function_declaration -> int - -(** Create a set of function declarations based on another set of function - declarations. *) -val update_function_declarations - : function_declarations - -> funs:function_declaration Variable.Map.t - -> function_declarations - -val import_function_declarations_for_pack - : function_declarations - -> (Set_of_closures_id.t -> Set_of_closures_id.t) - -> (Set_of_closures_origin.t -> Set_of_closures_origin.t) - -> function_declarations - -val update_function_declaration_body - : function_declaration - -> (Flambda.t -> Flambda.t) - -> function_declaration - -(** Creates a map from closure IDs to function declarations by iterating over - all sets of closures in the given map. *) -val make_closure_map - : function_declarations Set_of_closures_id.Map.t - -> function_declarations Closure_id.Map.t - -val clear_function_bodies : function_declarations -> function_declarations diff --git a/middle_end/simplify_boxed_integer_ops.ml b/middle_end/simplify_boxed_integer_ops.ml deleted file mode 100644 index 24d51e53..00000000 --- a/middle_end/simplify_boxed_integer_ops.ml +++ /dev/null @@ -1,116 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module S = Simplify_common - -(* Simplification of operations on boxed integers (nativeint, Int32, Int64). *) -module Simplify_boxed_integer_operator (I : sig - type t - val kind : Lambda.boxed_integer - val zero : t - val add : t -> t -> t - val sub : t -> t -> t - val mul : t -> t -> t - val div : t -> t -> t - val rem : t -> t -> t - val logand : t -> t -> t - val logor : t -> t -> t - val logxor : t -> t -> t - val shift_left : t -> int -> t - val shift_right : t -> int -> t - val shift_right_logical : t -> int -> t - val to_int : t -> int - val to_int32 : t -> Int32.t - val to_int64 : t -> Int64.t - val neg : t -> t - val swap : t -> t - val compare : t -> t -> int -end) : Simplify_boxed_integer_ops_intf.S with type t := I.t = struct - module A = Simple_value_approx - module C = Inlining_cost - - let equal_kind = Lambda.equal_boxed_integer - - let simplify_unop (p : Lambda.primitive) (kind : I.t A.boxed_int) - expr (n : I.t) = - let eval op = S.const_boxed_int_expr expr kind (op n) in - let eval_conv kind op = S.const_boxed_int_expr expr kind (op n) in - let eval_unboxed op = S.const_int_expr expr (op n) in - match p with - | Pintofbint kind when equal_kind kind I.kind -> eval_unboxed I.to_int - | Pcvtbint (kind, Pint32) when equal_kind kind I.kind -> - eval_conv A.Int32 I.to_int32 - | Pcvtbint (kind, Pint64) when equal_kind kind I.kind -> - eval_conv A.Int64 I.to_int64 - | Pnegbint kind when equal_kind kind I.kind -> eval I.neg - | Pbbswap kind when equal_kind kind I.kind -> eval I.swap - | _ -> expr, A.value_unknown Other, C.Benefit.zero - - let simplify_binop (p : Lambda.primitive) (kind : I.t A.boxed_int) - expr (n1 : I.t) (n2 : I.t) = - let eval op = S.const_boxed_int_expr expr kind (op n1 n2) in - let non_zero n = (I.compare I.zero n) <> 0 in - match p with - | Paddbint kind when equal_kind kind I.kind -> eval I.add - | Psubbint kind when equal_kind kind I.kind -> eval I.sub - | Pmulbint kind when equal_kind kind I.kind -> eval I.mul - | Pdivbint {size=kind} when equal_kind kind I.kind && non_zero n2 -> - eval I.div - | Pmodbint {size=kind} when equal_kind kind I.kind && non_zero n2 -> - eval I.rem - | Pandbint kind when equal_kind kind I.kind -> eval I.logand - | Porbint kind when equal_kind kind I.kind -> eval I.logor - | Pxorbint kind when equal_kind kind I.kind -> eval I.logxor - | Pbintcomp (kind, c) when equal_kind kind I.kind -> - S.const_integer_comparison_expr expr c n1 n2 - | _ -> expr, A.value_unknown Other, C.Benefit.zero - - let simplify_binop_int (p : Lambda.primitive) (kind : I.t A.boxed_int) - expr (n1 : I.t) (n2 : int) ~size_int = - let eval op = S.const_boxed_int_expr expr kind (op n1 n2) in - let precond = 0 <= n2 && n2 < 8 * size_int in - match p with - | Plslbint kind when equal_kind kind I.kind && precond -> eval I.shift_left - | Plsrbint kind when equal_kind kind I.kind && precond -> - eval I.shift_right_logical - | Pasrbint kind when equal_kind kind I.kind && precond -> eval I.shift_right - | _ -> expr, A.value_unknown Other, C.Benefit.zero -end - -module Simplify_boxed_nativeint = Simplify_boxed_integer_operator (struct - include Nativeint - let to_int64 = Int64.of_nativeint - let swap = S.swapnative - let kind = Lambda.Pnativeint -end) - -module Simplify_boxed_int32 = Simplify_boxed_integer_operator (struct - include Int32 - let to_int32 i = i - let to_int64 = Int64.of_int32 - let swap = S.swap32 - let kind = Lambda.Pint32 -end) - -module Simplify_boxed_int64 = Simplify_boxed_integer_operator (struct - include Int64 - let to_int64 i = i - let swap = S.swap64 - let kind = Lambda.Pint64 -end) diff --git a/middle_end/simplify_boxed_integer_ops.mli b/middle_end/simplify_boxed_integer_ops.mli deleted file mode 100644 index f3461043..00000000 --- a/middle_end/simplify_boxed_integer_ops.mli +++ /dev/null @@ -1,28 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(* Simplification of operations on boxed integers (nativeint, Int32, Int64). *) - -module Simplify_boxed_nativeint : Simplify_boxed_integer_ops_intf.S - with type t := Nativeint.t - -module Simplify_boxed_int32 : Simplify_boxed_integer_ops_intf.S - with type t := Int32.t - -module Simplify_boxed_int64 : Simplify_boxed_integer_ops_intf.S - with type t := Int64.t diff --git a/middle_end/simplify_boxed_integer_ops_intf.mli b/middle_end/simplify_boxed_integer_ops_intf.mli deleted file mode 100644 index ee621002..00000000 --- a/middle_end/simplify_boxed_integer_ops_intf.mli +++ /dev/null @@ -1,45 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -module type S = sig - type t - - val simplify_unop - : Lambda.primitive - -> t Simple_value_approx.boxed_int - -> Flambda.named - -> t - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - - val simplify_binop - : Lambda.primitive - -> t Simple_value_approx.boxed_int - -> Flambda.named - -> t - -> t - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - - val simplify_binop_int - : Lambda.primitive - -> t Simple_value_approx.boxed_int - -> Flambda.named - -> t - -> int - -> size_int:int - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t -end diff --git a/middle_end/simplify_common.ml b/middle_end/simplify_common.ml deleted file mode 100644 index fcbbcfbc..00000000 --- a/middle_end/simplify_common.ml +++ /dev/null @@ -1,86 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module A = Simple_value_approx -module C = Inlining_cost - -external swap16 : int -> int = "%bswap16" -external swap32 : int32 -> int32 = "%bswap_int32" -external swap64 : int64 -> int64 = "%bswap_int64" -external swapnative : nativeint -> nativeint = "%bswap_native" - -let const_int_expr expr n = - if Effect_analysis.no_effects_named expr then - let (new_expr, approx) = A.make_const_int_named n in - new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero - else expr, A.value_int n, C.Benefit.zero -let const_char_expr expr c = - if Effect_analysis.no_effects_named expr then - let (new_expr, approx) = A.make_const_char_named c in - new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero - else expr, A.value_char c, C.Benefit.zero -let const_ptr_expr expr n = - if Effect_analysis.no_effects_named expr then - let (new_expr, approx) = A.make_const_ptr_named n in - new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero - else expr, A.value_constptr n, C.Benefit.zero -let const_bool_expr expr b = - const_int_expr expr (if b then 1 else 0) -let const_float_expr expr f = - if Effect_analysis.no_effects_named expr then - let (new_expr, approx) = A.make_const_float_named f in - new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero - else expr, A.value_float f, C.Benefit.zero -let const_boxed_int_expr expr t i = - if Effect_analysis.no_effects_named expr then - let (new_expr, approx) = A.make_const_boxed_int_named t i in - new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero - else expr, A.value_boxed_int t i, C.Benefit.zero - -let const_integer_comparison_expr expr (cmp : Lambda.integer_comparison) x y = - (* Using the [Stdlib] comparison functions here in the compiler - coincides with the definitions of such functions in the code - compiled by the user, and is thus correct. *) - let open! Stdlib in - const_bool_expr expr - (match cmp with - | Ceq -> x = y - | Cne -> x <> y - | Clt -> x < y - | Cgt -> x > y - | Cle -> x <= y - | Cge -> x >= y) - -let const_float_comparison_expr expr (cmp : Lambda.float_comparison) x y = - (* Using the [Stdlib] comparison functions here in the compiler - coincides with the definitions of such functions in the code - compiled by the user, and is thus correct. *) - let open! Stdlib in - const_bool_expr expr - (match cmp with - | CFeq -> x = y - | CFneq -> not (x = y) - | CFlt -> x < y - | CFnlt -> not (x < y) - | CFgt -> x > y - | CFngt -> not (x > y) - | CFle -> x <= y - | CFnle -> not (x <= y) - | CFge -> x >= y - | CFnge -> not (x >= y)) diff --git a/middle_end/simplify_common.mli b/middle_end/simplify_common.mli deleted file mode 100644 index c667bfff..00000000 --- a/middle_end/simplify_common.mli +++ /dev/null @@ -1,80 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** [const_*_expr expr v annot], where the expression [expr] is known to - evaluate to the value [v], attempt to produce a more simple expression - together with its approximation and the benefit gained by replacing [expr] - with this new expression. This simplification is only performed if [expr] - is known to have no side effects. Otherwise, [expr] itself is returned, - with an appropriate approximation but zero benefit. - - [const_boxed_int_expr] takes an additional argument specifying the kind of - boxed integer to which the given expression evaluates. -*) - -val const_int_expr - : Flambda.named - -> int - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_char_expr - : Flambda.named - -> char - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_bool_expr - : Flambda.named - -> bool - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_ptr_expr - : Flambda.named - -> int - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_float_expr - : Flambda.named - -> float - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_boxed_int_expr - : Flambda.named - -> 'a Simple_value_approx.boxed_int - -> 'a - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_integer_comparison_expr - : Flambda.named - -> Lambda.integer_comparison - -> 'a - -> 'a - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_float_comparison_expr - : Flambda.named - -> Lambda.float_comparison - -> float - -> float - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -(** Functions for transposing the order of bytes within words of various - sizes. *) -val swap16 : int -> int -val swap32 : int32 -> int32 -val swap64 : int64 -> int64 -val swapnative : nativeint -> nativeint diff --git a/middle_end/simplify_primitives.ml b/middle_end/simplify_primitives.ml deleted file mode 100644 index a7107f72..00000000 --- a/middle_end/simplify_primitives.ml +++ /dev/null @@ -1,326 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module A = Simple_value_approx -module C = Inlining_cost -module I = Simplify_boxed_integer_ops -module S = Simplify_common - -let phys_equal (approxs:A.t list) = - match approxs with - | [] | [_] | _ :: _ :: _ :: _ -> - Misc.fatal_error "wrong number of arguments for equality" - | [a1; a2] -> - (* N.B. The following would be incorrect if the variables are not - bound in the environment: - match a1.var, a2.var with - | Some v1, Some v2 when Variable.equal v1 v2 -> true - | _ -> ... - *) - match a1.symbol, a2.symbol with - | Some (s1, None), Some (s2, None) -> Symbol.equal s1 s2 - | Some (s1, Some f1), Some (s2, Some f2) -> Symbol.equal s1 s2 && f1 = f2 - | _ -> false - -let is_known_to_be_some_kind_of_int (arg:A.descr) = - match arg with - | Value_int _ | Value_char _ | Value_constptr _ -> true - | Value_block (_, _) | Value_float _ | Value_set_of_closures _ - | Value_closure _ | Value_string _ | Value_float_array _ - | A.Value_boxed_int _ | Value_unknown _ | Value_extern _ - | Value_symbol _ | Value_unresolved _ | Value_bottom -> false - -let is_known_to_be_some_kind_of_block (arg:A.descr) = - match arg with - | Value_block _ | Value_float _ | Value_float_array _ | A.Value_boxed_int _ - | Value_closure _ | Value_string _ -> true - | Value_set_of_closures _ | Value_int _ | Value_char _ | Value_constptr _ - | Value_unknown _ | Value_extern _ | Value_symbol _ - | Value_unresolved _ | Value_bottom -> false - -let rec structurally_different (arg1:A.t) (arg2:A.t) = - match arg1.descr, arg2.descr with - | (Value_int n1 | Value_constptr n1), (Value_int n2 | Value_constptr n2) - when n1 <> n2 -> - true - | Value_block (tag1, fields1), Value_block (tag2, fields2) -> - not (Tag.equal tag1 tag2) - || (Array.length fields1 <> Array.length fields2) - || Misc.Stdlib.Array.exists2 structurally_different fields1 fields2 - | descr1, descr2 -> - (* This is not very precise as this won't allow to distinguish - blocks from strings for instance. This can be improved if it - is deemed valuable. *) - (is_known_to_be_some_kind_of_int descr1 - && is_known_to_be_some_kind_of_block descr2) - || (is_known_to_be_some_kind_of_block descr1 - && is_known_to_be_some_kind_of_int descr2) - -let phys_different (approxs:A.t list) = - match approxs with - | [] | [_] | _ :: _ :: _ :: _ -> - Misc.fatal_error "wrong number of arguments for equality" - | [a1; a2] -> - structurally_different a1 a2 - -let is_empty = function - | [] -> true - | _ :: _ -> false - -let is_pisint = function - | Lambda.Pisint -> true - | _ -> false - -let is_pstring_length = function - | Lambda.Pstringlength -> true - | _ -> false - -let is_pbytes_length = function - | Lambda.Pbyteslength -> true - | _ -> false - -let is_pstringrefs = function - | Lambda.Pstringrefs -> true - | _ -> false - -let is_pbytesrefs = function - | Lambda.Pbytesrefs -> true - | _ -> false - -let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int - ~big_endian : Flambda.named * A.t * Inlining_cost.Benefit.t = - let fpc = !Clflags.float_const_prop in - match p with - | Pmakeblock(tag_int, Asttypes.Immutable, shape) -> - let tag = Tag.create_exn tag_int in - let shape = match shape with - | None -> List.map (fun _ -> Lambda.Pgenval) args - | Some shape -> shape - in - let approxs = List.map2 A.augment_with_kind approxs shape in - let shape = List.map2 A.augment_kind_with_approx approxs shape in - Prim (Pmakeblock(tag_int, Asttypes.Immutable, Some shape), args, dbg), - A.value_block tag (Array.of_list approxs), C.Benefit.zero - | Praise _ -> - expr, A.value_bottom, C.Benefit.zero - | Pignore -> begin - match args, A.descrs approxs with - | [arg], [(Value_int 0 | Value_constptr 0)] -> - S.const_ptr_expr (Flambda.Expr (Var arg)) 0 - | _ -> S.const_ptr_expr expr 0 - end - | Pmakearray(_, _) when is_empty approxs -> - Prim (Pmakeblock(0, Asttypes.Immutable, Some []), [], dbg), - A.value_block (Tag.create_exn 0) [||], C.Benefit.zero - | Pmakearray (Pfloatarray, Mutable) -> - let approx = - A.value_mutable_float_array ~size:(List.length args) - in - expr, approx, C.Benefit.zero - | Pmakearray (Pfloatarray, Immutable) -> - let approx = - A.value_immutable_float_array (Array.of_list approxs) - in - expr, approx, C.Benefit.zero - | Pintcomp Ceq when phys_equal approxs -> - S.const_bool_expr expr true - | Pintcomp Cne when phys_equal approxs -> - S.const_bool_expr expr false - (* N.B. Having [not (phys_equal approxs)] would not on its own tell us - anything about whether the two values concerned are unequal. To judge - that, it would be necessary to prove that the approximations are - different, which would in turn entail them being completely known. - - It may seem that in the case where we have two approximations each - annotated with a symbol that we should be able to judge inequality - even if part of the approximation description(s) are unknown. This is - unfortunately not the case. Here is an example: - - let a = f 1 - let b = f 1 - let c = a, a - let d = a, a - - If [Share_constants] is run before [f] is completely inlined (assuming - [f] always generates the same result; effects of [f] aren't in fact - relevant) then [c] and [d] will not be shared. However if [f] is - inlined later, [a] and [b] could be shared and thus [c] and [d] could - be too. As such, any intermediate non-aliasing judgement would be - invalid. *) - | Pintcomp Ceq when phys_different approxs -> - S.const_bool_expr expr false - | Pintcomp Cne when phys_different approxs -> - S.const_bool_expr expr true - (* If two values are structurally different we are certain they can never - be shared*) - | _ -> - match A.descrs approxs with - | [Value_int x] -> - begin match p with - | Pidentity -> S.const_int_expr expr x - | Pnot -> S.const_bool_expr expr (x = 0) - | Pnegint -> S.const_int_expr expr (-x) - | Pbswap16 -> S.const_int_expr expr (S.swap16 x) - | Poffsetint y -> S.const_int_expr expr (x + y) - | Pfloatofint when fpc -> S.const_float_expr expr (float_of_int x) - | Pbintofint Pnativeint -> - S.const_boxed_int_expr expr Nativeint (Nativeint.of_int x) - | Pbintofint Pint32 -> S.const_boxed_int_expr expr Int32 (Int32.of_int x) - | Pbintofint Pint64 -> S.const_boxed_int_expr expr Int64 (Int64.of_int x) - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [(Value_int x | Value_constptr x); (Value_int y | Value_constptr y)] -> - let shift_precond = 0 <= y && y < 8 * size_int in - begin match p with - | Paddint -> S.const_int_expr expr (x + y) - | Psubint -> S.const_int_expr expr (x - y) - | Pmulint -> S.const_int_expr expr (x * y) - | Pdivint _ when y <> 0 -> S.const_int_expr expr (x / y) - | Pmodint _ when y <> 0 -> S.const_int_expr expr (x mod y) - | Pandint -> S.const_int_expr expr (x land y) - | Porint -> S.const_int_expr expr (x lor y) - | Pxorint -> S.const_int_expr expr (x lxor y) - | Plslint when shift_precond -> S.const_int_expr expr (x lsl y) - | Plsrint when shift_precond -> S.const_int_expr expr (x lsr y) - | Pasrint when shift_precond -> S.const_int_expr expr (x asr y) - | Pintcomp cmp -> S.const_integer_comparison_expr expr cmp x y - | Pisout -> S.const_bool_expr expr (y > x || y < 0) - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [Value_char x; Value_char y] -> - begin match p with - | Pintcomp cmp -> S.const_integer_comparison_expr expr cmp x y - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [Value_constptr x] -> - begin match p with - (* [Pidentity] should probably never appear, but is here for - completeness. *) - | Pidentity -> S.const_ptr_expr expr x - | Pnot -> S.const_bool_expr expr (x = 0) - | Pisint -> S.const_bool_expr expr true - | Poffsetint y -> S.const_ptr_expr expr (x + y) - | Pctconst c -> - begin match c with - | Big_endian -> S.const_bool_expr expr big_endian - | Word_size -> S.const_int_expr expr (8*size_int) - | Int_size -> S.const_int_expr expr (8*size_int - 1) - | Max_wosize -> - (* CR-someday mshinwell: this function should maybe not live here. *) - S.const_int_expr expr ((1 lsl ((8*size_int) - 10)) - 1) - | Ostype_unix -> - S.const_bool_expr expr (String.equal Sys.os_type "Unix") - | Ostype_win32 -> - S.const_bool_expr expr (String.equal Sys.os_type "Win32") - | Ostype_cygwin -> - S.const_bool_expr expr (String.equal Sys.os_type "Cygwin") - | Backend_type -> - S.const_ptr_expr expr 0 (* tag 0 is the same as Native *) - end - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [Value_float (Some x)] when fpc -> - begin match p with - | Pintoffloat -> S.const_int_expr expr (int_of_float x) - | Pnegfloat -> S.const_float_expr expr (-. x) - | Pabsfloat -> S.const_float_expr expr (abs_float x) - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [Value_float (Some n1); Value_float (Some n2)] when fpc -> - begin match p with - | Paddfloat -> S.const_float_expr expr (n1 +. n2) - | Psubfloat -> S.const_float_expr expr (n1 -. n2) - | Pmulfloat -> S.const_float_expr expr (n1 *. n2) - | Pdivfloat -> S.const_float_expr expr (n1 /. n2) - | Pfloatcomp c -> S.const_float_comparison_expr expr c n1 n2 - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [A.Value_boxed_int(A.Nativeint, n)] -> - I.Simplify_boxed_nativeint.simplify_unop p Nativeint expr n - | [A.Value_boxed_int(A.Int32, n)] -> - I.Simplify_boxed_int32.simplify_unop p Int32 expr n - | [A.Value_boxed_int(A.Int64, n)] -> - I.Simplify_boxed_int64.simplify_unop p Int64 expr n - | [A.Value_boxed_int(A.Nativeint, n1); - A.Value_boxed_int(A.Nativeint, n2)] -> - I.Simplify_boxed_nativeint.simplify_binop p Nativeint expr n1 n2 - | [A.Value_boxed_int(A.Int32, n1); A.Value_boxed_int(A.Int32, n2)] -> - I.Simplify_boxed_int32.simplify_binop p Int32 expr n1 n2 - | [A.Value_boxed_int(A.Int64, n1); A.Value_boxed_int(A.Int64, n2)] -> - I.Simplify_boxed_int64.simplify_binop p Int64 expr n1 n2 - | [A.Value_boxed_int(A.Nativeint, n1); Value_int n2] -> - I.Simplify_boxed_nativeint.simplify_binop_int p Nativeint expr n1 n2 - ~size_int - | [A.Value_boxed_int(A.Int32, n1); Value_int n2] -> - I.Simplify_boxed_int32.simplify_binop_int p Int32 expr n1 n2 - ~size_int - | [A.Value_boxed_int(A.Int64, n1); Value_int n2] -> - I.Simplify_boxed_int64.simplify_binop_int p Int64 expr n1 n2 - ~size_int - | [Value_block _] when is_pisint p -> - S.const_bool_expr expr false - | [Value_string { size }] - when (is_pstring_length p || is_pbytes_length p) -> - S.const_int_expr expr size - | [Value_string { size; contents = Some s }; - (Value_int x | Value_constptr x)] when x >= 0 && x < size -> - begin match p with - | Pstringrefu - | Pstringrefs - | Pbytesrefu - | Pbytesrefs -> - S.const_char_expr (Prim(Pstringrefu, args, dbg)) s.[x] - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [Value_string { size; contents = None }; - (Value_int x | Value_constptr x)] - when x >= 0 && x < size && is_pstringrefs p -> - Flambda.Prim (Pstringrefu, args, dbg), - A.value_unknown Other, - (* we improved it, but there is no way to account for that: *) - C.Benefit.zero - | [Value_string { size; contents = None }; - (Value_int x | Value_constptr x)] - when x >= 0 && x < size && is_pbytesrefs p -> - Flambda.Prim (Pbytesrefu, args, dbg), - A.value_unknown Other, - (* we improved it, but there is no way to account for that: *) - C.Benefit.zero - - | [Value_float_array { size; contents }] -> - begin match p with - | Parraylength _ -> S.const_int_expr expr size - | Pfloatfield i -> - begin match contents with - | A.Contents a when i >= 0 && i < size -> - begin match A.check_approx_for_float a.(i) with - | None -> expr, a.(i), C.Benefit.zero - | Some v -> S.const_float_expr expr v - end - | Contents _ | Unknown_or_mutable -> - expr, A.value_unknown Other, C.Benefit.zero - end - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | _ -> - match Semantics_of_primitives.return_type_of_primitive p with - | Float -> - expr, A.value_any_float, C.Benefit.zero - | Other -> - expr, A.value_unknown Other, C.Benefit.zero diff --git a/middle_end/simplify_primitives.mli b/middle_end/simplify_primitives.mli deleted file mode 100644 index 7f1f149b..00000000 --- a/middle_end/simplify_primitives.mli +++ /dev/null @@ -1,28 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Simplifies an application of a primitive based on approximation - information. *) -val primitive - : Lambda.primitive - -> (Variable.t list * (Simple_value_approx.t list)) - -> Flambda.named - -> Debuginfo.t - -> size_int:int - -> big_endian:bool - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t diff --git a/middle_end/symbol.ml b/middle_end/symbol.ml new file mode 100644 index 00000000..22a2e0a7 --- /dev/null +++ b/middle_end/symbol.ml @@ -0,0 +1,105 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + + +type t = + | Linkage of + { compilation_unit : Compilation_unit.t; + label : Linkage_name.t; + hash : int; } + | Variable of + { compilation_unit : Compilation_unit.t; + variable : Variable.t; } + +let label t = + match t with + | Linkage { label; _ } -> label + | Variable { variable; _ } -> + (* Use the variable's compilation unit for the label, since the + symbol's compilation unit might be a pack *) + let compilation_unit = Variable.get_compilation_unit variable in + let unit_linkage_name = + Linkage_name.to_string + (Compilation_unit.get_linkage_name compilation_unit) + in + let label = unit_linkage_name ^ "__" ^ Variable.unique_name variable in + Linkage_name.create label + +include Identifiable.Make (struct + + type nonrec t = t + + let compare t1 t2 = + if t1 == t2 then 0 + else begin + match t1, t2 with + | Linkage _, Variable _ -> 1 + | Variable _, Linkage _ -> -1 + | Linkage l1, Linkage l2 -> + let c = compare l1.hash l2.hash in + if c <> 0 then c else begin + (* Linkage names are unique across a whole project, so just comparing + those is sufficient. *) + Linkage_name.compare l1.label l2.label + end + | Variable v1, Variable v2 -> + Variable.compare v1.variable v2.variable + end + + let equal x y = + if x == y then true + else compare x y = 0 + + let output chan t = + Linkage_name.output chan (label t) + + let hash t = + match t with + | Linkage { hash; _ } -> hash + | Variable { variable } -> Variable.hash variable + + let print ppf t = + Linkage_name.print ppf (label t) + +end) + +let of_global_linkage compilation_unit label = + let hash = Linkage_name.hash label in + Linkage { compilation_unit; hash; label } + +let of_variable variable = + let compilation_unit = Variable.get_compilation_unit variable in + Variable { variable; compilation_unit } + +let import_for_pack ~pack:compilation_unit symbol = + match symbol with + | Linkage l -> Linkage { l with compilation_unit } + | Variable v -> Variable { v with compilation_unit } + +let compilation_unit t = + match t with + | Linkage { compilation_unit; _ } -> compilation_unit + | Variable { compilation_unit; _ } -> compilation_unit + +let print_opt ppf = function + | None -> Format.fprintf ppf "" + | Some t -> print ppf t + +let compare_lists l1 l2 = + Misc.Stdlib.List.compare compare l1 l2 diff --git a/middle_end/symbol.mli b/middle_end/symbol.mli new file mode 100644 index 00000000..d2771af2 --- /dev/null +++ b/middle_end/symbol.mli @@ -0,0 +1,44 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** A symbol identifies a constant provided by either: + - another compilation unit; or + - a top-level module. + + * [sym_unit] is the compilation unit containing the value. + * [sym_label] is the linkage name of the variable. + + The label must be globally unique: two compilation units linked in the + same program must not share labels. *) + +include Identifiable.S + +val of_variable : Variable.t -> t + +(* Create the symbol without prefixing with the compilation unit. + Used for global symbols like predefined exceptions *) +val of_global_linkage : Compilation_unit.t -> Linkage_name.t -> t + +val import_for_pack : pack:Compilation_unit.t -> t -> t + +val compilation_unit : t -> Compilation_unit.t +val label : t -> Linkage_name.t + +val print_opt : Format.formatter -> t option -> unit + +val compare_lists : t list -> t list -> int diff --git a/middle_end/unbox_closures.ml b/middle_end/unbox_closures.ml deleted file mode 100644 index 5c86bed3..00000000 --- a/middle_end/unbox_closures.ml +++ /dev/null @@ -1,87 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module ASA = Augment_specialised_args -module W = ASA.What_to_specialise -module E = Inline_and_simplify_aux.Env - -module Transform = struct - let pass_name = "unbox-closures" - - let precondition ~env ~(set_of_closures : Flambda.set_of_closures) = - !Clflags.unbox_closures - && not (E.at_toplevel env) - && not (Variable.Map.is_empty set_of_closures.free_vars) - - let what_to_specialise ~env ~(set_of_closures : Flambda.set_of_closures) = - let what_to_specialise = W.create ~set_of_closures in - if not (precondition ~env ~set_of_closures) then - what_to_specialise - else begin - let round = E.round env in - let num_closure_vars = Variable.Map.cardinal set_of_closures.free_vars in - let module B = Inlining_cost.Benefit in - let saved_by_not_building_closure = - (* For the moment assume that we're going to cause all functions in the - set to become closed. *) - B.remove_prims (B.remove_call B.zero) num_closure_vars - in - Flambda_iterators.fold_function_decls_ignoring_stubs set_of_closures - ~init:what_to_specialise - ~f:(fun ~fun_var ~(function_decl : Flambda.function_declaration) - what_to_specialise -> - let body_size = Inlining_cost.lambda_size function_decl.body in - (* If the function is small enough, make a direct call surrogate - for it, so that indirect calls are not penalised by having to - bounce through the stub. (Making such a surrogate involves - duplicating the function.) *) - let small_enough_to_duplicate = - let module W = Inlining_cost.Whether_sufficient_benefit in - let wsb = - W.create_estimate ~original_size:0 - ~toplevel:false - ~branch_depth:0 - ~new_size:((body_size / !Clflags.unbox_closures_factor) + 1) - ~benefit:saved_by_not_building_closure - ~lifting:false - ~round - in - W.evaluate wsb - in - let what_to_specialise = - if small_enough_to_duplicate then - W.make_direct_call_surrogate_for what_to_specialise ~fun_var - else - what_to_specialise - in - let bound_by_the_closure = - Flambda_utils.variables_bound_by_the_closure - (Closure_id.wrap fun_var) - set_of_closures.function_decls - in - Variable.Set.fold (fun inner_free_var what_to_specialise -> - W.new_specialised_arg what_to_specialise - ~fun_var ~group:inner_free_var - ~definition:(Existing_inner_free_var inner_free_var)) - bound_by_the_closure - what_to_specialise) - end -end - -include ASA.Make (Transform) diff --git a/middle_end/unbox_closures.mli b/middle_end/unbox_closures.mli deleted file mode 100644 index fb935a62..00000000 --- a/middle_end/unbox_closures.mli +++ /dev/null @@ -1,33 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Turn free variables of closures into specialised arguments. - The aim is to cause the closure to become closed. *) - -val rewrite_set_of_closures - : env:Inline_and_simplify_aux.Env.t - (* CR-soon mshinwell: eliminate superfluous parameter *) - -> duplicate_function:( - env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> fun_var:Variable.t - -> new_fun_var:Variable.t - -> Flambda.function_declaration - * Flambda.specialised_to Variable.Map.t) - -> set_of_closures:Flambda.set_of_closures - -> (Flambda.expr * Inlining_cost.Benefit.t) option diff --git a/middle_end/unbox_free_vars_of_closures.ml b/middle_end/unbox_free_vars_of_closures.ml deleted file mode 100644 index 7a4e48ed..00000000 --- a/middle_end/unbox_free_vars_of_closures.ml +++ /dev/null @@ -1,170 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module B = Inlining_cost.Benefit - -let pass_name = "unbox-free-vars-of-closures" -let () = Pass_wrapper.register ~pass_name - -(* CR-someday mshinwell: Nearly but not quite the same as something that - Augment_specialised_args uses. *) -let add_lifted_projections_around_set_of_closures - ~set_of_closures ~existing_inner_to_outer_vars ~benefit - ~definitions_indexed_by_new_inner_vars = - let body = - Flambda_utils.name_expr (Set_of_closures set_of_closures) - ~name:Internal_variable_names.unbox_free_vars_of_closures - in - Variable.Map.fold (fun new_inner_var (projection : Projection.t) - (expr, benefit) -> - let find_outer_var inner_var = - match - Variable.Map.find inner_var existing_inner_to_outer_vars - with - | (outer_var : Flambda.specialised_to) -> outer_var.var - | exception Not_found -> - Misc.fatal_errorf "(UFV) find_outer_var: expected %a \ - to be in [existing_inner_to_outer_vars], but it is \ - not. (The projection was: %a)" - Variable.print inner_var - Projection.print projection - in - let benefit = B.add_projection projection benefit in - let named : Flambda.named = - (* The lifted projection must be in terms of outer variables, - not inner variables. *) - let projection = - Projection.map_projecting_from projection ~f:find_outer_var - in - Flambda_utils.projection_to_named projection - in - let expr = - Flambda.create_let (find_outer_var new_inner_var) named expr - in - (expr, benefit)) - definitions_indexed_by_new_inner_vars - (body, benefit) - -let run ~env ~(set_of_closures : Flambda.set_of_closures) = - if not !Clflags.unbox_free_vars_of_closures then - None - else - let definitions_indexed_by_new_inner_vars, _, free_vars, done_something = - let all_existing_definitions = - Variable.Map.fold (fun _inner_var (outer_var : Flambda.specialised_to) - all_existing_definitions -> - match outer_var.projection with - | None -> all_existing_definitions - | Some projection -> - Projection.Set.add projection all_existing_definitions) - set_of_closures.free_vars - Projection.Set.empty - in - Flambda_iterators.fold_function_decls_ignoring_stubs set_of_closures - ~init:(Variable.Map.empty, all_existing_definitions, - set_of_closures.free_vars, false) - ~f:(fun ~fun_var:_ ~function_decl result -> - let extracted = - Extract_projections.from_function_decl ~env ~function_decl - ~which_variables:set_of_closures.free_vars - in - Projection.Set.fold (fun projection - ((definitions_indexed_by_new_inner_vars, - all_existing_definitions_including_added_ones, - additional_free_vars, _done_something) as result) -> - (* Don't add a new free variable if there already exists a - free variable with the desired projection. We need to - dedup not only across the existing free variables but - also across newly-added ones (unlike in - [Augment_specialised_args]), since free variables are - not local to a function declaration but rather to a - set of closures. *) - if Projection.Set.mem projection - all_existing_definitions_including_added_ones - then begin - result - end else begin - (* Add a new free variable. This needs both a fresh - "new inner" and a fresh "new outer" var, since we know - the definition is not a duplicate. *) - let projecting_from = Projection.projecting_from projection in - let new_inner_var = Variable.rename projecting_from in - let new_outer_var = Variable.rename projecting_from in - let definitions_indexed_by_new_inner_vars = - Variable.Map.add new_inner_var projection - definitions_indexed_by_new_inner_vars - in - let all_existing_definitions_including_added_ones = - Projection.Set.add projection - all_existing_definitions_including_added_ones - in - let new_outer_var : Flambda.specialised_to = - { var = new_outer_var; - projection = Some projection; - } - in - let additional_free_vars = - Variable.Map.add new_inner_var new_outer_var - additional_free_vars - in - definitions_indexed_by_new_inner_vars, - all_existing_definitions_including_added_ones, - additional_free_vars, - true - end) - extracted - result) - in - if not done_something then - None - else - (* CR-someday mshinwell: could consider doing the grouping thing - similar to Augment_specialised_args *) - let num_free_vars_before = - Variable.Map.cardinal set_of_closures.free_vars - in - let num_free_vars_after = - Variable.Map.cardinal free_vars - in - assert (num_free_vars_after > num_free_vars_before); - (* Don't let the closure grow too large. *) - if num_free_vars_after > 2 * num_free_vars_before then - None - else - let set_of_closures = - Flambda.create_set_of_closures - ~function_decls:set_of_closures.function_decls - ~free_vars - ~specialised_args:set_of_closures.specialised_args - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - let expr, benefit = - add_lifted_projections_around_set_of_closures ~set_of_closures - ~benefit:B.zero - ~existing_inner_to_outer_vars:set_of_closures.free_vars - ~definitions_indexed_by_new_inner_vars - in - Some (expr, benefit) - -let run ~env ~set_of_closures = - Pass_wrapper.with_dump ~ppf_dump:(Inline_and_simplify_aux.Env.ppf_dump env) - ~pass_name ~input:set_of_closures - ~print_input:Flambda.print_set_of_closures - ~print_output:(fun ppf (expr, _) -> Flambda.print ppf expr) - ~f:(fun () -> run ~env ~set_of_closures) diff --git a/middle_end/unbox_free_vars_of_closures.mli b/middle_end/unbox_free_vars_of_closures.mli deleted file mode 100644 index 3ee181ee..00000000 --- a/middle_end/unbox_free_vars_of_closures.mli +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** When approximations of free variables of closures indicate that they - are closures or blocks, rewrite projections from such blocks to new - variables (which become free in the closures), with the defining - expressions of the projections lifted out of the corresponding sets - of closures. *) - -val run - : env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> (Flambda.expr * Inlining_cost.Benefit.t) option diff --git a/middle_end/unbox_specialised_args.ml b/middle_end/unbox_specialised_args.ml deleted file mode 100755 index 70eb8760..00000000 --- a/middle_end/unbox_specialised_args.ml +++ /dev/null @@ -1,103 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module ASA = Augment_specialised_args -module W = ASA.What_to_specialise - -module Transform = struct - let pass_name = "unbox-specialised-args" - - let precondition ~env:_ ~(set_of_closures : Flambda.set_of_closures) = - !Clflags.unbox_specialised_args - && not (Variable.Map.is_empty set_of_closures.specialised_args) - - let what_to_specialise ~env ~(set_of_closures : Flambda.set_of_closures) = - let what_to_specialise = W.create ~set_of_closures in - if not (precondition ~env ~set_of_closures) then - what_to_specialise - else - let projections_by_function = - Variable.Map.filter_map set_of_closures.function_decls.funs - ~f:(fun _fun_var (function_decl : Flambda.function_declaration) -> - if function_decl.stub then None - else - Some (Extract_projections.from_function_decl ~env - ~function_decl - ~which_variables:set_of_closures.specialised_args)) - in - (* CR-soon mshinwell: consider caching the Invariant_params *relation* - as well as the "_in_recursion" map *) - let invariant_params_flow = - Invariant_params.invariant_param_sources set_of_closures.function_decls - ~backend:(Inline_and_simplify_aux.Env.backend env) - in - Variable.Map.fold (fun fun_var extractions what_to_specialise -> - Projection.Set.fold (fun (projection : Projection.t) - what_to_specialise -> - let group = Projection.projecting_from projection in - assert (Variable.Map.mem group set_of_closures.specialised_args); - let what_to_specialise = - W.new_specialised_arg what_to_specialise ~fun_var ~group - ~definition:(Projection_from_existing_specialised_arg - projection) - in - match Variable.Map.find group invariant_params_flow with - | exception Not_found -> what_to_specialise - | flow -> - (* If for function [f] we would extract a projection expression - [e] from some specialised argument [x] of [f], and we know - from [Invariant_params] that a specialised argument [y] of - another function [g] flows to [x], we will add [e] with - [y] substituted for [x] throughout as a newly-specialised - argument for [g]. This should help reduce the number of - simplification rounds required for mutually-recursive - functions. *) - Variable.Pair.Set.fold (fun (target_fun_var, target_spec_arg) - what_to_specialise -> - if Variable.equal fun_var target_fun_var - || not (Variable.Map.mem target_spec_arg - set_of_closures.specialised_args) - then begin - what_to_specialise - end else begin - (* Rewrite the projection (that was in terms of an inner - specialised arg of [fun_var]) to be in terms of the - corresponding inner specialised arg of - [target_fun_var]. (The outer vars referenced in the - projection remain unchanged.) *) - let projection = - Projection.map_projecting_from projection - ~f:(fun var -> - assert (Variable.equal var group); - target_spec_arg) - in - W.new_specialised_arg what_to_specialise - ~fun_var:target_fun_var ~group - ~definition: - (Projection_from_existing_specialised_arg projection) - end) - flow - what_to_specialise) - extractions - what_to_specialise) - projections_by_function - what_to_specialise -end - -include ASA.Make (Transform) diff --git a/middle_end/unbox_specialised_args.mli b/middle_end/unbox_specialised_args.mli deleted file mode 100644 index f0191764..00000000 --- a/middle_end/unbox_specialised_args.mli +++ /dev/null @@ -1,50 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** When approximations of specialised arguments indicate that they are - closures or blocks, add more specialised arguments corresponding to - the projections from such blocks (with definitions of such projections - lifted out), such that the original specialised arguments may later be - eliminated. - - This in particular enables elimination of closure allocations in - examples such as: - - let rec map f = function - | [] -> [] - | a::l -> let r = f a in r :: map f l - - let g x = - map (fun y -> x + y) [1; 2; 3; 4] - - Here, the specialised version of [map] initially has a specialised - argument [f]; and upon inlining there will be a projection of [x] from - the closure of [f]. This pass adds a new specialised argument to carry - that projection, at which point the closure of [f] is redundant. -*) - -val rewrite_set_of_closures - : env:Inline_and_simplify_aux.Env.t - (* CR-soon mshinwell: eliminate superfluous parameter *) - -> duplicate_function:( - env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> fun_var:Variable.t - -> new_fun_var:Variable.t - -> Flambda.function_declaration - * Flambda.specialised_to Variable.Map.t) - -> set_of_closures:Flambda.set_of_closures - -> (Flambda.expr * Inlining_cost.Benefit.t) option diff --git a/middle_end/variable.ml b/middle_end/variable.ml new file mode 100644 index 00000000..64099a73 --- /dev/null +++ b/middle_end/variable.ml @@ -0,0 +1,119 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type t = { + compilation_unit : Compilation_unit.t; + name : string; + name_stamp : int; + (** [name_stamp]s are unique within any given compilation unit. *) +} + +include Identifiable.Make (struct + type nonrec t = t + + let compare t1 t2 = + if t1 == t2 then 0 + else + let c = t1.name_stamp - t2.name_stamp in + if c <> 0 then c + else Compilation_unit.compare t1.compilation_unit t2.compilation_unit + + let equal t1 t2 = + if t1 == t2 then true + else + t1.name_stamp = t2.name_stamp + && Compilation_unit.equal t1.compilation_unit t2.compilation_unit + + let output chan t = + output_string chan t.name; + output_string chan "_"; + output_string chan (Int.to_string t.name_stamp) + + let hash t = t.name_stamp lxor (Compilation_unit.hash t.compilation_unit) + + let print ppf t = + if Compilation_unit.equal t.compilation_unit + (Compilation_unit.get_current_exn ()) + then begin + Format.fprintf ppf "%s/%d" + t.name t.name_stamp + end else begin + Format.fprintf ppf "%a.%s/%d" + Compilation_unit.print t.compilation_unit + t.name t.name_stamp + end +end) + +let previous_name_stamp = ref (-1) + +let create_with_name_string ?current_compilation_unit name = + let compilation_unit = + match current_compilation_unit with + | Some compilation_unit -> compilation_unit + | None -> Compilation_unit.get_current_exn () + in + let name_stamp = + incr previous_name_stamp; + !previous_name_stamp + in + { compilation_unit; + name; + name_stamp; + } + +let create ?current_compilation_unit name = + let name = (name : Internal_variable_names.t :> string) in + create_with_name_string ?current_compilation_unit name + +let create_with_same_name_as_ident ident = + create_with_name_string (Ident.name ident) + +let rename ?current_compilation_unit t = + create_with_name_string ?current_compilation_unit t.name + +let in_compilation_unit t cu = + Compilation_unit.equal cu t.compilation_unit + +let get_compilation_unit t = t.compilation_unit + +let name t = t.name + +let unique_name t = + t.name ^ "_" ^ (Int.to_string t.name_stamp) + +let print_list ppf ts = + List.iter (fun t -> Format.fprintf ppf "@ %a" print t) ts + +let debug_when_stamp_matches t ~stamp ~f = + if t.name_stamp = stamp then f () + +let print_opt ppf = function + | None -> Format.fprintf ppf "" + | Some t -> print ppf t + +type pair = t * t +module Pair = Identifiable.Make (Identifiable.Pair (T) (T)) + +let compare_lists l1 l2 = + Misc.Stdlib.List.compare compare l1 l2 + +let output_full chan t = + Compilation_unit.output chan t.compilation_unit; + output_string chan "."; + output chan t diff --git a/middle_end/variable.mli b/middle_end/variable.mli new file mode 100644 index 00000000..b5d3f136 --- /dev/null +++ b/middle_end/variable.mli @@ -0,0 +1,63 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** [Variable.t] is the equivalent of a non-persistent [Ident.t] in + the [Flambda] tree. It wraps an [Ident.t] together with its source + [compilation_unit]. As such, it is unique within a whole program, + not just one compilation unit. + + Introducing a new type helps in tracing the source of identifiers + when debugging the inliner. It also avoids Ident renaming when + importing cmx files. +*) + +include Identifiable.S + +val create + : ?current_compilation_unit:Compilation_unit.t + -> Internal_variable_names.t + -> t +val create_with_same_name_as_ident : Ident.t -> t + +val rename + : ?current_compilation_unit:Compilation_unit.t + -> t + -> t + +val in_compilation_unit : t -> Compilation_unit.t -> bool + +val name : t -> string + +val unique_name : t -> string + +val get_compilation_unit : t -> Compilation_unit.t + +val print_list : Format.formatter -> t list -> unit +val print_opt : Format.formatter -> t option -> unit + +(** If the given variable has the given stamp, call the user-supplied + function. For debugging purposes only. *) +val debug_when_stamp_matches : t -> stamp:int -> f:(unit -> unit) -> unit + +type pair = t * t +module Pair : Identifiable.S with type t := pair + +val compare_lists : t list -> t list -> int + +val output_full : out_channel -> t -> unit +(** Unlike [output], [output_full] includes the compilation unit. *) diff --git a/ocaml-variants.opam b/ocaml-variants.opam index 96b04ba3..30d48eb2 100644 --- a/ocaml-variants.opam +++ b/ocaml-variants.opam @@ -1,8 +1,8 @@ opam-version: "2.0" -version: "4.08.1" -synopsis: "OCaml release 4.08.1" +version: "4.09.0" +synopsis: "OCaml development version" depends: [ - "ocaml" {= "4.08.1" & post} + "ocaml" {= "4.09.0" & post} "base-unix" {post} "base-bigarray" {post} "base-threads" {post} diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index f8b8cf63..6710176b 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -97,8 +97,8 @@ INCLUDES_NODEP=\ -I $(ROOTDIR)/compilerlibs \ -I $(ROOTDIR)/otherlibs/str \ -I $(ROOTDIR)/otherlibs/dynlink \ - -I $(ROOTDIR)/otherlibs/$(UNIXLIB) \ - -I $(ROOTDIR)/otherlibs/$(GRAPHLIB) + -I $(ROOTDIR)/otherlibs/dynlink/native \ + -I $(ROOTDIR)/otherlibs/$(UNIXLIB) DEPINCLUDES=$(INCLUDES_DEP) INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) @@ -201,7 +201,7 @@ generatorsopt: $(GENERATORS_CMXS) debug: $(MAKE) OCAMLPP="" -OCAMLDOC_LIBRARIES = unix str dynlink ocamlcommon +OCAMLDOC_LIBRARIES = ocamlcommon unix str dynlink OCAMLDOC_BCLIBRARIES = $(OCAMLDOC_LIBRARIES:%=%.cma) OCAMLDOC_NCLIBRARIES = $(OCAMLDOC_LIBRARIES:%=%.cmxa) @@ -495,7 +495,7 @@ odoc: .PHONY: clean clean: - rm -f *~ \#*\# + rm -f \#*\# rm -f $(OCAMLDOC) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.cmt *.cmti *.$(A) *.$(O) rm -f odoc_parser.output odoc_text_parser.output rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml diff --git a/ocamldoc/Makefile.docfiles b/ocamldoc/Makefile.docfiles index fdeb7bf1..9b027426 100644 --- a/ocamldoc/Makefile.docfiles +++ b/ocamldoc/Makefile.docfiles @@ -13,17 +13,14 @@ #************************************************************************** # Define the lists of mli file used by ocamldoc to generate the stdlib -# + otherlibs + compilerlibs + plugin hooks documentation +# + otherlibs + compilerlibs documentation include $(SRC)/Makefile.config include $(SRC)/stdlib/StdlibModules PARSING_MLIS := $(wildcard $(SRC)/parsing/*.mli) UTILS_MLIS := $(wildcard $(SRC)/utils/*.mli) -TYPING_MLIS := $(SRC)/typing/typemod.mli -BYTECOMP_MLIS := $(SRC)/bytecomp/simplif.mli STR_MLIS = $(addprefix $(SRC)/otherlibs/str/, str.mli) UNIX_MLIS = $(addprefix $(SRC)/otherlibs/unix/, unix.mli unixLabels.mli) -GRAPHICS_MLIS = $(addprefix $(SRC)/otherlibs/graph/, graphics.mli graphicsX11.mli) DYNLINK_MLIS = $(addprefix $(SRC)/otherlibs/dynlink/, dynlink.mli) THREAD_MLIS = $(addprefix $(SRC)/otherlibs/systhreads/, \ thread.mli condition.mli mutex.mli event.mli threadUnix.mli) @@ -32,10 +29,10 @@ DRIVER_MLIS = $(SRC)/driver/pparse.mli DOC_STDLIB_DIRS = stdlib \ otherlibs/str \ - otherlibs/$(UNIXLIB) otherlibs/graphics otherlibs/dynlink \ + otherlibs/$(UNIXLIB) otherlibs/dynlink \ otherlibs/systhreads -DOC_COMPILERLIBS_DIRS= parsing utils typing bytecomp driver +DOC_COMPILERLIBS_DIRS= parsing utils typing bytecomp driver file_formats lambda DOC_ALL_DIRS = $(DOC_COMPILERLIBS) $(DOC_STDLIB_DIRS) @@ -53,14 +50,11 @@ STDLIB_MLIS=\ $(STR_MLIS) \ $(UNIX_MLIS) \ $(THREAD_MLIS) \ - $(GRAPHICS_MLIS) \ $(DYNLINK_MLIS) COMPILERLIBS_MLIS=\ $(PARSING_MLIS) \ $(UTILS_MLIS) \ - $(TYPING_MLIS) \ - $(BYTECOMP_MLIS) \ $(DRIVER_MLIS) DOC_STDLIB_TEXT = $(SRC)/stdlib/ocaml_operators.mld diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 8cae70af..ab29fe7b 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -26,7 +26,7 @@ open Typedtree The current directory is always searched first, then the directories specified with the -I option (in command-line order), then the standard library directory. *) -let init_path () = Compmisc.init_path false +let init_path () = Compmisc.init_path () (** Return the initial environment in which compilation proceeds. *) let initial_env () = @@ -113,7 +113,7 @@ let process_interface_file sourcefile = Pparse.file ~tool_name inputfile (no_docstring Parse.interface) Pparse.Signature in - let sg = Typemod.type_interface sourcefile (initial_env()) ast in + let sg = Typemod.type_interface (initial_env()) ast in Warnings.check_fatal (); (ast, sg, inputfile) diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml index ff86aa6d..dd1c448f 100644 --- a/ocamldoc/odoc_args.ml +++ b/ocamldoc/odoc_args.ml @@ -227,7 +227,7 @@ module Options = Main_args.Make_ocamldoc_options(struct let _strict_formats = set Clflags.strict_formats let _no_strict_formats = unset Clflags.strict_formats let _thread = set Clflags.use_threads - let _vmthread = set Clflags.use_vmthreads + let _vmthread = ignore let _unboxed_types = set Clflags.unboxed_types let _no_unboxed_types = unset Clflags.unboxed_types let _unsafe () = assert false diff --git a/ocamltest/Makefile b/ocamltest/Makefile index f226e550..1c0067aa 100644 --- a/ocamltest/Makefile +++ b/ocamltest/Makefile @@ -168,7 +168,7 @@ bytecode_modules := $(o_files) $(cmo_files) native_modules := $(o_files) $(cmx_files) directories := $(addprefix $(ROOTDIR)/,utils bytecomp parsing stdlib \ - compilerlibs) + compilerlibs file_formats) include_directories := $(addprefix -I , $(directories)) @@ -192,6 +192,8 @@ ocamlcdefaultflags := ocamloptdefaultflags := $(shell ./getocamloptdefaultflags $(TARGET)) +.SECONDARY: $(lexers:.mll=.ml) $(parsers:.mly=.mli) $(parsers:.mly=.ml) + .PHONY: all allopt opt.opt # allopt and opt.opt are synonyms all: ocamltest$(EXE) allopt: ocamltest.opt$(EXE) diff --git a/ocamltest/builtin_actions.ml b/ocamltest/builtin_actions.ml index 4b1c2a32..64af2eec 100644 --- a/ocamltest/builtin_actions.ml +++ b/ocamltest/builtin_actions.ml @@ -145,6 +145,12 @@ let arch64 = make "64-bit architecture" "non-64-bit architecture") +let arch_power = make + "arch_power" + (Actions_helpers.pass_or_skip (String.equal Ocamltest_config.arch "power") + "Target is POWER architecture" + "Target is not POWER architecture") + let has_symlink = make "has_symlink" (Actions_helpers.pass_or_skip (Sys.has_symlink () ) @@ -208,4 +214,5 @@ let _ = run; script; check_program_output; + arch_power; ] diff --git a/ocamltest/builtin_actions.mli b/ocamltest/builtin_actions.mli index 6fbedc6b..241270eb 100644 --- a/ocamltest/builtin_actions.mli +++ b/ocamltest/builtin_actions.mli @@ -34,6 +34,9 @@ val not_bsd : Actions.t val arch32 : Actions.t val arch64 : Actions.t +(** Whether the compiler target is POWER architecture. *) +val arch_power : Actions.t + val has_symlink : Actions.t val setup_build_env : Actions.t diff --git a/ocamltest/ocaml_actions.ml b/ocamltest/ocaml_actions.ml index be3664da..02c17aa7 100644 --- a/ocamltest/ocaml_actions.ml +++ b/ocamltest/ocaml_actions.ml @@ -81,7 +81,16 @@ let backend_flags env = Ocaml_variables.ocamlc_flags Ocaml_variables.ocamlopt_flags -let dumb_term = [|"TERM=dumb"|] +let env_setting env_reader default_setting = + Printf.sprintf "%s=%s" + env_reader.Clflags.env_var + (env_reader.Clflags.print default_setting) + +let default_ocaml_env = [| + "TERM=dumb"; + env_setting Clflags.color_reader Misc.Color.default_setting; + env_setting Clflags.error_style_reader Misc.Error_style.default_setting; +|] type module_generator = { description : string; @@ -130,7 +139,7 @@ let generate_module generator ocamlsrcdir output_variable input log env = let expected_exit_status = 0 in let exit_status = Actions_helpers.run_cmd - ~environment:dumb_term + ~environment:default_ocaml_env ~stdin_variable: Ocaml_variables.compiler_stdin ~stdout_variable:output_variable ~stderr_variable:output_variable @@ -259,7 +268,7 @@ let compile_program ocamlsrcdir (compiler : Ocaml_compilers.compiler) log env = ] in let exit_status = Actions_helpers.run_cmd - ~environment:dumb_term + ~environment:default_ocaml_env ~stdin_variable: Ocaml_variables.compiler_stdin ~stdout_variable:compiler#output_variable ~stderr_variable:compiler#output_variable @@ -297,7 +306,7 @@ let compile_module ocamlsrcdir compiler module_ log env = ] in let exit_status = Actions_helpers.run_cmd - ~environment:dumb_term + ~environment:default_ocaml_env ~stdin_variable: Ocaml_variables.compiler_stdin ~stdout_variable:compiler#output_variable ~stderr_variable:compiler#output_variable @@ -466,7 +475,7 @@ let compile (compiler : Ocaml_compilers.compiler) log env = let commandline = [compiler#name ocamlsrcdir; cmdline] in let exit_status = Actions_helpers.run_cmd - ~environment:dumb_term + ~environment:default_ocaml_env ~stdin_variable: Ocaml_variables.compiler_stdin ~stdout_variable:compiler#output_variable ~stderr_variable:compiler#output_variable @@ -528,7 +537,7 @@ let debug log env = ] in let systemenv = Array.append - dumb_term + default_ocaml_env (Environments.to_system_env (env_with_lib_unix ocamlsrcdir env)) in let expected_exit_status = 0 in @@ -567,7 +576,7 @@ let objinfo log env = let systemenv = Array.concat [ - dumb_term; + default_ocaml_env; ocamllib; (Environments.to_system_env (env_with_lib_unix ocamlsrcdir env)) ] @@ -612,7 +621,7 @@ let mklib log env = let expected_exit_status = 0 in let exit_status = Actions_helpers.run_cmd - ~environment:dumb_term + ~environment:default_ocaml_env ~stdout_variable:Ocaml_variables.compiler_output ~stderr_variable:Ocaml_variables.compiler_output ~append:true @@ -651,7 +660,7 @@ let finalise_codegen_msvc ocamlsrcdir test_basename log env = let expected_exit_status = 0 in let exit_status = Actions_helpers.run_cmd - ~environment:dumb_term + ~environment:default_ocaml_env ~stdout_variable:Ocaml_variables.compiler_output ~stderr_variable:Ocaml_variables.compiler_output ~append:true @@ -698,7 +707,7 @@ let run_codegen log env = let expected_exit_status = 0 in let exit_status = Actions_helpers.run_cmd - ~environment:dumb_term + ~environment:default_ocaml_env ~stdout_variable:Ocaml_variables.compiler_output ~stderr_variable:Ocaml_variables.compiler_output ~append:true @@ -740,7 +749,7 @@ let run_cc log env = let expected_exit_status = 0 in let exit_status = Actions_helpers.run_cmd - ~environment:dumb_term + ~environment:default_ocaml_env ~stdout_variable:Ocaml_variables.compiler_output ~stderr_variable:Ocaml_variables.compiler_output ~append:true @@ -770,7 +779,8 @@ let run_expect_once ocamlsrcdir input_file principal log env = input_file ] in let exit_status = - Actions_helpers.run_cmd ~environment:dumb_term log env commandline in + Actions_helpers.run_cmd ~environment:default_ocaml_env log env commandline + in if exit_status=0 then (Result.pass, env) else begin let reason = (Actions_helpers.mkreason @@ -1052,12 +1062,12 @@ let run_test_program_in_toplevel (toplevel : Ocaml_toplevels.toplevel) log env = let exit_status = if ocaml_script_as_argument then Actions_helpers.run_cmd - ~environment:dumb_term + ~environment:default_ocaml_env ~stdout_variable:compiler_output_variable ~stderr_variable:compiler_output_variable log env commandline else Actions_helpers.run_cmd - ~environment:dumb_term + ~environment:default_ocaml_env ~stdin_variable:Builtin_variables.test_file ~stdout_variable:compiler_output_variable ~stderr_variable:compiler_output_variable @@ -1095,6 +1105,7 @@ let config_variables _log env = let ocamlsrcdir = Ocaml_directories.srcdir () in Environments.add_bindings [ + Ocaml_variables.arch, Ocamltest_config.arch; Ocaml_variables.ocamlrun, Ocaml_files.ocamlrun ocamlsrcdir; Ocaml_variables.ocamlc_byte, Ocaml_files.ocamlc ocamlsrcdir; Ocaml_variables.ocamlopt_byte, Ocaml_files.ocamlopt ocamlsrcdir; diff --git a/ocamltest/ocaml_flags.ml b/ocamltest/ocaml_flags.ml index 520b2451..bfb31cc7 100644 --- a/ocamltest/ocaml_flags.ml +++ b/ocamltest/ocaml_flags.ml @@ -55,6 +55,7 @@ let toplevel_default_flags = "-noinit -no-version -noprompt" let ocamldebug_default_flags ocamlsrcdir = "-no-version -no-prompt -no-time -no-breakpoint-message " ^ + ("-I " ^ (Ocaml_directories.stdlib ocamlsrcdir) ^ " ") ^ ("-topdirs-path " ^ (Ocaml_directories.toplevel ocamlsrcdir)) let ocamlobjinfo_default_flags = "-null-crc" diff --git a/ocamltest/ocaml_modifiers.ml b/ocamltest/ocaml_modifiers.ml index 6bf8ed23..cfa4fbcf 100644 --- a/ocamltest/ocaml_modifiers.ml +++ b/ocamltest/ocaml_modifiers.ml @@ -98,6 +98,7 @@ let systhreads = let compilerlibs_subdirs = [ "utils"; "parsing"; "toplevel"; "typing"; "bytecomp"; "compilerlibs"; + "file_formats"; "lambda"; ] let add_compiler_subdir subdir = @@ -107,6 +108,8 @@ let ocamlcommon = (Append (Ocaml_variables.libraries, wrap "ocamlcommon")) :: (List.map add_compiler_subdir compilerlibs_subdirs) +let debugger = [add_compiler_subdir "debugger"] + let _ = register_modifiers "principal" principal; register_modifiers "config" config; @@ -120,4 +123,5 @@ let _ = register_modifiers "html" html; register_modifiers "man" man; register_modifiers "tool-ocaml-lib" tool_ocaml_lib; + register_modifiers "debugger" debugger; () diff --git a/ocamltest/ocaml_variables.ml b/ocamltest/ocaml_variables.ml index f118d2c6..bfe69d8a 100644 --- a/ocamltest/ocaml_variables.ml +++ b/ocamltest/ocaml_variables.ml @@ -29,6 +29,9 @@ open Variables (* Should not be necessary with a ppx *) let all_modules = make ("all_modules", "All the modules to compile and link") +let arch = make ("arch", + "Host architecture") + let binary_modules = make ("binary_modules", "Additional binary modules to link") @@ -209,7 +212,7 @@ let ocaml_script_as_argument = "Whether the ocaml script should be passed as argument or on stdin") let plugins = - Variables.make ( "plugins", "plugins for ocamlc,ocamlopt or ocamldoc" ) + Variables.make ( "plugins", "plugins for ocamldoc" ) let shared_library_cflags = Variables.make ("shared_library_cflags", @@ -226,6 +229,7 @@ let use_runtime = let _ = List.iter register_variable [ all_modules; + arch; binary_modules; bytecc_libs; c_preprocessor; diff --git a/ocamltest/ocaml_variables.mli b/ocamltest/ocaml_variables.mli index c0b75154..647fd4f1 100644 --- a/ocamltest/ocaml_variables.mli +++ b/ocamltest/ocaml_variables.mli @@ -19,6 +19,8 @@ val all_modules : Variables.t +val arch : Variables.t + val binary_modules : Variables.t val bytecc_libs : Variables.t diff --git a/ocamltest/run_unix.c b/ocamltest/run_unix.c index 5fc70e7e..2db26d2d 100644 --- a/ocamltest/run_unix.c +++ b/ocamltest/run_unix.c @@ -267,13 +267,19 @@ static int handle_process_termination( if ( access(COREFILENAME, F_OK) == -1) fprintf(stderr, "Could not find core file.\n"); else { - char corefile[strlen(corefilename_prefix) + 128]; - snprintf(corefile, sizeof(corefile), - "%s.%d.core", corefilename_prefix, pid); - if ( rename(COREFILENAME, corefile) == -1) - fprintf(stderr, "The core file exists but could not be renamed.\n"); - else - fprintf(stderr,"The core file has been renamed to %s\n", corefile); + size_t corefile_len = strlen(corefilename_prefix) + 128; + char * corefile = malloc(corefile_len); + if (corefile == NULL) + fprintf(stderr, "Out of memory while processing core file.\n"); + else { + snprintf(corefile, corefile_len, + "%s.%d.core", corefilename_prefix, pid); + if ( rename(COREFILENAME, corefile) == -1) + fprintf(stderr, "The core file exists but could not be renamed.\n"); + else + fprintf(stderr,"The core file has been renamed to %s\n", corefile); + free(corefile); + } } } diff --git a/otherlibs/dynlink/.depend b/otherlibs/dynlink/.depend new file mode 100644 index 00000000..0a3555b1 --- /dev/null +++ b/otherlibs/dynlink/.depend @@ -0,0 +1,40 @@ +byte/dynlink.cmo : \ + dynlink_types.cmi \ + byte/dynlink_compilerlibs.cmi \ + dynlink_common.cmi \ + byte/dynlink.cmi +dynlink.cmi : +dynlink_common.cmo : \ + dynlink_types.cmi \ + dynlink_platform_intf.cmi \ + byte/dynlink_compilerlibs.cmi \ + dynlink_common.cmi +dynlink_common.cmi : \ + dynlink_platform_intf.cmi +dynlink_platform_intf.cmo : \ + dynlink_types.cmi \ + dynlink_platform_intf.cmi +dynlink_platform_intf.cmi : \ + dynlink_types.cmi +dynlink_types.cmo : \ + dynlink_types.cmi +dynlink_types.cmi : +extract_crc.cmo : \ + byte/dynlink_compilerlibs.cmi +dynlink_common.cmx : \ + dynlink_types.cmx \ + dynlink_platform_intf.cmx \ + native/dynlink_compilerlibs.cmx \ + dynlink_common.cmi +dynlink_platform_intf.cmx : \ + dynlink_types.cmx \ + dynlink_platform_intf.cmi +dynlink_types.cmx : \ + dynlink_types.cmi +extract_crc.cmx : \ + native/dynlink_compilerlibs.cmx +native/dynlink.cmx : \ + dynlink_types.cmx \ + native/dynlink_compilerlibs.cmx \ + dynlink_common.cmx \ + native/dynlink.cmi diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index 6e7c4238..2a59ad5b 100644 --- a/otherlibs/dynlink/Makefile +++ b/otherlibs/dynlink/Makefile @@ -3,9 +3,11 @@ #* OCaml * #* * #* Xavier Leroy, projet Cristal, INRIA Rocquencourt * +#* Mark Shinwell, Jane Street Europe * #* * #* Copyright 1999 Institut National de Recherche en Informatique et * #* en Automatique. * +#* Copyright 2018--2019 Jane Street Group LLC * #* * #* All rights reserved. This file is distributed under the terms of * #* the GNU Lesser General Public License version 2.1, with the * @@ -27,57 +29,195 @@ CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun OCAMLC = $(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib OCAMLOPT = $(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib -INCLUDES=$(addprefix -I $(ROOTDIR)/,utils typing bytecomp asmcomp) -COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-40-41-42-44-45-48 -bin-annot -g \ - -I $(ROOTDIR)/stdlib -warn-error A \ - -safe-string -strict-sequence -strict-formats +# COMPFLAGS should be in sync with the toplevel Makefile's COMPFLAGS. +COMPFLAGS=-strict-sequence -principal -absname -w +a-4-9-40-41-42-44-45-48-66 \ + -warn-error A \ + -bin-annot -safe-string -strict-formats ifeq "$(FLAMBDA)" "true" OPTCOMPFLAGS=-O3 else OPTCOMPFLAGS= endif -OBJS=dynlink_compilerlibs.cmo dynlink_types.cmo \ - dynlink_platform_intf.cmo dynlink_common.cmo dynlink.cmo -NATOBJS=dynlink_types.cmx dynlink_platform_intf.cmx \ - dynlink_common.cmx dynlink.cmx - -COMPILEROBJS = $(addprefix $(ROOTDIR)/,\ - utils/config.cmo utils/build_path_prefix_map.cmo utils/misc.cmo \ - utils/identifiable.cmo utils/numbers.cmo utils/arg_helper.cmo \ - utils/clflags.cmo utils/consistbl.cmo \ - utils/terminfo.cmo utils/warnings.cmo utils/load_path.cmo \ - parsing/location.cmo parsing/longident.cmo \ - parsing/docstrings.cmo parsing/syntaxerr.cmo \ - parsing/ast_helper.cmo parsing/ast_mapper.cmo parsing/ast_iterator.cmo \ - parsing/attr_helper.cmo parsing/builtin_attributes.cmo \ - typing/ident.cmo typing/path.cmo typing/primitive.cmo typing/types.cmo \ - typing/btype.cmo typing/subst.cmo typing/predef.cmo \ - typing/datarepr.cmo typing/cmi_format.cmo typing/env.cmo \ - bytecomp/lambda.cmo bytecomp/instruct.cmo \ - bytecomp/opcodes.cmo bytecomp/runtimedef.cmo bytecomp/bytesections.cmo \ - bytecomp/dll.cmo bytecomp/meta.cmo bytecomp/symtable.cmo) - -COMPILERINTFS = $(addprefix $(ROOTDIR)/,\ - bytecomp/cmo_format.cmi) +COMPFLAGS += -I byte +OPTCOMPFLAGS += -I native + +LOCAL_SRC=dynlink_compilerlibs + +OBJS=byte/dynlink_compilerlibs.cmo dynlink_types.cmo \ + dynlink_platform_intf.cmo dynlink_common.cmo byte/dynlink.cmo + +NATOBJS=native/dynlink_compilerlibs.cmx dynlink_types.cmx \ + dynlink_platform_intf.cmx dynlink_common.cmx native/dynlink.cmx + +# We need/desire access to compilerlibs for various reasons: +# - The bytecode dynamic linker is in compilerlibs and has many dependencies +# from there. +# - It stops duplication of code (e.g. magic numbers from [Config]). +# - It allows future improvement by re-using various types. +# We have to pack our own version of compilerlibs (even if compilerlibs +# becomes packed in the future by default) otherwise problems will be caused +# if a user tries to link dynlink.cm{x,}a with code either having modules +# of the same names or code that is already linked against compilerlibs. +# +# The modules needed from compilerlibs have to be recompiled so that the +# -for-pack option can be specified. Packing without such option having been +# specified, as used to be performed in this Makefile, is currently permitted +# for bytecode (but may be disallowed in the future) but not native. + +# .mli files from compilerlibs that don't have a corresponding .ml file. +COMPILERLIBS_INTFS=\ + parsing/asttypes.mli \ + parsing/parsetree.mli \ + typing/outcometree.mli \ + file_formats/cmo_format.mli \ + file_formats/cmxs_format.mli + +# .ml files from compilerlibs that have corresponding .mli files. +COMPILERLIBS_SOURCES=\ + utils/config.ml \ + utils/build_path_prefix_map.ml \ + utils/misc.ml \ + utils/identifiable.ml \ + utils/numbers.ml \ + utils/arg_helper.ml \ + utils/clflags.ml \ + utils/profile.ml \ + utils/consistbl.ml \ + utils/terminfo.ml \ + utils/warnings.ml \ + utils/load_path.ml \ + parsing/location.ml \ + parsing/longident.ml \ + parsing/docstrings.ml \ + parsing/syntaxerr.ml \ + parsing/ast_helper.ml \ + parsing/ast_mapper.ml \ + parsing/attr_helper.ml \ + parsing/builtin_attributes.ml \ + typing/ident.ml \ + typing/path.ml \ + typing/primitive.ml \ + typing/types.ml \ + typing/btype.ml \ + typing/subst.ml \ + typing/predef.ml \ + typing/datarepr.ml \ + file_formats/cmi_format.ml \ + typing/persistent_env.ml \ + typing/env.ml \ + lambda/lambda.ml \ + lambda/runtimedef.ml \ + bytecomp/instruct.ml \ + bytecomp/opcodes.ml \ + bytecomp/bytesections.ml \ + bytecomp/dll.ml \ + bytecomp/meta.ml \ + bytecomp/symtable.ml + +# Rules to make a local copy of the .ml and .mli files required. We also +# provide .ml files for .mli-only modules---without this, such modules do +# not seem to be located by the type checker inside bytecode packs. + +$(LOCAL_SRC)/Makefile: $(LOCAL_SRC)/Makefile.copy-sources + cp -f $< $@ + for ml in $(COMPILERLIBS_SOURCES); do \ + echo "$(LOCAL_SRC)/$$(basename $$ml): $(ROOTDIR)/$$ml" \ + >> $@; \ + echo "$(LOCAL_SRC)/$$(basename $$ml)i: $(ROOTDIR)/$${ml}i" \ + >> $@; \ + done; + for mli in $(COMPILERLIBS_INTFS); do \ + echo "$(LOCAL_SRC)/$$(basename $$mli): $(ROOTDIR)/$$mli" \ + >> $@; \ + echo \ + "$(LOCAL_SRC)/$$(basename $$mli .mli).ml: $(ROOTDIR)/$$mli"\ + >> $@; \ + done + +# Rules to automatically generate dependencies for the local copy of the +# compilerlibs sources. + +COMPILERLIBS_SOURCES_NO_DIRS=$(notdir $(COMPILERLIBS_SOURCES)) + +COMPILERLIBS_INTFS_NO_DIRS=$(notdir $(COMPILERLIBS_INTFS)) + +COMPILERLIBS_INTFS_BASE_NAMES=$(basename $(COMPILERLIBS_INTFS_NO_DIRS)) + +COMPILERLIBS_INTFS_ML_NO_DIRS=$(addsuffix .ml, $(COMPILERLIBS_INTFS_BASE_NAMES)) + +COMPILERLIBS_COPIED_INTFS=\ + $(addprefix $(LOCAL_SRC)/, $(COMPILERLIBS_INTFS_ML_NO_DIRS)) + +COMPILERLIBS_COPIED_SOURCES=\ + $(addprefix $(LOCAL_SRC)/, $(COMPILERLIBS_SOURCES_NO_DIRS)) \ + $(COMPILERLIBS_COPIED_INTFS) + +COMPILERLIBS_SOURCES_INTFS=\ + $(addsuffix i, $(COMPILERLIBS_SOURCES)) + +COMPILERLIBS_COPIED_SOURCES_INTFS=\ + $(addsuffix i, $(COMPILERLIBS_COPIED_SOURCES)) + +# $(LOCAL_SRC)/Makefile uses the variables above in dependencies, so must be +# include'd after they've been defined. +-include $(LOCAL_SRC)/Makefile + +# Rules to build the local copy of the compilerlibs sources in such a way +# that the resulting .cm{o,x} files can be packed. + +COMPILERLIBS_CMO=$(COMPILERLIBS_COPIED_SOURCES:.ml=.cmo) +COMPILERLIBS_CMX=$(COMPILERLIBS_COPIED_SOURCES:.ml=.cmx) + +$(LOCAL_SRC)/%.cmi: + $(OCAMLC) -c -for-pack Dynlink_compilerlibs $(COMPFLAGS) \ + -I $(LOCAL_SRC) -o $@ $(LOCAL_SRC)/$*.mli + +$(LOCAL_SRC)/%.cmo: + $(OCAMLC) -c -for-pack Dynlink_compilerlibs $(COMPFLAGS) \ + -I $(LOCAL_SRC) -o $@ $(LOCAL_SRC)/$*.ml + +$(LOCAL_SRC)/%.cmx: + $(OCAMLOPT) -c -for-pack Dynlink_compilerlibs $(COMPFLAGS) \ + $(OPTCOMPFLAGS) -I $(LOCAL_SRC) -o $@ $(LOCAL_SRC)/$*.ml + +# Rules for building the [Dynlink_compilerlibs] bytecode and native packs +# from their components. + +byte/dynlink_compilerlibs.cmo: $(COMPILERLIBS_CMO) + $(OCAMLC) $(COMPFLAGS) -pack -o $@ $(COMPILERLIBS_CMO) + +byte/dynlink_compilerlibs.cmi: byte/dynlink_compilerlibs.cmo + +native/dynlink_compilerlibs.cmx: $(COMPILERLIBS_CMX) + $(OCAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) -pack -o $@ $(COMPILERLIBS_CMX) + +%/dynlink.cmi: dynlink.cmi dynlink.mli + cp $^ $*/ + +# Rules for building the interface of the [Dynlink_compilerlibs] packs. +# To avoid falling foul of the problem described below, the .cmo and .cmx +# files for the dynlink-specific compilerlibs packs generated here---and in +# particular the corresponding .cmi files -- are kept in separate directories. + +# The main dynlink rules start here. all: dynlink.cma extract_crc allopt: dynlink.cmxa dynlink.cma: $(OBJS) - $(OCAMLC) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o $@ $^ + $(OCAMLC) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -I byte -o $@ $^ dynlink.cmxa: $(NATOBJS) - $(OCAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o $@ $^ - -dynlink_compilerlibs.cmo: $(COMPILEROBJS) $(COMPILERINTFS) - $(OCAMLC) $(COMPFLAGS) -pack -o $@ $^ - -# This rule is ok since there is no corresponding rule for native code -# compilation (otherwise we would fall foul of the problem in the next -# comment). -dynlink_compilerlibs.cmi: dynlink_compilerlibs.cmo + $(OCAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -I native \ + -o $@ $^ +# As for all other .cmxa files, ensure that the .cmx files are in the same +# directory. If this were omitted, ocamldoc in particular will fail to build +# with a -opaque warning. Note that installopt refers to $(NATOBJS) so doesn't +# require this file to exist, hence its inclusion in the recipe for dynlink.cmxa +# rather than as a dependency elsewhere. + cp native/dynlink.cmx dynlink.cmx # Since there is no .mli for [Dynlink_platform_intf], we need to be # careful that compilation of the .cmx file does not write the .cmi file again, @@ -85,62 +225,8 @@ dynlink_compilerlibs.cmi: dynlink_compilerlibs.cmo # to be to copy the .ml file, which is a valid .mli, to the .mli. dynlink_platform_intf.mli: dynlink_platform_intf.ml cp $< $@ -dynlink_platform_intf.cmi: dynlink_platform_intf.mli \ - dynlink_types.cmi - $(OCAMLC) $(COMPFLAGS) -c $< - -dynlink_platform_intf.cmo: dynlink_platform_intf.ml \ - dynlink_platform_intf.cmi \ - dynlink_types.cmo - $(OCAMLC) $(COMPFLAGS) -c dynlink_platform_intf.ml - -dynlink_platform_intf.cmx: dynlink_platform_intf.ml \ - dynlink_platform_intf.cmi \ - dynlink_types.cmx - $(OCAMLOPT) $(COMPFLAGS) -c dynlink_platform_intf.ml - -dynlink_types.cmi: dynlink_types.mli - $(OCAMLC) $(COMPFLAGS) -c dynlink_types.mli - -dynlink_types.cmo: dynlink_types.ml dynlink_types.cmi - $(OCAMLC) $(COMPFLAGS) -c dynlink_types.ml - -dynlink_types.cmx: dynlink_types.ml dynlink_types.cmi - $(OCAMLOPT) $(COMPFLAGS) -c dynlink_types.ml - -dynlink_common.cmi: dynlink_common.mli \ - dynlink_platform_intf.cmi \ - dynlink_types.cmi - $(OCAMLC) $(COMPFLAGS) -c dynlink_common.mli - -dynlink_common.cmo: dynlink_common.ml \ - dynlink_common.cmi \ - dynlink_platform_intf.cmo - $(OCAMLC) $(COMPFLAGS) -c dynlink_common.ml - -dynlink_common.cmx: dynlink_common.ml \ - dynlink_common.cmi \ - dynlink_platform_intf.cmx - $(OCAMLOPT) $(COMPFLAGS) -c dynlink_common.ml - -dynlink.cmi: dynlink.mli dynlink_compilerlibs.cmi - $(OCAMLC) -c $(COMPFLAGS) dynlink.mli - -dynlink.cmo: dynlink.cmi dynlink_common.cmi \ - dynlink_types.cmo dynlink_common.cmo dynlink.ml \ - dynlink_compilerlibs.cmo - $(OCAMLC) -c $(COMPFLAGS) -impl dynlink.ml - -dynlink.cmx: dynlink.cmi dynlink_common.cmi \ - dynlink_types.cmx dynlink_common.cmx natdynlink.ml - cp natdynlink.ml dynlink.mlopt - $(OCAMLOPT) -c $(COMPFLAGS) -impl dynlink.mlopt - rm -f dynlink.mlopt - -extract_crc.cmo: extract_crc.ml dynlink.cmi - $(OCAMLC) -c $(COMPFLAGS) extract_crc.ml - -extract_crc: $(COMPILEROBJS) dynlink.cma extract_crc.cmo + +extract_crc: dynlink.cma byte/dynlink_compilerlibs.cmo extract_crc.cmo $(OCAMLC) -o $@ $^ install: @@ -164,10 +250,46 @@ installopt: fi partialclean: - rm -f extract_crc *.cm[ioaxt] *.cmti *.cmxa + rm -f extract_crc *.cm[ioaxt] *.cmti *.cmxa \ + byte/*.cm[iot] byte/*.cmti \ + native/*.cm[ixt] native/*.cmti native/*.$(O) \ + $(LOCAL_SRC)/*.cm[ioaxt] $(LOCAL_SRC)/*.cmti $(LOCAL_SRC)/*.$(O) clean: partialclean - rm -f *.$(A) *.$(O) *.so *.dll dynlink.mlopt \ - dynlink_platform_intf.mli + rm -f *.$(A) *.$(O) *.so *.dll dynlink_platform_intf.mli \ + $(LOCAL_SRC)/*.ml $(LOCAL_SRC)/*.mli $(LOCAL_SRC)/Makefile \ + $(LOCAL_SRC)/.depend byte/dynlink.mli native/dynlink.mli + +.PHONY: depend +ifeq "$(TOOLCHAIN)" "msvc" +depend: + $(error Dependencies cannot be regenerated using the MSVC ports) +else +DEPEND_DUMMY_FILES=\ + native/dynlink_compilerlibs.ml \ + byte/dynlink_compilerlibs.mli \ + byte/dynlink.mli \ + native/dynlink.mli \ + dynlink_platform_intf.mli depend: + touch $(DEPEND_DUMMY_FILES) + $(CAMLRUN) $(ROOTDIR)/boot/ocamlc -depend -slash \ + -I byte -bytecode *.mli *.ml byte/dynlink.ml > .depend + $(CAMLRUN) $(ROOTDIR)/boot/ocamlc -depend -slash \ + -I native -native *.ml native/dynlink.ml >> .depend + rm -f $(DEPEND_DUMMY_FILES) +endif + +include .depend + +.SUFFIXES: .ml .mli .cmi .cmo .cmx .$(O) + +.mli.cmi: + $(OCAMLC) -c $(COMPFLAGS) $< + +.ml.cmo: + $(OCAMLC) -c $(COMPFLAGS) $< + +.ml.cmx: + $(OCAMLOPT) -c $(COMPFLAGS) $(OPTCOMPFLAGS) $< diff --git a/otherlibs/dynlink/byte/dynlink.ml b/otherlibs/dynlink/byte/dynlink.ml new file mode 100644 index 00000000..9bb54320 --- /dev/null +++ b/otherlibs/dynlink/byte/dynlink.ml @@ -0,0 +1,204 @@ +#3 "otherlibs/dynlink/dynlink.ml" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2017--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. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +open! Dynlink_compilerlibs + +module DC = Dynlink_common +module DT = Dynlink_types + +module Bytecode = struct + type filename = string + + module Unit_header = struct + type t = Cmo_format.compilation_unit + + let name (t : t) = t.cu_name + let crc _t = None + + let interface_imports (t : t) = t.cu_imports + let implementation_imports (t : t) = + let required = + t.cu_required_globals + @ Symtable.required_globals t.cu_reloc + in + let required = + List.filter + (fun id -> + not (Ident.is_predef id) + && not (String.contains (Ident.name id) '.')) + required + in + List.map + (fun ident -> Ident.name ident, None) + required + + let defined_symbols (t : t) = + List.map (fun ident -> Ident.name ident) + (Symtable.defined_globals t.cu_reloc) + + let unsafe_module (t : t) = t.cu_primitives <> [] + end + + type handle = Stdlib.in_channel * filename * Digest.t + + let default_crcs = ref [] + let default_global_map = ref Symtable.empty_global_map + + let init () = + if !Sys.interactive then begin (* PR#6802 *) + invalid_arg "The dynlink.cma library cannot be used \ + inside the OCaml toplevel" + end; + default_crcs := Symtable.init_toplevel (); + default_global_map := Symtable.current_state () + + let is_native = false + let adapt_filename f = f + + let num_globals_inited () = + Misc.fatal_error "Should never be called for bytecode dynlink" + + let fold_initial_units ~init ~f = + List.fold_left (fun acc (comp_unit, interface) -> + let id = Ident.create_persistent comp_unit in + let defined = + Symtable.is_defined_in_global_map !default_global_map id + in + let implementation = + if defined then Some (None, DT.Loaded) + else None + in + let defined_symbols = + if defined then [comp_unit] + else [] + in + f acc ~comp_unit ~interface ~implementation ~defined_symbols) + init + !default_crcs + + let run_shared_startup _ = () + + let run (ic, file_name, file_digest) ~unit_header ~priv = + let open Misc in + let old_state = Symtable.current_state () in + let compunit : Cmo_format.compilation_unit = unit_header in + seek_in ic compunit.cu_pos; + let code_size = compunit.cu_codesize + 8 in + let code = LongString.create code_size in + LongString.input_bytes_into code ic compunit.cu_codesize; + LongString.set code compunit.cu_codesize (Char.chr Opcodes.opRETURN); + LongString.blit_string "\000\000\000\001\000\000\000" 0 + code (compunit.cu_codesize + 1) 7; + begin try + Symtable.patch_object code compunit.cu_reloc; + Symtable.check_global_initialized compunit.cu_reloc; + Symtable.update_global_table () + with Symtable.Error error -> + let new_error : DT.linking_error = + match error with + | Symtable.Undefined_global s -> Undefined_global s + | Symtable.Unavailable_primitive s -> Unavailable_primitive s + | Symtable.Uninitialized_global s -> Uninitialized_global s + | Symtable.Wrong_vm _ -> assert false + in + raise (DT.Error (Linking_error (file_name, new_error))) + end; + (* PR#5215: identify this code fragment by + digest of file contents + unit name. + Unit name is needed for .cma files, which produce several code + fragments. *) + let digest = Digest.string (file_digest ^ compunit.cu_name) in + let events = + if compunit.cu_debug = 0 then [| |] + else begin + seek_in ic compunit.cu_debug; + [| input_value ic |] + end in + if priv then Symtable.hide_additions old_state; + let _, clos = Meta.reify_bytecode code events (Some digest) in + try ignore ((clos ()) : Obj.t) + with exn -> raise (DT.Error (Library's_module_initializers_failed exn)) + + let load ~filename:file_name ~priv:_ = + let ic = open_in_bin file_name in + let file_digest = Digest.channel ic (-1) in + seek_in ic 0; + try + let buffer = + try really_input_string ic (String.length Config.cmo_magic_number) + with End_of_file -> raise (DT.Error (Not_a_bytecode_file file_name)) + in + let handle = ic, file_name, file_digest in + if buffer = Config.cmo_magic_number then begin + let compunit_pos = input_binary_int ic in (* Go to descriptor *) + seek_in ic compunit_pos; + let cu = (input_value ic : Cmo_format.compilation_unit) in + handle, [cu] + end else + if buffer = Config.cma_magic_number then begin + let toc_pos = input_binary_int ic in (* Go to table of contents *) + seek_in ic toc_pos; + let lib = (input_value ic : Cmo_format.library) in + begin try + Dll.open_dlls Dll.For_execution + (List.map Dll.extract_dll_name lib.lib_dllibs) + with exn -> + raise (DT.Error (Cannot_open_dynamic_library exn)) + end; + handle, lib.lib_units + end else begin + raise (DT.Error (Not_a_bytecode_file file_name)) + end + with exc -> + close_in ic; + raise exc + + let unsafe_get_global_value ~bytecode_or_asm_symbol = + let id = Ident.create_persistent bytecode_or_asm_symbol in + match Symtable.get_global_value id with + | exception _ -> None + | obj -> Some obj + + let finish (ic, _filename, _digest) = + close_in ic +end + +include DC.Make (Bytecode) + +type linking_error = DT.linking_error = + | Undefined_global of string + | Unavailable_primitive of string + | Uninitialized_global of string + +type error = DT.error = + | Not_a_bytecode_file of string + | Inconsistent_import of string + | Unavailable_unit of string + | Unsafe_file + | Linking_error of string * linking_error + | Corrupted_interface of string + | Cannot_open_dynamic_library of exn + | Library's_module_initializers_failed of exn + | Inconsistent_implementation of string + | Module_already_loaded of string + | Private_library_cannot_implement_interface of string + +exception Error = DT.Error +let error_message = DT.error_message diff --git a/otherlibs/dynlink/dune b/otherlibs/dynlink/dune index 83b8879c..32a84264 100644 --- a/otherlibs/dynlink/dune +++ b/otherlibs/dynlink/dune @@ -12,16 +12,20 @@ ;* * ;************************************************************************** -(library - (name dynlink) - (wrapped false) - (modules dynlink dynlink_compilerlibs dynlink_common dynlink_types - dynlink_platform_intf) - ; the -33 is specific to the hackery done with dune. - (flags (:standard -nostdlib -w -33)) - (libraries ocamlcommon stdlib)) - -(rule - (targets dynlink_compilerlibs.ml) - (action (write-file %{targets} - "(* empty because we are linking with ocamlcommon *)"))) +; mshinwell: Disabled: this needs to build in the same way as the +; Makefile does, with the [Dynlink_compilerlibs] pack. +; +; (library +; (name dynlink) +; (wrapped false) +; (modules dynlink dynlink_compilerlibs dynlink_common dynlink_types +; dynlink_platform_intf) +; ; the -33 is specific to the hackery done with dune. +; (flags (:standard -nostdlib -w -33)) +; (modules_without_implementation dynlink) +; (libraries ocamlcommon stdlib)) +; +; (rule +; (targets dynlink_compilerlibs.ml) +; (action (write-file %{targets} +; "(* empty because we are linking with ocamlcommon *)"))) diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml deleted file mode 100644 index 35bd88e2..00000000 --- a/otherlibs/dynlink/dynlink.ml +++ /dev/null @@ -1,198 +0,0 @@ -#3 "otherlibs/dynlink/dynlink.ml" -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* Copyright 2017--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. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-30-40-41-42"] - -open! Dynlink_compilerlibs (* REMOVE_ME for ../../debugger/dynlink.ml *) - -module DC = Dynlink_common -module DT = Dynlink_types - -module Bytecode = struct - type filename = string - - module Unit_header = struct - type t = Cmo_format.compilation_unit - - let name (t : t) = t.cu_name - let crc _t = None - - let interface_imports (t : t) = t.cu_imports - let implementation_imports (t : t) = - let required = - t.cu_required_globals - @ Symtable.required_globals t.cu_reloc - in - let required = - List.filter - (fun id -> - not (Ident.is_predef id) - && not (String.contains (Ident.name id) '.')) - required - in - List.map - (fun ident -> Ident.name ident, None) - required - - let defined_symbols (t : t) = - List.map (fun ident -> Ident.name ident) - (Symtable.defined_globals t.cu_reloc) - - let unsafe_module (t : t) = t.cu_primitives <> [] - end - - type handle = Stdlib.in_channel * filename * Digest.t - - let default_crcs = ref [] - let default_global_map = ref Symtable.empty_global_map - - let init () = - if !Sys.interactive then begin (* PR#6802 *) - invalid_arg "The dynlink.cma library cannot be used \ - inside the OCaml toplevel" - end; - default_crcs := Symtable.init_toplevel (); - default_global_map := Symtable.current_state () - - let is_native = false - let adapt_filename f = f - - let num_globals_inited () = - Misc.fatal_error "Should never be called for bytecode dynlink" - - let fold_initial_units ~init ~f = - List.fold_left (fun acc (comp_unit, interface) -> - let id = Ident.create_persistent comp_unit in - let defined = - Symtable.is_defined_in_global_map !default_global_map id - in - let implementation = - if defined then Some (None, DT.Loaded) - else None - in - let defined_symbols = - if defined then [comp_unit] - else [] - in - f acc ~comp_unit ~interface ~implementation ~defined_symbols) - init - !default_crcs - - let run_shared_startup _ = () - - let run (ic, file_name, file_digest) ~unit_header ~priv = - let open Misc in - let old_state = Symtable.current_state () in - let compunit : Cmo_format.compilation_unit = unit_header in - seek_in ic compunit.cu_pos; - let code_size = compunit.cu_codesize + 8 in - let code = LongString.create code_size in - LongString.input_bytes_into code ic compunit.cu_codesize; - LongString.set code compunit.cu_codesize (Char.chr Opcodes.opRETURN); - LongString.blit_string "\000\000\000\001\000\000\000" 0 - code (compunit.cu_codesize + 1) 7; - begin try - Symtable.patch_object code compunit.cu_reloc; - Symtable.check_global_initialized compunit.cu_reloc; - Symtable.update_global_table () - with Symtable.Error error -> - let new_error : DT.linking_error = - match error with - | Symtable.Undefined_global s -> Undefined_global s - | Symtable.Unavailable_primitive s -> Unavailable_primitive s - | Symtable.Uninitialized_global s -> Uninitialized_global s - | Symtable.Wrong_vm _ -> assert false - in - raise (DT.Error (Linking_error (file_name, new_error))) - end; - (* PR#5215: identify this code fragment by - digest of file contents + unit name. - Unit name is needed for .cma files, which produce several code - fragments. *) - let digest = Digest.string (file_digest ^ compunit.cu_name) in - let events = - if compunit.cu_debug = 0 then [| |] - else begin - seek_in ic compunit.cu_debug; - [| input_value ic |] - end in - if priv then Symtable.hide_additions old_state; - let _, clos = Meta.reify_bytecode code events (Some digest) in - try ignore ((clos ()) : Obj.t) - with exn -> raise (DT.Error (Library's_module_initializers_failed exn)) - - let load ~filename:file_name ~priv:_ = - let ic = open_in_bin file_name in - let file_digest = Digest.channel ic (-1) in - seek_in ic 0; - try - let buffer = - try really_input_string ic (String.length Config.cmo_magic_number) - with End_of_file -> raise (DT.Error (Not_a_bytecode_file file_name)) - in - let handle = ic, file_name, file_digest in - if buffer = Config.cmo_magic_number then begin - let compunit_pos = input_binary_int ic in (* Go to descriptor *) - seek_in ic compunit_pos; - let cu = (input_value ic : Cmo_format.compilation_unit) in - handle, [cu] - end else - if buffer = Config.cma_magic_number then begin - let toc_pos = input_binary_int ic in (* Go to table of contents *) - seek_in ic toc_pos; - let lib = (input_value ic : Cmo_format.library) in - begin try - Dll.open_dlls Dll.For_execution - (List.map Dll.extract_dll_name lib.lib_dllibs) - with exn -> - raise (DT.Error (Cannot_open_dynamic_library exn)) - end; - handle, lib.lib_units - end else begin - raise (DT.Error (Not_a_bytecode_file file_name)) - end - with exc -> - close_in ic; - raise exc - - let finish (ic, _filename, _digest) = - close_in ic -end - -include DC.Make (Bytecode) - -type linking_error = DT.linking_error = - | Undefined_global of string - | Unavailable_primitive of string - | Uninitialized_global of string - -type error = DT.error = - | Not_a_bytecode_file of string - | Inconsistent_import of string - | Unavailable_unit of string - | Unsafe_file - | Linking_error of string * linking_error - | Corrupted_interface of string - | Cannot_open_dynamic_library of exn - | Library's_module_initializers_failed of exn - | Inconsistent_implementation of string - | Module_already_loaded of string - | Private_library_cannot_implement_interface of string - -exception Error = DT.Error -let error_message = DT.error_message diff --git a/otherlibs/dynlink/dynlink.mli b/otherlibs/dynlink/dynlink.mli index 3b81e752..a9770a25 100644 --- a/otherlibs/dynlink/dynlink.mli +++ b/otherlibs/dynlink/dynlink.mli @@ -149,3 +149,25 @@ exception Error of error val error_message : error -> string (** Convert an error description to a printable message. *) + +(**/**) + +val unsafe_get_global_value : bytecode_or_asm_symbol:string -> Obj.t option +(** Obtain the globally-visible value whose address is that of the given symbol. + The symbol name must be the mangled form as would occur in bytecode or + a native object file. [None] is returned if the value is inaccessible. + The accessible values are those in the main program and those provided by + previous calls to [loadfile]. + + This function is deemed "unsafe" as there is no type safety provided. + + When executing in bytecode, this function uses [Symtable]. As a cautionary + note for programs such as the debugger: even though the linking of a packed + (subset of) compilerlibs into [Dynlink] hides the copy of [Symtable] that + [Dynlink] uses from its clients, there is still only one table of global + values in the bytecode VM. Changes to this table are NOT synchronized + between [Dynlink] and the functions that change the global value table + ([update_global_table] and [assign_global_value], accessed through a + client's version of [Symtable]). This is why we can't use [Dynlink] from the + toplevel interactive loop, in particular. +*) diff --git a/otherlibs/dynlink/dynlink_common.ml b/otherlibs/dynlink/dynlink_common.ml index 4ce7c63a..3a362fd1 100644 --- a/otherlibs/dynlink/dynlink_common.ml +++ b/otherlibs/dynlink/dynlink_common.ml @@ -8,7 +8,7 @@ (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. *) -(* Copyright 2017--2018 Jane Street Group LLC *) +(* Copyright 2017--2019 Jane Street Group LLC *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) @@ -18,14 +18,13 @@ [@@@ocaml.warning "+a-4-30-40-41-42"] -(* This compilation unit cannot depend on compilerlibs. *) -module String = struct - include String +open! Dynlink_compilerlibs - module Set = Set.Make (String) +module String = struct + include Misc.Stdlib.String module Map = struct - include Map.Make (String) + include Map let keys t = fold (fun key _data keys -> Set.add key keys) t Set.empty @@ -355,6 +354,8 @@ module Make (P : Dynlink_platform_intf.S) = struct let loadfile filename = load false filename let loadfile_private filename = load true filename + let unsafe_get_global_value = P.unsafe_get_global_value + let is_native = P.is_native let adapt_filename = P.adapt_filename end diff --git a/otherlibs/dynlink/dynlink_common.mli b/otherlibs/dynlink/dynlink_common.mli index a4c001ea..a9201249 100644 --- a/otherlibs/dynlink/dynlink_common.mli +++ b/otherlibs/dynlink/dynlink_common.mli @@ -23,6 +23,7 @@ module Make (P : Dynlink_platform_intf.S) : sig val is_native : bool val loadfile : string -> unit val loadfile_private : string -> unit + val unsafe_get_global_value : bytecode_or_asm_symbol:string -> Obj.t option val adapt_filename : string -> string val set_allowed_units : string list -> unit val allow_only: string list -> unit diff --git a/otherlibs/dynlink/dynlink_compilerlibs/Makefile.copy-sources b/otherlibs/dynlink/dynlink_compilerlibs/Makefile.copy-sources new file mode 100644 index 00000000..4bd3bc59 --- /dev/null +++ b/otherlibs/dynlink/dynlink_compilerlibs/Makefile.copy-sources @@ -0,0 +1,30 @@ +#************************************************************************** +#* * +#* OCaml * +#* * +#* Mark Shinwell, Jane Street Europe * +#* * +#* Copyright 1999 Institut National de Recherche en Informatique et * +#* en Automatique. * +#* Copyright 2018--2019 Jane Street Group LLC * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +$(LOCAL_SRC)/.depend: $(COMPILERLIBS_COPIED_SOURCES) \ + $(COMPILERLIBS_COPIED_SOURCES_INTFS) $(LOCAL_SRC)/Makefile + $(CAMLRUN) $(ROOTDIR)/ocamlc -depend -slash -I $(LOCAL_SRC) \ + $(COMPILERLIBS_COPIED_SOURCES) \ + $(COMPILERLIBS_COPIED_SOURCES_INTFS) \ + > $(LOCAL_SRC)/.depend + +-include $(LOCAL_SRC)/.depend + +$(LOCAL_SRC)/%.ml: + cp $< $@ + +$(LOCAL_SRC)/%.mli: + cp $< $@ diff --git a/otherlibs/dynlink/dynlink_platform_intf.ml b/otherlibs/dynlink/dynlink_platform_intf.ml index 900f595c..d4b3a9b6 100644 --- a/otherlibs/dynlink/dynlink_platform_intf.ml +++ b/otherlibs/dynlink/dynlink_platform_intf.ml @@ -63,5 +63,7 @@ module type S = sig val run_shared_startup : handle -> unit val run : handle -> unit_header:Unit_header.t -> priv:bool -> unit + val unsafe_get_global_value : bytecode_or_asm_symbol:string -> Obj.t option + val finish : handle -> unit end diff --git a/otherlibs/dynlink/extract_crc.ml b/otherlibs/dynlink/extract_crc.ml index 2ccbda86..49c48394 100644 --- a/otherlibs/dynlink/extract_crc.ml +++ b/otherlibs/dynlink/extract_crc.ml @@ -15,6 +15,8 @@ (* Print the digests of unit interfaces *) +open! Dynlink_compilerlibs + let load_path = ref [] let first = ref true diff --git a/otherlibs/dynlink/natdynlink.ml b/otherlibs/dynlink/natdynlink.ml deleted file mode 100644 index 24f04f50..00000000 --- a/otherlibs/dynlink/natdynlink.ml +++ /dev/null @@ -1,122 +0,0 @@ -#3 "otherlibs/dynlink/natdynlink.ml" -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* Copyright 2017--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. *) -(* *) -(**************************************************************************) - -(* Dynamic loading of .cmx files *) - -[@@@ocaml.warning "+a-4-30-40-41-42"] - -module DC = Dynlink_common -module DT = Dynlink_types - -type global_map = { - name : string; - crc_intf : Digest.t option; - crc_impl : Digest.t option; - syms : string list -} - -module Native = struct - type handle - - external ndl_open : string -> bool -> handle * Cmx_format.dynheader - = "caml_natdynlink_open" - external ndl_run : handle -> string -> unit = "caml_natdynlink_run" - external ndl_getmap : unit -> global_map list = "caml_natdynlink_getmap" - external ndl_globals_inited : unit -> int = "caml_natdynlink_globals_inited" - - module Unit_header = struct - type t = Cmx_format.dynunit - - let name (t : t) = t.dynu_name - let crc (t : t) = Some t.dynu_crc - - let interface_imports (t : t) = t.dynu_imports_cmi - let implementation_imports (t : t) = t.dynu_imports_cmx - - let defined_symbols (t : t) = t.dynu_defines - let unsafe_module _t = false - end - - let init () = () - - let is_native = true - let adapt_filename f = Filename.chop_extension f ^ ".cmxs" - - let num_globals_inited () = ndl_globals_inited () - - (* Copied from config.ml -- this file cannot depend on that. *) - let cmxs_magic_number = "Caml1999D025" - - let fold_initial_units ~init ~f = - let rank = ref 0 in - List.fold_left (fun acc { name; crc_intf; crc_impl; syms; } -> - rank := !rank + List.length syms; - let implementation = - match crc_impl with - | None -> None - | Some _ as crco -> Some (crco, DT.Check_inited !rank) - in - f acc ~comp_unit:name ~interface:crc_intf - ~implementation ~defined_symbols:syms) - init - (ndl_getmap ()) - - let run_shared_startup handle = - ndl_run handle "_shared_startup" - - let run handle ~unit_header ~priv:_ = - List.iter (fun cu -> - try ndl_run handle cu - with exn -> raise (DT.Error (Library's_module_initializers_failed exn))) - (Unit_header.defined_symbols unit_header) - - let load ~filename ~priv = - let handle, header = - try ndl_open filename (not priv) - with exn -> raise (DT.Error (Cannot_open_dynamic_library exn)) - in - if header.dynu_magic <> cmxs_magic_number then begin - raise (DT.Error (Not_a_bytecode_file filename)) - end; - handle, header.dynu_units - - let finish _handle = () -end - -include DC.Make (Native) - -type linking_error = DT.linking_error = - | Undefined_global of string - | Unavailable_primitive of string - | Uninitialized_global of string - -type error = DT.error = - | Not_a_bytecode_file of string - | Inconsistent_import of string - | Unavailable_unit of string - | Unsafe_file - | Linking_error of string * linking_error - | Corrupted_interface of string - | Cannot_open_dynamic_library of exn - | Library's_module_initializers_failed of exn - | Inconsistent_implementation of string - | Module_already_loaded of string - | Private_library_cannot_implement_interface of string - -exception Error = DT.Error -let error_message = DT.error_message diff --git a/otherlibs/dynlink/native/dynlink.ml b/otherlibs/dynlink/native/dynlink.ml new file mode 100644 index 00000000..fda32112 --- /dev/null +++ b/otherlibs/dynlink/native/dynlink.ml @@ -0,0 +1,127 @@ +#3 "otherlibs/dynlink/native/dynlink.ml" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2017--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. *) +(* *) +(**************************************************************************) + +(* Dynamic loading of .cmx files *) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +open! Dynlink_compilerlibs + +module DC = Dynlink_common +module DT = Dynlink_types + +type global_map = { + name : string; + crc_intf : Digest.t option; + crc_impl : Digest.t option; + syms : string list +} + +module Native = struct + type handle + + external ndl_open : string -> bool -> handle * Cmxs_format.dynheader + = "caml_natdynlink_open" + external ndl_run : handle -> string -> unit = "caml_natdynlink_run" + external ndl_getmap : unit -> global_map list = "caml_natdynlink_getmap" + external ndl_globals_inited : unit -> int = "caml_natdynlink_globals_inited" + external ndl_loadsym : string -> Obj.t = "caml_natdynlink_loadsym" + + module Unit_header = struct + type t = Cmxs_format.dynunit + + let name (t : t) = t.dynu_name + let crc (t : t) = Some t.dynu_crc + + let interface_imports (t : t) = t.dynu_imports_cmi + let implementation_imports (t : t) = t.dynu_imports_cmx + + let defined_symbols (t : t) = t.dynu_defines + let unsafe_module _t = false + end + + let init () = () + + let is_native = true + let adapt_filename f = Filename.chop_extension f ^ ".cmxs" + + let num_globals_inited () = ndl_globals_inited () + + let fold_initial_units ~init ~f = + let rank = ref 0 in + List.fold_left (fun acc { name; crc_intf; crc_impl; syms; } -> + rank := !rank + List.length syms; + let implementation = + match crc_impl with + | None -> None + | Some _ as crco -> Some (crco, DT.Check_inited !rank) + in + f acc ~comp_unit:name ~interface:crc_intf + ~implementation ~defined_symbols:syms) + init + (ndl_getmap ()) + + let run_shared_startup handle = + ndl_run handle "_shared_startup" + + let run handle ~unit_header ~priv:_ = + List.iter (fun cu -> + try ndl_run handle cu + with exn -> raise (DT.Error (Library's_module_initializers_failed exn))) + (Unit_header.defined_symbols unit_header) + + let load ~filename ~priv = + let handle, header = + try ndl_open filename (not priv) + with exn -> raise (DT.Error (Cannot_open_dynamic_library exn)) + in + if header.dynu_magic <> Config.cmxs_magic_number then begin + raise (DT.Error (Not_a_bytecode_file filename)) + end; + handle, header.dynu_units + + let unsafe_get_global_value ~bytecode_or_asm_symbol = + match ndl_loadsym bytecode_or_asm_symbol with + | exception _ -> None + | obj -> Some obj + + let finish _handle = () +end + +include DC.Make (Native) + +type linking_error = DT.linking_error = + | Undefined_global of string + | Unavailable_primitive of string + | Uninitialized_global of string + +type error = DT.error = + | Not_a_bytecode_file of string + | Inconsistent_import of string + | Unavailable_unit of string + | Unsafe_file + | Linking_error of string * linking_error + | Corrupted_interface of string + | Cannot_open_dynamic_library of exn + | Library's_module_initializers_failed of exn + | Inconsistent_implementation of string + | Module_already_loaded of string + | Private_library_cannot_implement_interface of string + +exception Error = DT.Error +let error_message = DT.error_message diff --git a/otherlibs/dynlink/nodynlink.ml b/otherlibs/dynlink/nodynlink.ml deleted file mode 100644 index 4556e775..00000000 --- a/otherlibs/dynlink/nodynlink.ml +++ /dev/null @@ -1,79 +0,0 @@ -#2 "otherlibs/dynlink/nodynlink.ml" -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* Copyright 2017--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. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-30-40-41-42"] - -module DC = Dynlink_common -module DT = Dynlink_types - -let not_available _ = - failwith "No support for native dynlink on this platform" - -module Not_available = struct - module Unit_header = struct - type t = unit - - let name = not_available - let crc = not_available - - let interface_imports = not_available - let implementation_imports = not_available - - let defined_symbols = not_available - let unsafe_module = not_available - end - - type handle = unit - - let init = not_available - - let is_native = false - let adapt_filename = not_available - - let num_globals_inited = not_available - - let fold_initial_units ~init ~f:_ = not_available init - - let run_shared_startup _ = not_available () - let run _ ~unit_header:_ ~priv:_ = not_available () - let load ~filename:_ ~priv:_ = not_available () - let finish = not_available -end - -include DC.Make (Not_available) - -type linking_error = DT.linking_error = - | Undefined_global of string - | Unavailable_primitive of string - | Uninitialized_global of string - -type error = DT.error = - | Not_a_bytecode_file of string - | Inconsistent_import of string - | Unavailable_unit of string - | Unsafe_file - | Linking_error of string * linking_error - | Corrupted_interface of string - | Cannot_open_dynamic_library of exn - | Library's_module_initializers_failed of exn - | Inconsistent_implementation of string - | Module_already_loaded of string - | Private_library_cannot_implement_interface of string - -exception Error = DT.Error -let error_message = DT.error_message diff --git a/otherlibs/graph/.depend b/otherlibs/graph/.depend deleted file mode 100644 index 1ac60883..00000000 --- a/otherlibs/graph/.depend +++ /dev/null @@ -1,69 +0,0 @@ -color.o: color.c libgraph.h ../../runtime/caml/mlvalues.h \ - ../../runtime/caml/config.h ../../runtime/caml/m.h \ - ../../runtime/caml/s.h ../../runtime/caml/misc.h \ - ../../runtime/caml/misc.h -draw.o: draw.c libgraph.h ../../runtime/caml/mlvalues.h \ - ../../runtime/caml/config.h ../../runtime/caml/m.h \ - ../../runtime/caml/s.h ../../runtime/caml/misc.h \ - ../../runtime/caml/misc.h ../../runtime/caml/alloc.h \ - ../../runtime/caml/mlvalues.h -dump_img.o: dump_img.c libgraph.h ../../runtime/caml/mlvalues.h \ - ../../runtime/caml/config.h ../../runtime/caml/m.h \ - ../../runtime/caml/s.h ../../runtime/caml/misc.h \ - ../../runtime/caml/misc.h image.h ../../runtime/caml/alloc.h \ - ../../runtime/caml/mlvalues.h ../../runtime/caml/memory.h -events.o: events.c libgraph.h ../../runtime/caml/mlvalues.h \ - ../../runtime/caml/config.h ../../runtime/caml/m.h \ - ../../runtime/caml/s.h ../../runtime/caml/misc.h \ - ../../runtime/caml/misc.h ../../runtime/caml/alloc.h \ - ../../runtime/caml/mlvalues.h ../../runtime/caml/signals.h -fill.o: fill.c libgraph.h ../../runtime/caml/mlvalues.h \ - ../../runtime/caml/config.h ../../runtime/caml/m.h \ - ../../runtime/caml/s.h ../../runtime/caml/misc.h \ - ../../runtime/caml/misc.h ../../runtime/caml/memory.h \ - ../../runtime/caml/mlvalues.h -image.o: image.c libgraph.h ../../runtime/caml/mlvalues.h \ - ../../runtime/caml/config.h ../../runtime/caml/m.h \ - ../../runtime/caml/s.h ../../runtime/caml/misc.h \ - ../../runtime/caml/misc.h image.h ../../runtime/caml/alloc.h \ - ../../runtime/caml/mlvalues.h ../../runtime/caml/custom.h -make_img.o: make_img.c libgraph.h ../../runtime/caml/mlvalues.h \ - ../../runtime/caml/config.h ../../runtime/caml/m.h \ - ../../runtime/caml/s.h ../../runtime/caml/misc.h \ - ../../runtime/caml/misc.h image.h ../../runtime/caml/memory.h \ - ../../runtime/caml/mlvalues.h -open.o: open.c libgraph.h ../../runtime/caml/mlvalues.h \ - ../../runtime/caml/config.h ../../runtime/caml/m.h \ - ../../runtime/caml/s.h ../../runtime/caml/misc.h \ - ../../runtime/caml/misc.h ../../runtime/caml/alloc.h \ - ../../runtime/caml/mlvalues.h ../../runtime/caml/callback.h \ - ../../runtime/caml/fail.h ../../runtime/caml/memory.h -point_col.o: point_col.c libgraph.h ../../runtime/caml/mlvalues.h \ - ../../runtime/caml/config.h ../../runtime/caml/m.h \ - ../../runtime/caml/s.h ../../runtime/caml/misc.h \ - ../../runtime/caml/misc.h -sound.o: sound.c libgraph.h ../../runtime/caml/mlvalues.h \ - ../../runtime/caml/config.h ../../runtime/caml/m.h \ - ../../runtime/caml/s.h ../../runtime/caml/misc.h \ - ../../runtime/caml/misc.h -subwindow.o: subwindow.c libgraph.h ../../runtime/caml/mlvalues.h \ - ../../runtime/caml/config.h ../../runtime/caml/m.h \ - ../../runtime/caml/s.h ../../runtime/caml/misc.h \ - ../../runtime/caml/misc.h -text.o: text.c libgraph.h ../../runtime/caml/mlvalues.h \ - ../../runtime/caml/config.h ../../runtime/caml/m.h \ - ../../runtime/caml/s.h ../../runtime/caml/misc.h \ - ../../runtime/caml/misc.h ../../runtime/caml/alloc.h \ - ../../runtime/caml/mlvalues.h -graphics.cmo : \ - graphics.cmi -graphics.cmx : \ - graphics.cmi -graphics.cmi : -graphicsX11.cmo : \ - graphics.cmi \ - graphicsX11.cmi -graphicsX11.cmx : \ - graphics.cmx \ - graphicsX11.cmi -graphicsX11.cmi : diff --git a/otherlibs/graph/Makefile b/otherlibs/graph/Makefile deleted file mode 100644 index fee153f6..00000000 --- a/otherlibs/graph/Makefile +++ /dev/null @@ -1,34 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -#* * -#* Copyright 1999 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -# Makefile for the portable graphics library - -LIBNAME=graphics -COBJS=open.o draw.o fill.o color.o text.o \ - image.o make_img.o dump_img.o point_col.o sound.o events.o \ - subwindow.o -CAMLOBJS=graphics.cmo graphicsX11.cmo -LINKOPTS=-cclib "\"$(X11_LINK)\"" -LDOPTS=-ldopt "$(X11_LINK)" - -EXTRACFLAGS=$(X11_INCLUDES) - -include ../Makefile.otherlibs.common - -depend: - $(CC) -MM $(OC_CPPFLAGS) *.c | sed -e 's, /[^ ]*\.h,,g' > .depend - $(CAMLRUN) $(ROOTDIR)/boot/ocamlc -depend -slash *.mli *.ml >> .depend - -include .depend diff --git a/otherlibs/graph/color.c b/otherlibs/graph/color.c deleted file mode 100644 index 5d7bafc7..00000000 --- a/otherlibs/graph/color.c +++ /dev/null @@ -1,233 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include "libgraph.h" -#include - -/* Cache to speed up the translation rgb -> pixel value. */ - -struct color_cache_entry { - int rgb; /* RGB value with format 0xRRGGBB */ - unsigned long pixel; /* Pixel value */ -}; - -#define Color_cache_size 512 -static struct color_cache_entry color_cache[Color_cache_size]; -#define Empty (-1) -#define Hash_rgb(r,g,b) \ - ((((r) & 0xE0) << 1) + (((g) & 0xE0) >> 2) + (((b) & 0xE0) >> 5)) -#define Color_cache_slack 16 - -static int num_overflows = 0; - -/* rgb -> pixel conversion *without* display connection */ - -Bool caml_gr_direct_rgb = False; -int caml_gr_red_l, caml_gr_red_r; -int caml_gr_green_l, caml_gr_green_r; -int caml_gr_blue_l, caml_gr_blue_r; -unsigned long caml_gr_red_mask, caml_gr_green_mask, caml_gr_blue_mask; - -/* rgb -> pixel table */ -unsigned long caml_gr_red_vals[256]; -unsigned long caml_gr_green_vals[256]; -unsigned long caml_gr_blue_vals[256]; - -void caml_gr_get_shifts( unsigned long mask, int *lsl, int *lsr ) -{ - int l = 0; - int r = 0; - int bit = 1; - if ( mask == 0 ){ *lsl = -1; *lsr = -1; return; } - - for( l = 0; l < 32; l++ ){ - if( bit & mask ){ break; } - bit = bit << 1; - } - for( r = l; r < 32; r++ ){ - if( ! (bit & mask) ){ break; } - bit = bit << 1; - } - /* fix r */ - if ( r == 32 ) { r = 31; } - *lsl = l; - *lsr = 16 - (r - l); -} - -void caml_gr_init_direct_rgb_to_pixel(void) -{ - Visual *visual; - int i; - - visual = DefaultVisual(caml_gr_display,caml_gr_screen); - - if ( visual->class == TrueColor || visual->class == DirectColor ){ - - caml_gr_red_mask = visual->red_mask; - caml_gr_green_mask = visual->green_mask; - caml_gr_blue_mask = visual->blue_mask; - -#ifdef QUICKCOLORDEBUG - fprintf(stderr, "visual %lx %lx %lx\n", - caml_gr_red_mask, - caml_gr_green_mask, - caml_gr_blue_mask); -#endif - - caml_gr_get_shifts(caml_gr_red_mask, &caml_gr_red_l, &caml_gr_red_r); -#ifdef QUICKCOLORDEBUG - fprintf(stderr, "red %d %d\n", caml_gr_red_l, caml_gr_red_r); -#endif - for(i=0; i<256; i++){ - caml_gr_red_vals[i] = (((i << 8) + i) >> caml_gr_red_r) << caml_gr_red_l; - } - - caml_gr_get_shifts(caml_gr_green_mask, &caml_gr_green_l, &caml_gr_green_r); -#ifdef QUICKCOLORDEBUG - fprintf(stderr, "green %d %d\n", caml_gr_green_l, caml_gr_green_r); -#endif - for(i=0; i<256; i++){ - caml_gr_green_vals[i] = - (((i << 8) + i) >> caml_gr_green_r) << caml_gr_green_l; - } - - caml_gr_get_shifts(caml_gr_blue_mask, &caml_gr_blue_l, &caml_gr_blue_r); -#ifdef QUICKCOLORDEBUG - fprintf(stderr, "blue %d %d\n", caml_gr_blue_l, caml_gr_blue_r); -#endif - for(i=0; i<256; i++){ - caml_gr_blue_vals[i] = - (((i << 8) + i) >> caml_gr_blue_r) << caml_gr_blue_l; - } - - if( caml_gr_red_l < 0 || caml_gr_red_r < 0 || - caml_gr_green_l < 0 || caml_gr_green_r < 0 || - caml_gr_blue_l < 0 || caml_gr_blue_r < 0 ){ -#ifdef QUICKCOLORDEBUG - fprintf(stderr, "Damn, boost failed\n"); -#endif - caml_gr_direct_rgb = False; - } else { -#ifdef QUICKCOLORDEBUG - fprintf(stderr, "Boost ok\n"); -#endif - caml_gr_direct_rgb = True; - } - } else { - /* we cannot use direct_rgb_to_pixel */ -#ifdef QUICKCOLORDEBUG - fprintf(stderr, "No boost!\n"); -#endif - caml_gr_direct_rgb = False; - } -} - -void caml_gr_init_color_cache(void) -{ - int i; - for (i = 0; i < Color_cache_size; i++) color_cache[i].rgb = Empty; - i = Hash_rgb(0, 0, 0); - color_cache[i].rgb = 0; - color_cache[i].pixel = caml_gr_black; - i = Hash_rgb(0xFF, 0xFF, 0xFF); - color_cache[i].rgb = 0xFFFFFF; - color_cache[i].pixel = caml_gr_white; -} - -unsigned long caml_gr_pixel_rgb(int rgb) -{ - unsigned int r, g, b; - int h, i; - XColor color; - - r = (rgb >> 16) & 0xFF; - g = (rgb >> 8) & 0xFF; - b = rgb & 0xFF; - - if (caml_gr_direct_rgb){ - return caml_gr_red_vals[r] | caml_gr_green_vals[g] | caml_gr_blue_vals[b]; - } - - h = Hash_rgb(r, g, b); - i = h; - while(1) { - if (color_cache[i].rgb == Empty) break; - if (color_cache[i].rgb == rgb) return color_cache[i].pixel; - i = (i + 1) & (Color_cache_size - 1); - if (i == h) { - /* Cache is full. Instead of inserting at slot h, which causes - thrashing if many colors hash to the same value, - insert at h + n where n is pseudo-random and - smaller than Color_cache_slack */ - int slack = num_overflows++ & (Color_cache_slack - 1); - i = (i + slack) & (Color_cache_size - 1); - break; - } - } - color.red = r * 0x101; - color.green = g * 0x101; - color.blue = b * 0x101; - XAllocColor(caml_gr_display, caml_gr_colormap, &color); - color_cache[i].rgb = rgb; - color_cache[i].pixel = color.pixel; - return color.pixel; -} - -int caml_gr_rgb_pixel(long unsigned int pixel) -{ - register int r,g,b; - - XColor color; - int i; - - if (caml_gr_direct_rgb) { - r = (((pixel & caml_gr_red_mask) >> caml_gr_red_l) << 8) - >> (16 - caml_gr_red_r); - g = (((pixel & caml_gr_green_mask) >> caml_gr_green_l) << 8) - >> (16 - caml_gr_green_r); - b = (((pixel & caml_gr_blue_mask) >> caml_gr_blue_l) << 8) - >> (16 - caml_gr_blue_r); - return (r << 16) + (g << 8) + b; - } - - if (pixel == caml_gr_black) return 0; - if (pixel == caml_gr_white) return 0xFFFFFF; - - /* Probably faster to do a linear search than to query the X server. */ - for (i = 0; i < Color_cache_size; i++) { - if (color_cache[i].rgb != Empty && color_cache[i].pixel == pixel) - return color_cache[i].rgb; - } - color.pixel = pixel; - XQueryColor(caml_gr_display, caml_gr_colormap, &color); - return - ((color.red >> 8) << 16) + ((color.green >> 8) << 8) + (color.blue >> 8); -} - -value caml_gr_set_color(value vrgb) -{ - int xcolor; - caml_gr_check_open(); - caml_gr_color = Int_val(vrgb); - if (caml_gr_color >= 0 ){ - xcolor = caml_gr_pixel_rgb(Int_val(vrgb)); - XSetForeground(caml_gr_display, caml_gr_window.gc, xcolor); - XSetForeground(caml_gr_display, caml_gr_bstore.gc, xcolor); - } else { - XSetForeground(caml_gr_display, caml_gr_window.gc, caml_gr_background); - XSetForeground(caml_gr_display, caml_gr_bstore.gc, caml_gr_background); - } - return Val_unit; -} diff --git a/otherlibs/graph/draw.c b/otherlibs/graph/draw.c deleted file mode 100644 index 6e0f9373..00000000 --- a/otherlibs/graph/draw.c +++ /dev/null @@ -1,127 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include "libgraph.h" -#include - -value caml_gr_plot(value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - caml_gr_check_open(); - if(caml_gr_remember_modeflag) - XDrawPoint(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, x, - Bcvt(y)); - if(caml_gr_display_modeflag) { - XDrawPoint(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, x, - Wcvt(y)); - XFlush(caml_gr_display); - } - return Val_unit; -} - -value caml_gr_moveto(value vx, value vy) -{ - caml_gr_x = Int_val(vx); - caml_gr_y = Int_val(vy); - return Val_unit; -} - -value caml_gr_current_x(void) -{ - return Val_int(caml_gr_x); -} - -value caml_gr_current_y(void) -{ - return Val_int(caml_gr_y); -} - -value caml_gr_lineto(value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - caml_gr_check_open(); - if(caml_gr_remember_modeflag) - XDrawLine(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, - caml_gr_x, Bcvt(caml_gr_y), x, Bcvt(y)); - if(caml_gr_display_modeflag) { - XDrawLine(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, - caml_gr_x, Wcvt(caml_gr_y), x, Wcvt(y)); - XFlush(caml_gr_display); - } - caml_gr_x = x; - caml_gr_y = y; - return Val_unit; -} - -value caml_gr_draw_rect(value vx, value vy, value vw, value vh) -{ - int x = Int_val(vx); - int y = Int_val(vy); - int w = Int_val(vw); - int h = Int_val(vh); - - caml_gr_check_open(); - if(caml_gr_remember_modeflag) - XDrawRectangle(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, - x, Bcvt(y) - h, w, h); - if(caml_gr_display_modeflag) { - XDrawRectangle(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, - x, Wcvt(y) - h, w, h); - XFlush(caml_gr_display); - } - return Val_unit; -} - -value caml_gr_draw_arc_nat(value vx, value vy, value vrx, value vry, value va1, - value va2) -{ - int x = Int_val(vx); - int y = Int_val(vy); - int rx = Int_val(vrx); - int ry = Int_val(vry); - int a1 = Int_val(va1); - int a2 = Int_val(va2); - - caml_gr_check_open(); - if(caml_gr_remember_modeflag) - XDrawArc(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, - x - rx, Bcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64); - if(caml_gr_display_modeflag) { - XDrawArc(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, - x - rx, Wcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64); - XFlush(caml_gr_display); - } - return Val_unit; -} - -value caml_gr_draw_arc(value *argv, int argc) -{ - return caml_gr_draw_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], - argv[5]); -} - -value caml_gr_set_line_width(value vwidth) -{ - int width = Int_val(vwidth); - - caml_gr_check_open(); - XSetLineAttributes(caml_gr_display, caml_gr_window.gc, - width, LineSolid, CapRound, JoinRound); - XSetLineAttributes(caml_gr_display, caml_gr_bstore.gc, - width, LineSolid, CapRound, JoinRound); - return Val_unit; -} diff --git a/otherlibs/graph/dump_img.c b/otherlibs/graph/dump_img.c deleted file mode 100644 index 6d9be709..00000000 --- a/otherlibs/graph/dump_img.c +++ /dev/null @@ -1,58 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include "libgraph.h" -#include "image.h" -#include -#include - -value caml_gr_dump_image(value image) -{ - int width, height, i, j; - XImage * idata, * imask; - value m = Val_unit; - - Begin_roots2(image, m); - caml_gr_check_open(); - width = Width_im(image); - height = Height_im(image); - m = caml_alloc(height, 0); - for (i = 0; i < height; i++) { - value v = caml_alloc(width, 0); - caml_modify(&Field(m, i), v); - } - - idata = - XGetImage(caml_gr_display, Data_im(image), 0, 0, width, height, (-1), - ZPixmap); - for (i = 0; i < height; i++) - for (j = 0; j < width; j++) - Field(Field(m, i), j) = - Val_int(caml_gr_rgb_pixel(XGetPixel(idata, j, i))); - XDestroyImage(idata); - - if (Mask_im(image) != None) { - imask = - XGetImage(caml_gr_display, Mask_im(image), 0, 0, width, height, 1, - ZPixmap); - for (i = 0; i < height; i++) - for (j = 0; j < width; j++) - if (XGetPixel(imask, j, i) == 0) - Field(Field(m, i), j) = Val_int(Transparent); - XDestroyImage(imask); - } - End_roots(); - return m; -} diff --git a/otherlibs/graph/events.c b/otherlibs/graph/events.c deleted file mode 100644 index b858b037..00000000 --- a/otherlibs/graph/events.c +++ /dev/null @@ -1,279 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#define CAML_INTERNALS - -#include -#include "libgraph.h" -#include -#include -#include -#include -#ifdef HAS_SYS_SELECT_H -#include -#endif -#include -#include - -struct event_data { - short kind; - short mouse_x, mouse_y; - unsigned char button; - unsigned char key; -}; - -static struct event_data caml_gr_queue[SIZE_QUEUE]; -static unsigned int caml_gr_head = 0; /* position of next read */ -static unsigned int caml_gr_tail = 0; /* position of next write */ - -#define QueueIsEmpty (caml_gr_tail == caml_gr_head) - -static void caml_gr_enqueue_event(int kind, int mouse_x, int mouse_y, - int button, int key) -{ - struct event_data * ev; - - ev = &(caml_gr_queue[caml_gr_tail]); - ev->kind = kind; - ev->mouse_x = mouse_x; - ev->mouse_y = mouse_y; - ev->button = (button != 0); - ev->key = key; - caml_gr_tail = (caml_gr_tail + 1) % SIZE_QUEUE; - /* If queue was full, it now appears empty; drop oldest entry from queue. */ - if (QueueIsEmpty) caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE; -} - -#define BUTTON_STATE(state) \ - ((state) & (Button1Mask|Button2Mask|Button3Mask|Button4Mask|Button5Mask)) - -void caml_gr_handle_event(XEvent * event) -{ - switch (event->type) { - - case Expose: - XCopyArea(caml_gr_display, caml_gr_bstore.win, caml_gr_window.win, - caml_gr_window.gc, - event->xexpose.x, - event->xexpose.y + caml_gr_bstore.h - caml_gr_window.h, - event->xexpose.width, event->xexpose.height, - event->xexpose.x, event->xexpose.y); - XFlush(caml_gr_display); - break; - - case ConfigureNotify: - caml_gr_window.w = event->xconfigure.width; - caml_gr_window.h = event->xconfigure.height; - if (caml_gr_window.w > caml_gr_bstore.w - || caml_gr_window.h > caml_gr_bstore.h) { - - /* Allocate a new backing store large enough to accommodate - both the old backing store and the current window. */ - struct canvas newbstore; - newbstore.w = max(caml_gr_window.w, caml_gr_bstore.w); - newbstore.h = max(caml_gr_window.h, caml_gr_bstore.h); - newbstore.win = - XCreatePixmap(caml_gr_display, caml_gr_window.win, newbstore.w, - newbstore.h, - XDefaultDepth(caml_gr_display, caml_gr_screen)); - newbstore.gc = XCreateGC(caml_gr_display, newbstore.win, 0, NULL); - XSetBackground(caml_gr_display, newbstore.gc, caml_gr_white); - XSetForeground(caml_gr_display, newbstore.gc, caml_gr_white); - XFillRectangle(caml_gr_display, newbstore.win, newbstore.gc, - 0, 0, newbstore.w, newbstore.h); - XSetForeground(caml_gr_display, newbstore.gc, caml_gr_color); - if (caml_gr_font != NULL) - XSetFont(caml_gr_display, newbstore.gc, caml_gr_font->fid); - - /* Copy the old backing store into the new one */ - XCopyArea(caml_gr_display, caml_gr_bstore.win, newbstore.win, - newbstore.gc, - 0, 0, caml_gr_bstore.w, caml_gr_bstore.h, 0, - newbstore.h - caml_gr_bstore.h); - - /* Free the old backing store */ - XFreeGC(caml_gr_display, caml_gr_bstore.gc); - XFreePixmap(caml_gr_display, caml_gr_bstore.win); - - /* Use the new backing store */ - caml_gr_bstore = newbstore; - XFlush(caml_gr_display); - } - break; - - case MappingNotify: - XRefreshKeyboardMapping(&(event->xmapping)); - break; - - case KeyPress: - { KeySym thekey; - char keytxt[256]; - int nchars; - char * p; - nchars = XLookupString(&(event->xkey), keytxt, sizeof(keytxt), - &thekey, 0); - for (p = keytxt; nchars > 0; p++, nchars--) - caml_gr_enqueue_event(event->type, event->xkey.x, event->xkey.y, - BUTTON_STATE(event->xkey.state), *p); - break; - } - - case ButtonPress: - case ButtonRelease: - caml_gr_enqueue_event(event->type, event->xbutton.x, event->xbutton.y, - event->type == ButtonPress, 0); - break; - - case MotionNotify: - caml_gr_enqueue_event(event->type, event->xmotion.x, event->xmotion.y, - BUTTON_STATE(event->xmotion.state), 0); - break; - } -} - -static value caml_gr_wait_allocate_result(int mouse_x, int mouse_y, int button, - int keypressed, int key) -{ - value res = caml_alloc_small(5, 0); - Field(res, 0) = Val_int(mouse_x); - Field(res, 1) = Val_int(mouse_y == -1 ? -1 : Wcvt(mouse_y)); - Field(res, 2) = Val_bool(button); - Field(res, 3) = Val_bool(keypressed); - Field(res, 4) = Val_int(key & 0xFF); - return res; -} - -static value caml_gr_wait_event_poll(void) -{ - int mouse_x, mouse_y, button, key, keypressed; - Window rootwin, childwin; - int root_x, root_y, win_x, win_y; - unsigned int modifiers; - unsigned int i; - - caml_process_pending_signals (); - if (XQueryPointer(caml_gr_display, caml_gr_window.win, - &rootwin, &childwin, - &root_x, &root_y, &win_x, &win_y, - &modifiers)) { - mouse_x = win_x; - mouse_y = win_y; - } else { - mouse_x = -1; - mouse_y = -1; - } - button = modifiers & (Button1Mask | Button2Mask | Button3Mask - | Button4Mask | Button5Mask); - /* Look inside event queue for pending KeyPress events */ - key = 0; - keypressed = False; - for (i = caml_gr_head; i != caml_gr_tail; i = (i + 1) % SIZE_QUEUE) { - if (caml_gr_queue[i].kind == KeyPress) { - keypressed = True; - key = caml_gr_queue[i].key; - break; - } - } - return - caml_gr_wait_allocate_result(mouse_x, mouse_y, button, keypressed, key); -} - -static value caml_gr_wait_event_in_queue(long mask) -{ - struct event_data * ev; - /* Pop events in queue until one matches mask. */ - while (caml_gr_head != caml_gr_tail) { - ev = &(caml_gr_queue[caml_gr_head]); - caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE; - if ((ev->kind == KeyPress && (mask & KeyPressMask)) - || (ev->kind == ButtonPress && (mask & ButtonPressMask)) - || (ev->kind == ButtonRelease && (mask & ButtonReleaseMask)) - || (ev->kind == MotionNotify && (mask & PointerMotionMask))) - return caml_gr_wait_allocate_result(ev->mouse_x, ev->mouse_y, - ev->button, ev->kind == KeyPress, - ev->key); - } - return Val_false; -} - -static value caml_gr_wait_event_blocking(long mask) -{ - XEvent event; - fd_set readfds; - value res; - - /* First see if we have a matching event in the queue */ - res = caml_gr_wait_event_in_queue(mask); - if (res != Val_false) return res; - - /* Increase the selected events if required */ - if ((mask & ~caml_gr_selected_events) != 0) { - caml_gr_selected_events |= mask; - XSelectInput(caml_gr_display, caml_gr_window.win, caml_gr_selected_events); - } - - /* Replenish our event queue from that of X11 */ - caml_gr_ignore_sigio = True; - while (1) { - if (XCheckMaskEvent(caml_gr_display, -1 /*all events*/, &event)) { - /* One event available: add it to our queue */ - caml_gr_handle_event(&event); - /* See if we now have a matching event */ - res = caml_gr_wait_event_in_queue(mask); - if (res != Val_false) break; - } else { - /* No event available: block on input socket until one is */ - FD_ZERO(&readfds); - FD_SET(ConnectionNumber(caml_gr_display), &readfds); - caml_enter_blocking_section(); - select(FD_SETSIZE, &readfds, NULL, NULL, NULL); - caml_leave_blocking_section(); - caml_gr_check_open(); /* in case another thread closed the display */ - } - } - caml_gr_ignore_sigio = False; - - /* Return result */ - return res; -} - -value caml_gr_wait_event(value eventlist) /* ML */ -{ - int mask; - Bool poll; - - caml_gr_check_open(); - mask = 0; - poll = False; - while (eventlist != Val_int(0)) { - switch (Int_val(Field(eventlist, 0))) { - case 0: /* Button_down */ - mask |= ButtonPressMask | OwnerGrabButtonMask; break; - case 1: /* Button_up */ - mask |= ButtonReleaseMask | OwnerGrabButtonMask; break; - case 2: /* Key_pressed */ - mask |= KeyPressMask; break; - case 3: /* Mouse_motion */ - mask |= PointerMotionMask; break; - case 4: /* Poll */ - poll = True; break; - } - eventlist = Field(eventlist, 1); - } - if (poll) - return caml_gr_wait_event_poll(); - else - return caml_gr_wait_event_blocking(mask); -} diff --git a/otherlibs/graph/fill.c b/otherlibs/graph/fill.c deleted file mode 100644 index 0eb307f9..00000000 --- a/otherlibs/graph/fill.c +++ /dev/null @@ -1,90 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include "libgraph.h" -#include - -value caml_gr_fill_rect(value vx, value vy, value vw, value vh) -{ - int x = Int_val(vx); - int y = Int_val(vy); - int w = Int_val(vw); - int h = Int_val(vh); - - caml_gr_check_open(); - if(caml_gr_remember_modeflag) - XFillRectangle(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, - x, Bcvt(y) - h, w + 1, h + 1); - if(caml_gr_display_modeflag) { - XFillRectangle(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, - x, Wcvt(y) - h, w + 1, h + 1); - XFlush(caml_gr_display); - } - return Val_unit; -} - -value caml_gr_fill_poly(value array) -{ - XPoint * points; - int npoints, i; - - caml_gr_check_open(); - npoints = Wosize_val(array); - points = (XPoint *) caml_stat_alloc(npoints * sizeof(XPoint)); - for (i = 0; i < npoints; i++) { - points[i].x = Int_val(Field(Field(array, i), 0)); - points[i].y = Bcvt(Int_val(Field(Field(array, i), 1))); - } - if(caml_gr_remember_modeflag) - XFillPolygon(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, points, - npoints, Complex, CoordModeOrigin); - if(caml_gr_display_modeflag) { - for (i = 0; i < npoints; i++) - points[i].y = BtoW(points[i].y); - XFillPolygon(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, points, - npoints, Complex, CoordModeOrigin); - XFlush(caml_gr_display); - } - caml_stat_free((char *) points); - return Val_unit; -} - -value caml_gr_fill_arc_nat(value vx, value vy, value vrx, value vry, value va1, - value va2) -{ - int x = Int_val(vx); - int y = Int_val(vy); - int rx = Int_val(vrx); - int ry = Int_val(vry); - int a1 = Int_val(va1); - int a2 = Int_val(va2); - - caml_gr_check_open(); - if(caml_gr_remember_modeflag) - XFillArc(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, - x - rx, Bcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64); - if(caml_gr_display_modeflag) { - XFillArc(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, - x - rx, Wcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64); - XFlush(caml_gr_display); - } - return Val_unit; -} - -value caml_gr_fill_arc(value *argv, int argc) -{ - return caml_gr_fill_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], - argv[5]); -} diff --git a/otherlibs/graph/graphics.ml b/otherlibs/graph/graphics.ml deleted file mode 100644 index 36328986..00000000 --- a/otherlibs/graph/graphics.ml +++ /dev/null @@ -1,266 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -exception Graphic_failure of string - -(* Initializations *) - -let _ = - Callback.register_exception "Graphics.Graphic_failure" (Graphic_failure "") - -external raw_open_graph: string -> unit = "caml_gr_open_graph" -external raw_close_graph: unit -> unit = "caml_gr_close_graph" -external sigio_signal: unit -> int = "caml_gr_sigio_signal" -external sigio_handler: int -> unit = "caml_gr_sigio_handler" - -let unix_open_graph arg = - Sys.set_signal (sigio_signal()) (Sys.Signal_handle sigio_handler); - raw_open_graph arg - -let unix_close_graph () = - Sys.set_signal (sigio_signal()) Sys.Signal_ignore; - raw_close_graph () - -let (open_graph, close_graph) = - match Sys.os_type with - | "Unix" | "Cygwin" -> (unix_open_graph, unix_close_graph) - | "Win32" -> (raw_open_graph, raw_close_graph) - | "MacOS" -> (raw_open_graph, raw_close_graph) - | _ -> invalid_arg ("Graphics: unknown OS type: " ^ Sys.os_type) - -external set_window_title : string -> unit = "caml_gr_set_window_title" -external resize_window : int -> int -> unit = "caml_gr_resize_window" -external clear_graph : unit -> unit = "caml_gr_clear_graph" -external size_x : unit -> int = "caml_gr_size_x" -external size_y : unit -> int = "caml_gr_size_y" - -(* Double-buffering *) - -external display_mode : bool -> unit = "caml_gr_display_mode" -external remember_mode : bool -> unit = "caml_gr_remember_mode" -external synchronize : unit -> unit = "caml_gr_synchronize" - -let auto_synchronize = function - | true -> display_mode true; remember_mode true; synchronize () - | false -> display_mode false; remember_mode true -;; - - -(* Colors *) - -type color = int - -let rgb r g b = (r lsl 16) + (g lsl 8) + b - -external set_color : color -> unit = "caml_gr_set_color" - -let black = 0x000000 -and white = 0xFFFFFF -and red = 0xFF0000 -and green = 0x00FF00 -and blue = 0x0000FF -and yellow = 0xFFFF00 -and cyan = 0x00FFFF -and magenta = 0xFF00FF - -let background = white -and foreground = black - -(* Drawing *) - -external plot : int -> int -> unit = "caml_gr_plot" -let plots points = - for i = 0 to Array.length points - 1 do - let (x, y) = points.(i) in - plot x y; - done -;; -external point_color : int -> int -> color = "caml_gr_point_color" -external moveto : int -> int -> unit = "caml_gr_moveto" -external current_x : unit -> int = "caml_gr_current_x" -external current_y : unit -> int = "caml_gr_current_y" -let current_point () = current_x (), current_y () -external lineto : int -> int -> unit = "caml_gr_lineto" -let rlineto x y = lineto (current_x () + x) (current_y () + y) -let rmoveto x y = moveto (current_x () + x) (current_y () + y) - -external raw_draw_rect : int -> int -> int -> int -> unit = "caml_gr_draw_rect" -let draw_rect x y w h = - if w < 0 || h < 0 then raise (Invalid_argument "draw_rect") - else raw_draw_rect x y w h -;; - -let draw_poly, draw_poly_line = - let dodraw close_flag points = - if Array.length points > 0 then begin - let (savex, savey) = current_point () in - moveto (fst points.(0)) (snd points.(0)); - for i = 1 to Array.length points - 1 do - let (x, y) = points.(i) in - lineto x y; - done; - if close_flag then lineto (fst points.(0)) (snd points.(0)); - moveto savex savey; - end; - in dodraw true, dodraw false -;; -let draw_segments segs = - let (savex, savey) = current_point () in - for i = 0 to Array.length segs - 1 do - let (x1, y1, x2, y2) = segs.(i) in - moveto x1 y1; - lineto x2 y2; - done; - moveto savex savey; -;; - -external raw_draw_arc : int -> int -> int -> int -> int -> int -> unit - = "caml_gr_draw_arc" "caml_gr_draw_arc_nat" -let draw_arc x y rx ry a1 a2 = - if rx < 0 || ry < 0 then raise (Invalid_argument "draw_arc/ellipse/circle") - else raw_draw_arc x y rx ry a1 a2 -;; - -let draw_ellipse x y rx ry = draw_arc x y rx ry 0 360 -let draw_circle x y r = draw_arc x y r r 0 360 - -external raw_set_line_width : int -> unit = "caml_gr_set_line_width" -let set_line_width w = - if w < 0 then raise (Invalid_argument "set_line_width") - else raw_set_line_width w -;; - -external raw_fill_rect : int -> int -> int -> int -> unit = "caml_gr_fill_rect" -let fill_rect x y w h = - if w < 0 || h < 0 then raise (Invalid_argument "fill_rect") - else raw_fill_rect x y w h -;; - -external fill_poly : (int * int) array -> unit = "caml_gr_fill_poly" -external raw_fill_arc : int -> int -> int -> int -> int -> int -> unit - = "caml_gr_fill_arc" "caml_gr_fill_arc_nat" -let fill_arc x y rx ry a1 a2 = - if rx < 0 || ry < 0 then raise (Invalid_argument "fill_arc/ellipse/circle") - else raw_fill_arc x y rx ry a1 a2 -;; - -let fill_ellipse x y rx ry = fill_arc x y rx ry 0 360 -let fill_circle x y r = fill_arc x y r r 0 360 - -(* Text *) - -external draw_char : char -> unit = "caml_gr_draw_char" -external draw_string : string -> unit = "caml_gr_draw_string" -external set_font : string -> unit = "caml_gr_set_font" -external set_text_size : int -> unit = "caml_gr_set_text_size" -external text_size : string -> int * int = "caml_gr_text_size" - -(* Images *) - -type image - -let transp = -1 - -external make_image : color array array -> image = "caml_gr_make_image" -external dump_image : image -> color array array = "caml_gr_dump_image" -external draw_image : image -> int -> int -> unit = "caml_gr_draw_image" -external create_image : int -> int -> image = "caml_gr_create_image" -external blit_image : image -> int -> int -> unit = "caml_gr_blit_image" - -let get_image x y w h = - let image = create_image w h in - blit_image image x y; - image - -(* Events *) - -type status = - { mouse_x : int; - mouse_y : int; - button : bool; - keypressed : bool; - key : char } - -type event = - Button_down - | Button_up - | Key_pressed - | Mouse_motion - | Poll - -external wait_next_event : event list -> status = "caml_gr_wait_event" - -let mouse_pos () = - let e = wait_next_event [Poll] in (e.mouse_x, e.mouse_y) - -let button_down () = - let e = wait_next_event [Poll] in e.button - -let read_key () = - let e = wait_next_event [Key_pressed] in e.key - -let key_pressed () = - let e = wait_next_event [Poll] in e.keypressed - -let loop_at_exit events handler = - let events = List.filter (fun e -> e <> Poll) events in - at_exit (fun _ -> - try - while true do - let e = wait_next_event events in - handler e - done - with Exit -> close_graph () - | e -> close_graph (); raise e - ) - -(*** Sound *) - -external sound : int -> int -> unit = "caml_gr_sound" - -(* Splines *) -let sub (x1, y1) (x2, y2) = (x1 -. x2, y1 -. y2) -and middle (x1, y1) (x2, y2) = ((x1 +. x2) /. 2.0, (y1 +. y2) /. 2.0) -and area (x1, y1) (x2, y2) = abs_float (x1 *. y2 -. x2 *. y1) -and norm (x1, y1) = sqrt (x1 *. x1 +. y1 *. y1);; - -let test a b c d = - let v = sub d a in - let s = norm v in - area v (sub a b) <= s && area v (sub a c) <= s;; - -let spline a b c d = - let rec spl accu a b c d = - if test a b c d then d :: accu else - let a' = middle a b - and o = middle b c in - let b' = middle a' o - and d' = middle c d in - let c' = middle o d' in - let i = middle b' c' in - spl (spl accu a a' b' i) i c' d' d in - spl [a] a b c d;; - -let curveto b c (x, y as d) = - let float_point (x, y) = (float_of_int x, float_of_int y) in - let round f = int_of_float (f +. 0.5) in - let int_point (x, y) = (round x, round y) in - let points = - spline - (float_point (current_point ())) - (float_point b) (float_point c) (float_point d) in - draw_poly_line - (Array.of_list (List.map int_point points)); - moveto x y;; diff --git a/otherlibs/graph/graphics.mli b/otherlibs/graph/graphics.mli deleted file mode 100644 index 1acbd0d4..00000000 --- a/otherlibs/graph/graphics.mli +++ /dev/null @@ -1,391 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Machine-independent graphics primitives. *) - -exception Graphic_failure of string -(** Raised by the functions below when they encounter an error. *) - - -(** {1 Initializations} *) - -val open_graph : string -> unit -(** Show the graphics window or switch the screen to graphic mode. - The graphics window is cleared and the current point is set - to (0, 0). The string argument is used to pass optional - information on the desired graphics mode, the graphics window - size, and so on. Its interpretation is implementation-dependent. - If the empty string is given, a sensible default is selected. *) - -val close_graph : unit -> unit -(** Delete the graphics window or switch the screen back to text mode. *) - -val set_window_title : string -> unit -(** Set the title of the graphics window. *) - -val resize_window : int -> int -> unit -(** Resize and erase the graphics window. *) - -external clear_graph : unit -> unit = "caml_gr_clear_graph" -(** Erase the graphics window. *) - -external size_x : unit -> int = "caml_gr_size_x" -(** See {!Graphics.size_y}. *) - -external size_y : unit -> int = "caml_gr_size_y" -(** Return the size of the graphics window. Coordinates of the screen - pixels range over [0 .. size_x()-1] and [0 .. size_y()-1]. - Drawings outside of this rectangle are clipped, without causing - an error. The origin (0,0) is at the lower left corner. - Some implementation (e.g. X Windows) represent coordinates by - 16-bit integers, hence wrong clipping may occur with coordinates - below [-32768] or above [32676]. *) - -(** {1 Colors} *) - -type color = int -(** A color is specified by its R, G, B components. Each component - is in the range [0..255]. The three components are packed in - an [int]: [0xRRGGBB], where [RR] are the two hexadecimal digits for - the red component, [GG] for the green component, [BB] for the - blue component. *) - -val rgb : int -> int -> int -> color -(** [rgb r g b] returns the integer encoding the color with red - component [r], green component [g], and blue component [b]. - [r], [g] and [b] are in the range [0..255]. *) - -external set_color : color -> unit = "caml_gr_set_color" -(** Set the current drawing color. *) - -val background : color -(** See {!Graphics.foreground}.*) - -val foreground : color -(** Default background and foreground colors (usually, either black - foreground on a white background or white foreground on a - black background). - {!Graphics.clear_graph} fills the screen with the [background] color. - The initial drawing color is [foreground]. *) - - -(** {7 Some predefined colors} *) - -val black : color -val white : color -val red : color -val green : color -val blue : color -val yellow : color -val cyan : color -val magenta : color - - -(** {1 Point and line drawing} *) - -external plot : int -> int -> unit = "caml_gr_plot" -(** Plot the given point with the current drawing color. *) - -val plots : (int * int) array -> unit -(** Plot the given points with the current drawing color. *) - -external point_color : int -> int -> color = "caml_gr_point_color" -(** Return the color of the given point in the backing store - (see "Double buffering" below). *) - -external moveto : int -> int -> unit = "caml_gr_moveto" -(** Position the current point. *) - -val rmoveto : int -> int -> unit -(** [rmoveto dx dy] translates the current point by the given vector. *) - -external current_x : unit -> int = "caml_gr_current_x" -(** Return the abscissa of the current point. *) - -external current_y : unit -> int = "caml_gr_current_y" -(** Return the ordinate of the current point. *) - -val current_point : unit -> int * int -(** Return the position of the current point. *) - -external lineto : int -> int -> unit = "caml_gr_lineto" -(** Draw a line with endpoints the current point and the given point, - and move the current point to the given point. *) - -val rlineto : int -> int -> unit -(** Draw a line with endpoints the current point and the - current point translated of the given vector, - and move the current point to this point. *) - -val curveto : int * int -> int * int -> int * int -> unit -(** [curveto b c d] draws a cubic Bezier curve starting from - the current point to point [d], with control points [b] and - [c], and moves the current point to [d]. *) - -val draw_rect : int -> int -> int -> int -> unit -(** [draw_rect x y w h] draws the rectangle with lower left corner - at [x,y], width [w] and height [h]. - The current point is unchanged. - Raise [Invalid_argument] if [w] or [h] is negative. *) - -val draw_poly_line : (int * int) array -> unit -(** [draw_poly_line points] draws the line that joins the - points given by the array argument. - The array contains the coordinates of the vertices of the - polygonal line, which need not be closed. - The current point is unchanged. *) - -val draw_poly : (int * int) array -> unit -(** [draw_poly polygon] draws the given polygon. - The array contains the coordinates of the vertices of the - polygon. - The current point is unchanged. *) - -val draw_segments : (int * int * int * int) array -> unit -(** [draw_segments segments] draws the segments given in the array - argument. Each segment is specified as a quadruple - [(x0, y0, x1, y1)] where [(x0, y0)] and [(x1, y1)] are - the coordinates of the end points of the segment. - The current point is unchanged. *) - -val draw_arc : int -> int -> int -> int -> int -> int -> unit -(** [draw_arc x y rx ry a1 a2] draws an elliptical arc with center - [x,y], horizontal radius [rx], vertical radius [ry], from angle - [a1] to angle [a2] (in degrees). The current point is unchanged. - Raise [Invalid_argument] if [rx] or [ry] is negative. *) - -val draw_ellipse : int -> int -> int -> int -> unit -(** [draw_ellipse x y rx ry] draws an ellipse with center - [x,y], horizontal radius [rx] and vertical radius [ry]. - The current point is unchanged. - Raise [Invalid_argument] if [rx] or [ry] is negative. *) - -val draw_circle : int -> int -> int -> unit -(** [draw_circle x y r] draws a circle with center [x,y] and - radius [r]. The current point is unchanged. - Raise [Invalid_argument] if [r] is negative. *) - -val set_line_width : int -> unit -(** Set the width of points and lines drawn with the functions above. - Under X Windows, [set_line_width 0] selects a width of 1 pixel - and a faster, but less precise drawing algorithm than the one - used when [set_line_width 1] is specified. - Raise [Invalid_argument] if the argument is negative. *) - -(** {1 Text drawing} *) - -external draw_char : char -> unit = "caml_gr_draw_char" -(** See {!Graphics.draw_string}.*) - -external draw_string : string -> unit = "caml_gr_draw_string" -(** Draw a character or a character string with lower left corner - at current position. After drawing, the current position is set - to the lower right corner of the text drawn. *) - -external set_font : string -> unit = "caml_gr_set_font" -(** Set the font used for drawing text. - The interpretation of the argument to [set_font] - is implementation-dependent. *) - -val set_text_size : int -> unit -(** Set the character size used for drawing text. - The interpretation of the argument to [set_text_size] - is implementation-dependent. *) - -external text_size : string -> int * int = "caml_gr_text_size" -(** Return the dimensions of the given text, if it were drawn with - the current font and size. *) - - -(** {1 Filling} *) - -val fill_rect : int -> int -> int -> int -> unit -(** [fill_rect x y w h] fills the rectangle with lower left corner - at [x,y], width [w] and height [h], with the current color. - Raise [Invalid_argument] if [w] or [h] is negative. *) - -external fill_poly : (int * int) array -> unit = "caml_gr_fill_poly" -(** Fill the given polygon with the current color. The array - contains the coordinates of the vertices of the polygon. *) - -val fill_arc : int -> int -> int -> int -> int -> int -> unit -(** Fill an elliptical pie slice with the current color. The - parameters are the same as for {!Graphics.draw_arc}. *) - -val fill_ellipse : int -> int -> int -> int -> unit -(** Fill an ellipse with the current color. The - parameters are the same as for {!Graphics.draw_ellipse}. *) - -val fill_circle : int -> int -> int -> unit -(** Fill a circle with the current color. The - parameters are the same as for {!Graphics.draw_circle}. *) - - -(** {1 Images} *) - -type image -(** The abstract type for images, in internal representation. - Externally, images are represented as matrices of colors. - Images are bound to the current graphics window and should not be reused - after closing this graphics window with {!close_graph}. -*) - -val transp : color -(** In matrices of colors, this color represent a 'transparent' - point: when drawing the corresponding image, all pixels on the - screen corresponding to a transparent pixel in the image will - not be modified, while other points will be set to the color - of the corresponding point in the image. This allows superimposing - an image over an existing background. *) - -external make_image : color array array -> image = "caml_gr_make_image" -(** Convert the given color matrix to an image. - Each sub-array represents one horizontal line. All sub-arrays - must have the same length; otherwise, exception [Graphic_failure] - is raised. *) - -external dump_image : image -> color array array = "caml_gr_dump_image" -(** Convert an image to a color matrix. *) - -external draw_image : image -> int -> int -> unit = "caml_gr_draw_image" -(** Draw the given image with lower left corner at the given point. *) - -val get_image : int -> int -> int -> int -> image -(** Capture the contents of a rectangle on the screen as an image. - The parameters are the same as for {!Graphics.fill_rect}. *) - -external create_image : int -> int -> image = "caml_gr_create_image" -(** [create_image w h] returns a new image [w] pixels wide and [h] - pixels tall, to be used in conjunction with [blit_image]. - The initial image contents are random, except that no point - is transparent. *) - -external blit_image : image -> int -> int -> unit = "caml_gr_blit_image" -(** [blit_image img x y] copies screen pixels into the image [img], - modifying [img] in-place. The pixels copied are those inside the - rectangle with lower left corner at [x,y], and width and height - equal to those of the image. Pixels that were transparent in - [img] are left unchanged. *) - - -(** {1 Mouse and keyboard events} *) - -type status = - { mouse_x : int; (** X coordinate of the mouse *) - mouse_y : int; (** Y coordinate of the mouse *) - button : bool; (** true if a mouse button is pressed *) - keypressed : bool; (** true if a key has been pressed *) - key : char; (** the character for the key pressed *) - } -(** To report events. *) - - -type event = - Button_down (** A mouse button is pressed *) - | Button_up (** A mouse button is released *) - | Key_pressed (** A key is pressed *) - | Mouse_motion (** The mouse is moved *) - | Poll (** Don't wait; return immediately *) -(** To specify events to wait for. *) - - -external wait_next_event : event list -> status = "caml_gr_wait_event" -(** Wait until one of the events specified in the given event list - occurs, and return the status of the mouse and keyboard at - that time. If [Poll] is given in the event list, return immediately - with the current status. If the mouse cursor is outside of the - graphics window, the [mouse_x] and [mouse_y] fields of the event are - outside the range [0..size_x()-1, 0..size_y()-1]. Keypresses - are queued, and dequeued one by one when the [Key_pressed] - event is specified and the [Poll] event is not specified. *) - -val loop_at_exit : event list -> (status -> unit) -> unit -(** Loop before exiting the program, the list given as argument is the - list of handlers and the events on which these handlers are called. - To exit cleanly the loop, the handler should raise Exit. Any other - exception will be propagated outside of the loop. - @since 4.01 -*) - -(** {1 Mouse and keyboard polling} *) - -val mouse_pos : unit -> int * int -(** Return the position of the mouse cursor, relative to the - graphics window. If the mouse cursor is outside of the graphics - window, [mouse_pos()] returns a point outside of the range - [0..size_x()-1, 0..size_y()-1]. *) - -val button_down : unit -> bool -(** Return [true] if the mouse button is pressed, [false] otherwise. *) - -val read_key : unit -> char -(** Wait for a key to be pressed, and return the corresponding - character. Keypresses are queued. *) - -val key_pressed : unit -> bool -(** Return [true] if a keypress is available; that is, if [read_key] - would not block. *) - - -(** {1 Sound} *) - -external sound : int -> int -> unit = "caml_gr_sound" -(** [sound freq dur] plays a sound at frequency [freq] (in hertz) - for a duration [dur] (in milliseconds). *) - -(** {1 Double buffering} *) - -val auto_synchronize : bool -> unit -(** By default, drawing takes place both on the window displayed - on screen, and in a memory area (the 'backing store'). - The backing store image is used to re-paint the on-screen - window when necessary. - - To avoid flicker during animations, it is possible to turn - off on-screen drawing, perform a number of drawing operations - in the backing store only, then refresh the on-screen window - explicitly. - - [auto_synchronize false] turns on-screen drawing off. All - subsequent drawing commands are performed on the backing store - only. - - [auto_synchronize true] refreshes the on-screen window from - the backing store (as per [synchronize]), then turns on-screen - drawing back on. All subsequent drawing commands are performed - both on screen and in the backing store. - - The default drawing mode corresponds to [auto_synchronize true]. *) - -external synchronize : unit -> unit = "caml_gr_synchronize" -(** Synchronize the backing store and the on-screen window, by - copying the contents of the backing store onto the graphics - window. *) - - -external display_mode : bool -> unit = "caml_gr_display_mode" -(** Set display mode on or off. When turned on, drawings are done - in the graphics window; when turned off, drawings do not affect - the graphics window. This occurs independently of - drawing into the backing store (see the function {!Graphics.remember_mode} - below). Default display mode is on. *) - - -external remember_mode : bool -> unit = "caml_gr_remember_mode" -(** Set remember mode on or off. When turned on, drawings are done - in the backing store; when turned off, the backing store is - unaffected by drawings. This occurs independently of drawing - onto the graphics window (see the function {!Graphics.display_mode} above). - Default remember mode is on. *) diff --git a/otherlibs/graph/graphicsX11.ml b/otherlibs/graph/graphicsX11.ml deleted file mode 100644 index 10f39f32..00000000 --- a/otherlibs/graph/graphicsX11.ml +++ /dev/null @@ -1,42 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Weis and Jun Furuse, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Module [GraphicsX11]: additional graphics primitives for - the X Windows system *) - -type window_id = string - -external window_id : unit -> window_id = "caml_gr_window_id" - -let subwindows = Hashtbl.create 13 - -external open_subwindow : int -> int -> int -> int -> window_id - = "caml_gr_open_subwindow" -external close_subwindow : window_id -> unit - = "caml_gr_close_subwindow" - -let open_subwindow ~x ~y ~width ~height = - let wid = open_subwindow x y width height in - Hashtbl.add subwindows wid (); - wid -;; - -let close_subwindow wid = - if Hashtbl.mem subwindows wid then begin - close_subwindow wid; - Hashtbl.remove subwindows wid - end else - raise (Graphics.Graphic_failure("close_subwindow: no such subwindow: "^wid)) -;; diff --git a/otherlibs/graph/graphicsX11.mli b/otherlibs/graph/graphicsX11.mli deleted file mode 100644 index e0229996..00000000 --- a/otherlibs/graph/graphicsX11.mli +++ /dev/null @@ -1,30 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Weis and Jun Furuse, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Additional graphics primitives for the X Windows system. *) - -type window_id = string - -val window_id : unit -> window_id -(** Return the unique identifier of the OCaml graphics window. - The returned string is an unsigned 32 bits integer - in decimal form. *) - -val open_subwindow : x:int -> y:int -> width:int -> height:int -> window_id -(** Create a sub-window of the current OCaml graphics window - and return its identifier. *) - -val close_subwindow : window_id -> unit -(** Close the sub-window having the given identifier. *) diff --git a/otherlibs/graph/image.c b/otherlibs/graph/image.c deleted file mode 100644 index baa85540..00000000 --- a/otherlibs/graph/image.c +++ /dev/null @@ -1,109 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include "libgraph.h" -#include "image.h" -#include -#include - -static void caml_gr_free_image(value im) -{ - XFreePixmap(caml_gr_display, Data_im(im)); - if (Mask_im(im) != None) XFreePixmap(caml_gr_display, Mask_im(im)); -} - -static struct custom_operations image_ops = { - "_image", - caml_gr_free_image, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default, - custom_compare_ext_default, - custom_fixed_length_default -}; - -#define Max_image_mem 2000000 - -value caml_gr_new_image(int w, int h) -{ - value res = caml_alloc_custom(&image_ops, sizeof(struct grimage), - w * h, Max_image_mem); - Width_im(res) = w; - Height_im(res) = h; - Data_im(res) = XCreatePixmap(caml_gr_display, caml_gr_window.win, w, h, - XDefaultDepth(caml_gr_display, caml_gr_screen)); - Mask_im(res) = None; - return res; -} - -value caml_gr_create_image(value vw, value vh) -{ - caml_gr_check_open(); - return caml_gr_new_image(Int_val(vw), Int_val(vh)); -} - -value caml_gr_blit_image(value im, value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - caml_gr_check_open(); - XCopyArea(caml_gr_display, caml_gr_bstore.win, Data_im(im), caml_gr_bstore.gc, - x, Bcvt(y) + 1 - Height_im(im), - Width_im(im), Height_im(im), - 0, 0); - return Val_unit; -} - -value caml_gr_draw_image(value im, value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - int wy = Wcvt(y) + 1 - Height_im(im); - int by = Bcvt(y) + 1 - Height_im(im); - - caml_gr_check_open(); - if (Mask_im(im) != None) { - if(caml_gr_remember_modeflag) { - XSetClipOrigin(caml_gr_display, caml_gr_bstore.gc, x, by); - XSetClipMask(caml_gr_display, caml_gr_bstore.gc, Mask_im(im)); - } - if(caml_gr_display_modeflag) { - XSetClipOrigin(caml_gr_display, caml_gr_window.gc, x, wy); - XSetClipMask(caml_gr_display, caml_gr_window.gc, Mask_im(im)); - } - } - if(caml_gr_remember_modeflag) - XCopyArea(caml_gr_display, Data_im(im), caml_gr_bstore.win, - caml_gr_bstore.gc, - 0, 0, - Width_im(im), Height_im(im), - x, by); - if(caml_gr_display_modeflag) - XCopyArea(caml_gr_display, Data_im(im), caml_gr_window.win, - caml_gr_window.gc, - 0, 0, - Width_im(im), Height_im(im), - x, wy); - if (Mask_im(im) != None) { - if(caml_gr_remember_modeflag) - XSetClipMask(caml_gr_display, caml_gr_bstore.gc, None); - if(caml_gr_display_modeflag) - XSetClipMask(caml_gr_display, caml_gr_window.gc, None); - } - if(caml_gr_display_modeflag) - XFlush(caml_gr_display); - return Val_unit; -} diff --git a/otherlibs/graph/image.h b/otherlibs/graph/image.h deleted file mode 100644 index acb85110..00000000 --- a/otherlibs/graph/image.h +++ /dev/null @@ -1,29 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -struct grimage { - int width, height; /* Dimensions of the image */ - Pixmap data; /* Pixels */ - Pixmap mask; /* Mask for transparent points, or None */ -}; - -#define Width_im(i) (((struct grimage *)Data_custom_val(i))->width) -#define Height_im(i) (((struct grimage *)Data_custom_val(i))->height) -#define Data_im(i) (((struct grimage *)Data_custom_val(i))->data) -#define Mask_im(i) (((struct grimage *)Data_custom_val(i))->mask) - -#define Transparent (-1) - -value caml_gr_new_image(int w, int h); diff --git a/otherlibs/graph/libgraph.h b/otherlibs/graph/libgraph.h deleted file mode 100644 index e2dcb2bf..00000000 --- a/otherlibs/graph/libgraph.h +++ /dev/null @@ -1,89 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include -#include -#include -#include -#include - -struct canvas { - int w, h; /* Dimensions of the drawable */ - Drawable win; /* The drawable itself */ - GC gc; /* The associated graphics context */ -}; - -extern Display * caml_gr_display; /* The display connection */ -extern int caml_gr_screen; /* The screen number */ -extern Colormap caml_gr_colormap; /* The color map */ -extern struct canvas caml_gr_window; /* The graphics window */ -extern struct canvas caml_gr_bstore; /* The pixmap used for backing store */ -extern int caml_gr_white, caml_gr_black; /* Black and white pixels for X */ -extern int caml_gr_background; /* Background color for X - (used for CAML color -1) */ -extern Bool caml_gr_display_modeflag; /* Display-mode flag */ -extern Bool caml_gr_remember_modeflag; /* Remember-mode flag */ -extern int caml_gr_x, caml_gr_y; /* Coordinates of the current point */ -extern int caml_gr_color; /* Current *CAML* drawing color (can be -1) */ -extern XFontStruct * caml_gr_font; /* Current font */ -extern long caml_gr_selected_events; /* Events we are interested in */ -extern Bool caml_gr_ignore_sigio; /* Whether to consume events on sigio */ - -extern Bool caml_gr_direct_rgb; -extern int caml_gr_byte_order; -extern int caml_gr_bitmap_unit; -extern int caml_gr_bits_per_pixel; - -#define Wcvt(y) (caml_gr_window.h - 1 - (y)) -#define Bcvt(y) (caml_gr_bstore.h - 1 - (y)) -#define WtoB(y) ((y) + caml_gr_bstore.h - caml_gr_window.h) -#define BtoW(y) ((y) + caml_gr_window.h - caml_gr_bstore.h) -#define min(a,b) ((a) < (b) ? (a) : (b)) -#define max(a,b) ((a) > (b) ? (a) : (b)) - -#define DEFAULT_SCREEN_WIDTH 600 -#define DEFAULT_SCREEN_HEIGHT 450 -#define BORDER_WIDTH 2 -#define DEFAULT_WINDOW_NAME "OCaml graphics" -#define DEFAULT_SELECTED_EVENTS \ - (ExposureMask | KeyPressMask | StructureNotifyMask) -#define DEFAULT_FONT "fixed" -#define SIZE_QUEUE 256 - -/* To handle events asynchronously */ -#ifdef HAS_ASYNC_IO -#define USE_ASYNC_IO -#define EVENT_SIGNAL SIGIO -#else -#ifdef HAS_SETITIMER -#define USE_INTERVAL_TIMER -#define EVENT_SIGNAL SIGALRM -#else -#define USE_ALARM -#define EVENT_SIGNAL SIGALRM -#endif -#endif - -CAMLnoreturn_start -extern void caml_gr_fail(const char *fmt, const char *arg) -CAMLnoreturn_end; - -extern void caml_gr_check_open(void); -extern unsigned long caml_gr_pixel_rgb(int rgb); -extern int caml_gr_rgb_pixel(long unsigned int pixel); -extern void caml_gr_handle_event(XEvent *e); -extern void caml_gr_init_color_cache(void); -extern void caml_gr_init_direct_rgb_to_pixel(void); -extern value caml_gr_id_of_window( Window w ); diff --git a/otherlibs/graph/make_img.c b/otherlibs/graph/make_img.c deleted file mode 100644 index f1cd761d..00000000 --- a/otherlibs/graph/make_img.c +++ /dev/null @@ -1,99 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include "libgraph.h" -#include "image.h" -#include - -value caml_gr_make_image(value m) -{ - int width, height; - value im; - Bool has_transp; - XImage * idata, * imask; - char * bdata, * bmask; - int i, j, rgb; - value line; - GC gc; - - caml_gr_check_open(); - height = Wosize_val(m); - if (height == 0) return caml_gr_new_image(0, 0); - width = Wosize_val(Field(m, 0)); - for (i = 1; i < height; i++) - if (Wosize_val(Field(m, i)) != width) - caml_gr_fail("make_image: lines of different lengths", NULL); - - /* Build an XImage for the data part of the image */ - idata = - XCreateImage(caml_gr_display, - DefaultVisual(caml_gr_display, caml_gr_screen), - XDefaultDepth(caml_gr_display, caml_gr_screen), - ZPixmap, 0, NULL, width, height, - BitmapPad(caml_gr_display), 0); - - bdata = (char *) caml_stat_alloc(height * idata->bytes_per_line); - idata->data = bdata; - has_transp = False; - - for (i = 0; i < height; i++) { - line = Field(m, i); - for (j = 0; j < width; j++) { - rgb = Int_val(Field(line, j)); - if (rgb == Transparent) { has_transp = True; rgb = 0; } - XPutPixel(idata, j, i, caml_gr_pixel_rgb(rgb)); - } - } - - /* If the matrix contains transparent points, - build an XImage for the mask part of the image */ - if (has_transp) { - imask = - XCreateImage(caml_gr_display, - DefaultVisual(caml_gr_display, caml_gr_screen), - 1, ZPixmap, 0, NULL, width, height, - BitmapPad(caml_gr_display), 0); - bmask = (char *) caml_stat_alloc(height * imask->bytes_per_line); - imask->data = bmask; - - for (i = 0; i < height; i++) { - line = Field(m, i); - for (j = 0; j < width; j++) { - rgb = Int_val(Field(line, j)); - XPutPixel(imask, j, i, rgb != Transparent); - } - } - } else { - imask = NULL; - } - - /* Allocate the image and store the XImages into the Pixmaps */ - im = caml_gr_new_image(width, height); - gc = XCreateGC(caml_gr_display, Data_im(im), 0, NULL); - XPutImage(caml_gr_display, Data_im(im), gc, idata, 0, 0, 0, 0, width, height); - XDestroyImage(idata); - XFreeGC(caml_gr_display, gc); - if (has_transp) { - Mask_im(im) = XCreatePixmap(caml_gr_display, caml_gr_window.win, width, - height, 1); - gc = XCreateGC(caml_gr_display, Mask_im(im), 0, NULL); - XPutImage(caml_gr_display, Mask_im(im), gc, imask, 0, 0, 0, 0, width, - height); - XDestroyImage(imask); - XFreeGC(caml_gr_display, gc); - } - XFlush(caml_gr_display); - return im; -} diff --git a/otherlibs/graph/open.c b/otherlibs/graph/open.c deleted file mode 100644 index 7fac8c9e..00000000 --- a/otherlibs/graph/open.c +++ /dev/null @@ -1,401 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include -#include -#include -#include "libgraph.h" -#include -#include -#include -#include -#ifdef HAS_UNISTD -#include -#endif -#ifdef HAS_SETITIMER -#include -#endif - -Display * caml_gr_display = NULL; -int caml_gr_screen; -Colormap caml_gr_colormap; -int caml_gr_white, caml_gr_black, caml_gr_background; -struct canvas caml_gr_window; -struct canvas caml_gr_bstore; -Bool caml_gr_display_modeflag; -Bool caml_gr_remember_modeflag; -int caml_gr_x, caml_gr_y; -int caml_gr_color; -extern XFontStruct * caml_gr_font; -long caml_gr_selected_events; -Bool caml_gr_ignore_sigio = False; -static Bool caml_gr_initialized = False; -static char * window_name = NULL; - -static int caml_gr_error_handler(Display *display, XErrorEvent *error); -static int caml_gr_ioerror_handler(Display *display); -value caml_gr_clear_graph(void); - -value caml_gr_open_graph(value arg) -{ - char display_name[256], geometry_spec[64]; - const char * p; - char * q; - XSizeHints hints; - int ret; - XEvent event; - int x, y, w, h; - XWindowAttributes attributes; - - if (caml_gr_initialized) { - caml_gr_clear_graph(); - } else { - - /* Parse the argument */ - for (p = String_val(arg), q = display_name; *p != 0 && *p != ' '; p++) - if (q < display_name + sizeof(display_name) - 1) *q++ = *p; - *q = 0; - while (*p == ' ') p++; - for (q = geometry_spec; *p != 0; p++) - if (q < geometry_spec + sizeof(geometry_spec) - 1) *q++ = *p; - *q = 0; - - /* Open the display */ - if (caml_gr_display == NULL) { - caml_gr_display = XOpenDisplay(display_name); - if (caml_gr_display == NULL) - caml_gr_fail("Cannot open display %s", XDisplayName(display_name)); - caml_gr_screen = DefaultScreen(caml_gr_display); - caml_gr_black = BlackPixel(caml_gr_display, caml_gr_screen); - caml_gr_white = WhitePixel(caml_gr_display, caml_gr_screen); - caml_gr_background = caml_gr_white; - caml_gr_colormap = DefaultColormap(caml_gr_display, caml_gr_screen); - } - - /* Set up the error handlers */ - XSetErrorHandler(caml_gr_error_handler); - XSetIOErrorHandler(caml_gr_ioerror_handler); - - /* Parse the geometry specification */ - hints.x = 0; - hints.y = 0; - hints.width = DEFAULT_SCREEN_WIDTH; - hints.height = DEFAULT_SCREEN_HEIGHT; - hints.flags = PPosition | PSize; - hints.win_gravity = 0; - - ret = XWMGeometry(caml_gr_display, caml_gr_screen, geometry_spec, "", - BORDER_WIDTH, - &hints, &x, &y, &w, &h, &hints.win_gravity); - if (ret & (XValue | YValue)) { - hints.x = x; hints.y = y; hints.flags |= USPosition; - } - if (ret & (WidthValue | HeightValue)) { - hints.width = w; hints.height = h; hints.flags |= USSize; - } - - /* Initial drawing color is black */ - caml_gr_color = 0; /* CAML COLOR */ - - /* Create the on-screen window */ - caml_gr_window.w = hints.width; - caml_gr_window.h = hints.height; - caml_gr_window.win = - XCreateSimpleWindow(caml_gr_display, DefaultRootWindow(caml_gr_display), - hints.x, hints.y, hints.width, hints.height, - BORDER_WIDTH, caml_gr_black, caml_gr_background); - p = window_name; - if (p == NULL) p = DEFAULT_WINDOW_NAME; - /* What not use XSetWMProperties? */ - XSetStandardProperties(caml_gr_display, caml_gr_window.win, p, p, - None, NULL, 0, &hints); - caml_gr_window.gc = XCreateGC(caml_gr_display, caml_gr_window.win, 0, NULL); - XSetBackground(caml_gr_display, caml_gr_window.gc, caml_gr_background); - XSetForeground(caml_gr_display, caml_gr_window.gc, caml_gr_black); - - /* Require exposure, resize and keyboard events */ - caml_gr_selected_events = DEFAULT_SELECTED_EVENTS; - XSelectInput(caml_gr_display, caml_gr_window.win, caml_gr_selected_events); - - /* Map the window on the screen and wait for the first Expose event */ - XMapWindow(caml_gr_display, caml_gr_window.win); - do { XNextEvent(caml_gr_display, &event); } while (event.type != Expose); - - /* Get the actual window dimensions */ - XGetWindowAttributes(caml_gr_display, caml_gr_window.win, &attributes); - caml_gr_window.w = attributes.width; - caml_gr_window.h = attributes.height; - - /* Create the pixmap used for backing store */ - caml_gr_bstore.w = caml_gr_window.w; - caml_gr_bstore.h = caml_gr_window.h; - caml_gr_bstore.win = - XCreatePixmap(caml_gr_display, caml_gr_window.win, caml_gr_bstore.w, - caml_gr_bstore.h, - XDefaultDepth(caml_gr_display, caml_gr_screen)); - caml_gr_bstore.gc = XCreateGC(caml_gr_display, caml_gr_bstore.win, 0, NULL); - XSetBackground(caml_gr_display, caml_gr_bstore.gc, caml_gr_background); - - /* Clear the pixmap */ - XSetForeground(caml_gr_display, caml_gr_bstore.gc, caml_gr_background); - XFillRectangle(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, - 0, 0, caml_gr_bstore.w, caml_gr_bstore.h); - XSetForeground(caml_gr_display, caml_gr_bstore.gc, caml_gr_black); - - /* Set the display and remember modes on */ - caml_gr_display_modeflag = True ; - caml_gr_remember_modeflag = True ; - - /* The global data structures are now correctly initialized. - In particular, caml_gr_sigio_handler can now handle events safely. */ - caml_gr_initialized = True; - - /* If possible, request that system calls be restarted after - the EVENT_SIGNAL signal. */ -#ifdef POSIX_SIGNALS -#ifdef SA_RESTART - { struct sigaction action; - sigaction(EVENT_SIGNAL, NULL, &action); - action.sa_flags |= SA_RESTART; - sigaction(EVENT_SIGNAL, &action, NULL); - } -#endif -#endif - -#ifdef USE_ASYNC_IO - /* If BSD-style asynchronous I/O are supported: - arrange for I/O on the connection to trigger the SIGIO signal */ - ret = fcntl(ConnectionNumber(caml_gr_display), F_GETFL, 0); - fcntl(ConnectionNumber(caml_gr_display), F_SETFL, ret | FASYNC); - fcntl(ConnectionNumber(caml_gr_display), F_SETOWN, getpid()); -#endif - } -#ifdef USE_INTERVAL_TIMER - /* If BSD-style interval timers are provided, use the real-time timer - to poll events. */ - { struct itimerval it; - it.it_interval.tv_sec = 0; - it.it_interval.tv_usec = 250000; - it.it_value.tv_sec = 0; - it.it_value.tv_usec = 250000; - setitimer(ITIMER_REAL, &it, NULL); - } -#endif -#ifdef USE_ALARM - /* The poor man's solution: use alarm to poll events. */ - alarm(1); -#endif - /* Position the current point at origin */ - caml_gr_x = 0; - caml_gr_y = 0; - /* Reset the color cache */ - caml_gr_init_color_cache(); - caml_gr_init_direct_rgb_to_pixel(); - return Val_unit; -} - -value caml_gr_close_graph(void) -{ - if (caml_gr_initialized) { -#ifdef USE_INTERVAL_TIMER - struct itimerval it; - it.it_value.tv_sec = 0; - it.it_value.tv_usec = 0; - setitimer(ITIMER_REAL, &it, NULL); -#endif - caml_gr_initialized = False; - if (caml_gr_font != NULL) { - XFreeFont(caml_gr_display, caml_gr_font); caml_gr_font = NULL; - } - XFreeGC(caml_gr_display, caml_gr_window.gc); - XDestroyWindow(caml_gr_display, caml_gr_window.win); - XFreeGC(caml_gr_display, caml_gr_bstore.gc); - XFreePixmap(caml_gr_display, caml_gr_bstore.win); - XFlush(caml_gr_display); - XCloseDisplay (caml_gr_display); - caml_gr_display = NULL; - } - return Val_unit; -} - -value caml_gr_id_of_window(Window win) -{ - char tmp[256]; - - sprintf(tmp, "%lu", (unsigned long)win); - return caml_copy_string( tmp ); -} - -value caml_gr_window_id(void) -{ - caml_gr_check_open(); - return caml_gr_id_of_window(caml_gr_window.win); -} - -value caml_gr_set_window_title(value n) -{ - if (window_name != NULL) caml_stat_free(window_name); - window_name = caml_stat_strdup(String_val(n)); - if (caml_gr_initialized) { - XStoreName(caml_gr_display, caml_gr_window.win, window_name); - XSetIconName(caml_gr_display, caml_gr_window.win, window_name); - XFlush(caml_gr_display); - } - return Val_unit; -} - -value caml_gr_resize_window (value vx, value vy) -{ - caml_gr_check_open (); - - caml_gr_window.w = Int_val (vx); - caml_gr_window.h = Int_val (vy); - XResizeWindow (caml_gr_display, caml_gr_window.win, caml_gr_window.w, - caml_gr_window.h); - - XFreeGC(caml_gr_display, caml_gr_bstore.gc); - XFreePixmap(caml_gr_display, caml_gr_bstore.win); - - caml_gr_bstore.w = caml_gr_window.w; - caml_gr_bstore.h = caml_gr_window.h; - caml_gr_bstore.win = - XCreatePixmap(caml_gr_display, caml_gr_window.win, caml_gr_bstore.w, - caml_gr_bstore.h, - XDefaultDepth(caml_gr_display, caml_gr_screen)); - caml_gr_bstore.gc = XCreateGC(caml_gr_display, caml_gr_bstore.win, 0, NULL); - XSetBackground(caml_gr_display, caml_gr_bstore.gc, caml_gr_background); - - caml_gr_clear_graph (); - return Val_unit; -} - -value caml_gr_clear_graph(void) -{ - caml_gr_check_open(); - if(caml_gr_remember_modeflag) { - XSetForeground(caml_gr_display, caml_gr_bstore.gc, caml_gr_white); - XFillRectangle(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, - 0, 0, caml_gr_bstore.w, caml_gr_bstore.h); - XSetForeground(caml_gr_display, caml_gr_bstore.gc, caml_gr_color); - } - if(caml_gr_display_modeflag) { - XSetForeground(caml_gr_display, caml_gr_window.gc, caml_gr_white); - XFillRectangle(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, - 0, 0, caml_gr_window.w, caml_gr_window.h); - XSetForeground(caml_gr_display, caml_gr_window.gc, caml_gr_color); - XFlush(caml_gr_display); - } - caml_gr_init_color_cache(); - caml_gr_init_direct_rgb_to_pixel(); - return Val_unit; -} - -value caml_gr_size_x(void) -{ - caml_gr_check_open(); - return Val_int(caml_gr_window.w); -} - -value caml_gr_size_y(void) -{ - caml_gr_check_open(); - return Val_int(caml_gr_window.h); -} - -value caml_gr_synchronize(void) -{ - caml_gr_check_open(); - XCopyArea(caml_gr_display, caml_gr_bstore.win, caml_gr_window.win, - caml_gr_window.gc, - 0, caml_gr_bstore.h - caml_gr_window.h, - caml_gr_window.w, caml_gr_window.h, - 0, 0); - XFlush(caml_gr_display); - return Val_unit ; -} - -value caml_gr_display_mode(value flag) -{ - caml_gr_display_modeflag = Bool_val (flag); - return Val_unit ; -} - -value caml_gr_remember_mode(value flag) -{ - caml_gr_remember_modeflag = Bool_val(flag); - return Val_unit ; -} - -/* The caml_gr_sigio_handler is called via the signal machinery in the bytecode - interpreter. The signal system ensures that this function will be - called either between two bytecode instructions, or during a blocking - primitive. In either case, not in the middle of an Xlib call. */ - -value caml_gr_sigio_signal(value unit) -{ - return Val_int(EVENT_SIGNAL); -} - -value caml_gr_sigio_handler(void) -{ - XEvent grevent; - - if (caml_gr_initialized && !caml_gr_ignore_sigio) { - while (XCheckMaskEvent(caml_gr_display, -1 /*all events*/, &grevent)) { - caml_gr_handle_event(&grevent); - } - } -#ifdef USE_ALARM - alarm(1); -#endif - return Val_unit; -} - -/* Processing of graphic errors */ - -static value * graphic_failure_exn = NULL; - -void caml_gr_fail(const char *fmt, const char *arg) -{ - char buffer[1024]; - - if (graphic_failure_exn == NULL) { - graphic_failure_exn = caml_named_value("Graphics.Graphic_failure"); - if (graphic_failure_exn == NULL) - caml_invalid_argument("Exception Graphics.Graphic_failure not " - "initialized, must link graphics.cma"); - } - sprintf(buffer, fmt, arg); - caml_raise_with_string(*graphic_failure_exn, buffer); -} - -void caml_gr_check_open(void) -{ - if (!caml_gr_initialized) caml_gr_fail("graphic screen not opened", NULL); -} - -static int caml_gr_error_handler(Display *display, XErrorEvent *error) -{ - char errmsg[512]; - XGetErrorText(error->display, error->error_code, errmsg, sizeof(errmsg)); - caml_gr_fail("Xlib error: %s", errmsg); - return 0; -} - -static int caml_gr_ioerror_handler(Display *display) -{ - caml_gr_fail("fatal I/O error", NULL); - return 0; -} diff --git a/otherlibs/graph/point_col.c b/otherlibs/graph/point_col.c deleted file mode 100644 index 3c3d33db..00000000 --- a/otherlibs/graph/point_col.c +++ /dev/null @@ -1,31 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include "libgraph.h" - -value caml_gr_point_color(value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - XImage * im; - int rgb; - - caml_gr_check_open(); - im = XGetImage(caml_gr_display, caml_gr_bstore.win, x, Bcvt(y), 1, 1, (-1), - ZPixmap); - rgb = caml_gr_rgb_pixel(XGetPixel(im, 0, 0)); - XDestroyImage(im); - return Val_int(rgb); -} diff --git a/otherlibs/graph/sound.c b/otherlibs/graph/sound.c deleted file mode 100644 index 75ab2a57..00000000 --- a/otherlibs/graph/sound.c +++ /dev/null @@ -1,34 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include "libgraph.h" - -value caml_gr_sound(value vfreq, value vdur) -{ - XKeyboardControl kbdcontrol; - - caml_gr_check_open(); - kbdcontrol.bell_pitch = Int_val(vfreq); - kbdcontrol.bell_duration = Int_val(vdur); - XChangeKeyboardControl(caml_gr_display, KBBellPitch | KBBellDuration, - &kbdcontrol); - XBell(caml_gr_display, 0); - kbdcontrol.bell_pitch = -1; /* restore default value */ - kbdcontrol.bell_duration = -1; /* restore default value */ - XChangeKeyboardControl(caml_gr_display, KBBellPitch | KBBellDuration, - &kbdcontrol); - XFlush(caml_gr_display); - return Val_unit; -} diff --git a/otherlibs/graph/subwindow.c b/otherlibs/graph/subwindow.c deleted file mode 100644 index 8ccd78fb..00000000 --- a/otherlibs/graph/subwindow.c +++ /dev/null @@ -1,45 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Jun Furuse, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2001 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include "libgraph.h" - -value caml_gr_open_subwindow(value vx, value vy, value width, value height) -{ - Window win; - - int h = Int_val(height); - int w = Int_val(width); - int x = Int_val(vx); - int y = Int_val(vy); - - caml_gr_check_open(); - win = XCreateSimpleWindow(caml_gr_display, caml_gr_window.win, - x, Wcvt(y + h), w, h, - 0, caml_gr_black, caml_gr_background); - XMapWindow(caml_gr_display, win); - XFlush(caml_gr_display); - return (caml_gr_id_of_window (win)); -} - -value caml_gr_close_subwindow(value wid) -{ - Window win; - - caml_gr_check_open(); - sscanf( String_val(wid), "%lu", (unsigned long *)(&win) ); - XDestroyWindow(caml_gr_display, win); - XFlush(caml_gr_display); - return Val_unit; -} diff --git a/otherlibs/graph/text.c b/otherlibs/graph/text.c deleted file mode 100644 index d98c884e..00000000 --- a/otherlibs/graph/text.c +++ /dev/null @@ -1,86 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include "libgraph.h" -#include - -XFontStruct * caml_gr_font = NULL; - -static void caml_gr_get_font(const char *fontname) -{ - XFontStruct * font = XLoadQueryFont(caml_gr_display, fontname); - if (font == NULL) caml_gr_fail("cannot find font %s", fontname); - if (caml_gr_font != NULL) XFreeFont(caml_gr_display, caml_gr_font); - caml_gr_font = font; - XSetFont(caml_gr_display, caml_gr_window.gc, caml_gr_font->fid); - XSetFont(caml_gr_display, caml_gr_bstore.gc, caml_gr_font->fid); -} - -value caml_gr_set_font(value fontname) -{ - caml_gr_check_open(); - caml_gr_get_font(String_val(fontname)); - return Val_unit; -} - -value caml_gr_set_text_size (value sz) -{ - return Val_unit; -} - -static void caml_gr_draw_text(const char *txt, int len) -{ - if (caml_gr_font == NULL) caml_gr_get_font(DEFAULT_FONT); - if (caml_gr_remember_modeflag) - XDrawString(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, - caml_gr_x, Bcvt(caml_gr_y) - caml_gr_font->descent + 1, txt, - len); - if (caml_gr_display_modeflag) { - XDrawString(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, - caml_gr_x, Wcvt(caml_gr_y) - caml_gr_font->descent + 1, txt, - len); - XFlush(caml_gr_display); - } - caml_gr_x += XTextWidth(caml_gr_font, txt, len); -} - -value caml_gr_draw_char(value chr) -{ - char str[1]; - caml_gr_check_open(); - str[0] = Int_val(chr); - caml_gr_draw_text(str, 1); - return Val_unit; -} - -value caml_gr_draw_string(value str) -{ - caml_gr_check_open(); - caml_gr_draw_text(String_val(str), caml_string_length(str)); - return Val_unit; -} - -value caml_gr_text_size(value str) -{ - int width; - value res; - caml_gr_check_open(); - if (caml_gr_font == NULL) caml_gr_get_font(DEFAULT_FONT); - width = XTextWidth(caml_gr_font, String_val(str), caml_string_length(str)); - res = caml_alloc_small(2, 0); - Field(res, 0) = Val_int(width); - Field(res, 1) = Val_int(caml_gr_font->ascent + caml_gr_font->descent); - return res; -} diff --git a/otherlibs/systhreads/st_posix.h b/otherlibs/systhreads/st_posix.h index 386d4563..5e42cdd4 100644 --- a/otherlibs/systhreads/st_posix.h +++ b/otherlibs/systhreads/st_posix.h @@ -15,6 +15,7 @@ /* POSIX thread implementation of the "st" interface */ +#include #include #include #include @@ -92,22 +93,6 @@ static void st_thread_join(st_thread_id thr) /* best effort: ignore errors */ } -/* Scheduling hints */ - -static INLINE void st_thread_yield(void) -{ -#ifdef __linux__ - /* sched_yield() doesn't do what we want in Linux 2.6 and up (PR#2663) */ - /* but not doing anything here would actually disable preemption (PR#7669) */ - struct timespec t; - t.tv_sec = 0; - t.tv_nsec = 1; - nanosleep(&t, NULL); -#else - sched_yield(); -#endif -} - /* Thread-specific state */ typedef pthread_key_t st_tlskey; @@ -172,6 +157,44 @@ static INLINE int st_masterlock_waiters(st_masterlock * m) return m->waiters; } +/* Scheduling hints */ + +/* This is mostly equivalent to release(); acquire(), but better. In particular, + release(); acquire(); leaves both us and the waiter we signal() racing to + acquire the lock. Calling yield or sleep helps there but does not solve the + problem. Sleeping ourselves is much more reliable--and since we're handing + off the lock to a waiter we know exists, it's safe, as they'll certainly + re-wake us later. +*/ +static INLINE void st_thread_yield(st_masterlock * m) +{ + pthread_mutex_lock(&m->lock); + /* We must hold the lock to call this. */ + assert(m->busy); + + /* We already checked this without the lock, but we might have raced--if + there's no waiter, there's nothing to do and no one to wake us if we did + wait, so just keep going. */ + if (m->waiters == 0) { + pthread_mutex_unlock(&m->lock); + return; + } + + m->busy = 0; + pthread_cond_signal(&m->is_free); + m->waiters++; + do { + /* Note: the POSIX spec prevents the above signal from pairing with this + wait, which is good: we'll reliably continue waiting until the next + yield() or enter_blocking_section() call (or we see a spurious condvar + wakeup, which are rare at best.) */ + pthread_cond_wait(&m->is_free, &m->lock); + } while (m->busy); + m->busy = 1; + m->waiters--; + pthread_mutex_unlock(&m->lock); +} + /* Mutexes */ typedef pthread_mutex_t * st_mutex; diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c index c751ffbc..bfe57514 100644 --- a/otherlibs/systhreads/st_stubs.c +++ b/otherlibs/systhreads/st_stubs.c @@ -462,7 +462,7 @@ static void caml_thread_reinitialize(void) CAMLprim value caml_thread_initialize(value unit) /* ML */ { - /* Protect against repeated initialization (PR#1325) */ + /* Protect against repeated initialization (PR#3532) */ if (curr_thread != NULL) return Val_unit; /* OS-specific initialization */ st_initialize(); @@ -737,9 +737,19 @@ CAMLprim value caml_thread_exit(value unit) /* ML */ CAMLprim value caml_thread_yield(value unit) /* ML */ { if (st_masterlock_waiters(&caml_master_lock) == 0) return Val_unit; - caml_enter_blocking_section(); - st_thread_yield(); - caml_leave_blocking_section(); + + /* Do all the parts of a blocking section enter/leave except lock + manipulation, which we'll do more efficiently in st_thread_yield. (Since + our blocking section doesn't contain anything interesting, don't bother + with saving errno.) + */ + caml_process_pending_signals(); + caml_thread_save_runtime_state(); + st_thread_yield(&caml_master_lock); + curr_thread = st_tls_get(thread_descriptor_key); + caml_thread_restore_runtime_state(); + caml_process_pending_signals(); + return Val_unit; } diff --git a/otherlibs/systhreads/st_win32.h b/otherlibs/systhreads/st_win32.h index 2f2ea665..fcc25290 100644 --- a/otherlibs/systhreads/st_win32.h +++ b/otherlibs/systhreads/st_win32.h @@ -99,13 +99,6 @@ static void st_thread_join(st_thread_id thr) WaitForSingleObject(thr, INFINITE); } -/* Scheduling hints */ - -static INLINE void st_thread_yield(void) -{ - Sleep(0); -} - /* Thread-specific state */ typedef DWORD st_tlskey; @@ -158,6 +151,15 @@ static INLINE int st_masterlock_waiters(st_masterlock * m) return 1; /* info not maintained */ } +/* Scheduling hints */ + +static INLINE void st_thread_yield(st_masterlock * m) +{ + LeaveCriticalSection(m); + Sleep(0); + EnterCriticalSection(m); +} + /* Mutexes */ typedef CRITICAL_SECTION * st_mutex; diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend deleted file mode 100644 index 8c74f88d..00000000 --- a/otherlibs/threads/.depend +++ /dev/null @@ -1,78 +0,0 @@ -scheduler.o: scheduler.c ../../runtime/caml/alloc.h \ - ../../runtime/caml/misc.h ../../runtime/caml/config.h \ - ../../runtime/caml/m.h ../../runtime/caml/s.h \ - ../../runtime/caml/mlvalues.h ../../runtime/caml/backtrace.h \ - ../../runtime/caml/exec.h ../../runtime/caml/callback.h \ - ../../runtime/caml/config.h ../../runtime/caml/fail.h \ - ../../runtime/caml/io.h ../../runtime/caml/memory.h \ - ../../runtime/caml/gc.h ../../runtime/caml/major_gc.h \ - ../../runtime/caml/freelist.h ../../runtime/caml/minor_gc.h \ - ../../runtime/caml/address_class.h ../../runtime/caml/misc.h \ - ../../runtime/caml/mlvalues.h ../../runtime/caml/printexc.h \ - ../../runtime/caml/roots.h ../../runtime/caml/memory.h \ - ../../runtime/caml/signals.h ../../runtime/caml/stacks.h \ - ../../runtime/caml/sys.h -condition.cmo : \ - thread.cmi \ - mutex.cmi \ - condition.cmi -condition.cmx : \ - thread.cmx \ - mutex.cmx \ - condition.cmi -condition.cmi : \ - mutex.cmi -event.cmo : \ - mutex.cmi \ - condition.cmi \ - event.cmi -event.cmx : \ - mutex.cmx \ - condition.cmx \ - event.cmi -event.cmi : -marshal.cmo : -marshal.cmx : -mutex.cmo : \ - thread.cmi \ - mutex.cmi -mutex.cmx : \ - thread.cmx \ - mutex.cmi -mutex.cmi : -stdlib.cmo : \ - unix.cmi \ - marshal.cmo \ - stdlib.cmi -stdlib.cmx : \ - unix.cmx \ - marshal.cmx \ - stdlib.cmi -stdlib.cmi : \ - marshal.cmo -thread.cmo : \ - unix.cmi \ - thread.cmi -thread.cmx : \ - unix.cmx \ - thread.cmi -thread.cmi : \ - unix.cmi -threadUnix.cmo : \ - unix.cmi \ - thread.cmi \ - threadUnix.cmi -threadUnix.cmx : \ - unix.cmx \ - thread.cmx \ - threadUnix.cmi -threadUnix.cmi : \ - unix.cmi -unix.cmo : \ - stdlib.cmi \ - unix.cmi -unix.cmx : \ - stdlib.cmx \ - unix.cmi -unix.cmi : \ - stdlib.cmi diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile deleted file mode 100644 index 9b81940e..00000000 --- a/otherlibs/threads/Makefile +++ /dev/null @@ -1,159 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -#* * -#* Copyright 1999 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -# FIXME reduce redundancy by including ../Makefile - -ROOTDIR = ../.. - -include $(ROOTDIR)/Makefile.config -include $(ROOTDIR)/Makefile.common - -CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun - -OC_CFLAGS += $(SHAREDLIB_CFLAGS) -OC_CPPFLAGS += -I$(ROOTDIR)/runtime -CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib \ - -I $(ROOTDIR)/stdlib -I $(ROOTDIR)/otherlibs/unix -MKLIB=$(CAMLRUN) $(ROOTDIR)/tools/ocamlmklib -COMPFLAGS=-w +33..39 -warn-error A -bin-annot -g -safe-string - -C_OBJS=scheduler.o - -CAML_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo - -LIB=$(ROOTDIR)/stdlib - -# Object file prefix -P=stdlib__ - -LIB_OBJS=$(LIB)/camlinternalFormatBasics.cmo stdlib.cmo $(LIB)/$(P)bool.cmo \ - $(LIB)/$(P)seq.cmo $(LIB)/$(P)option.cmo $(LIB)/$(P)result.cmo \ - $(LIB)/$(P)fun.cmo $(LIB)/$(P)unit.cmo \ - $(LIB)/$(P)array.cmo $(LIB)/$(P)list.cmo \ - $(LIB)/$(P)char.cmo $(LIB)/$(P)bytes.cmo $(LIB)/$(P)string.cmo \ - $(LIB)/$(P)sys.cmo marshal.cmo $(LIB)/$(P)obj.cmo \ - $(LIB)/$(P)int.cmo $(LIB)/$(P)int32.cmo $(LIB)/$(P)int64.cmo \ - $(LIB)/$(P)nativeint.cmo $(LIB)/$(P)lexing.cmo $(LIB)/$(P)parsing.cmo \ - $(LIB)/$(P)set.cmo $(LIB)/$(P)map.cmo $(LIB)/$(P)stack.cmo \ - $(LIB)/$(P)queue.cmo $(LIB)/camlinternalLazy.cmo $(LIB)/$(P)lazy.cmo \ - $(LIB)/$(P)stream.cmo $(LIB)/$(P)buffer.cmo $(LIB)/camlinternalFormat.cmo \ - $(LIB)/$(P)printf.cmo $(LIB)/$(P)arg.cmo $(LIB)/$(P)printexc.cmo \ - $(LIB)/$(P)gc.cmo $(LIB)/$(P)digest.cmo \ - $(LIB)/$(P)random.cmo $(LIB)/$(P)hashtbl.cmo $(LIB)/$(P)format.cmo \ - $(LIB)/$(P)scanf.cmo $(LIB)/$(P)callback.cmo $(LIB)/camlinternalOO.cmo \ - $(LIB)/$(P)oo.cmo $(LIB)/camlinternalMod.cmo $(LIB)/$(P)genlex.cmo \ - $(LIB)/$(P)weak.cmo $(LIB)/$(P)ephemeron.cmo $(LIB)/$(P)filename.cmo \ - $(LIB)/$(P)complex.cmo $(LIB)/$(P)arrayLabels.cmo $(LIB)/$(P)listLabels.cmo \ - $(LIB)/$(P)bytesLabels.cmo $(LIB)/$(P)stringLabels.cmo \ - $(LIB)/$(P)moreLabels.cmo $(LIB)/$(P)stdLabels.cmo - -UNIXLIB=../unix - -UNIXLIB_OBJS=unix.cmo $(UNIXLIB)/unixLabels.cmo - -all: libvmthreads.a threads.cma stdlib.cma unix.cma - -allopt: - -libvmthreads.a: $(C_OBJS) - $(MKLIB) -o threads -oc vmthreads $(C_OBJS) - -threads.cma: $(CAML_OBJS) - $(MKLIB) -ocamlc '$(CAMLC)' -o threads -oc vmthreads $^ - -stdlib.cma: $(LIB_OBJS) - $(CAMLC) -a -o $@ $^ - -unix.cma: $(UNIXLIB_OBJS) - $(MKLIB) -ocamlc '$(CAMLC)' -o unix -linkall $^ - -stdlib.cmo: stdlib.mli stdlib.cmi stdlib.ml - $(CAMLC) ${COMPFLAGS} -nopervasives \ - -pp "$(AWK) -f $(LIB)/expand_module_aliases.awk" -o $@ -c stdlib.ml - -stdlib.mli: $(LIB)/stdlib.mli - ln -s $(LIB)/stdlib.mli stdlib.mli - -stdlib.cmi: $(LIB)/stdlib.cmi - rm -f $@ - ln -s $< $@ - -$(P)marshal.cmo: marshal.ml marshal.mli $(P)marshal.cmi - $(CAMLC) ${COMPFLAGS} -o$@ -c $< - -marshal.mli: $(LIB)/marshal.mli - ln -s $< $@ - -$(P)marshal.cmi: $(LIB)/$(P)marshal.cmi - ln -s $< $@ - -unix.mli: $(UNIXLIB)/unix.mli - ln -s -f $< $@ - -unix.cmi: $(UNIXLIB)/unix.cmi - ln -s -f $< $@ - -unix.cmo: unix.mli unix.cmi $(UNIXLIB)/unixLabels.cmo - $(CAMLC) ${COMPFLAGS} -c unix.ml - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f libvmthreads.a dllvmthreads.so *.o - rm -f stdlib.mli marshal.mli unix.mli - -CMIFILES=thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi - -install: - if test -f dllvmthreads.so; then \ - $(INSTALL_PROG) dllvmthreads.so "$(INSTALL_STUBLIBDIR)"; \ - fi - mkdir -p "$(INSTALL_LIBDIR)/vmthreads" - $(INSTALL_DATA) libvmthreads.a "$(INSTALL_LIBDIR)/vmthreads" - cd "$(INSTALL_LIBDIR)/vmthreads"; $(RANLIB) libvmthreads.a - $(INSTALL_DATA) \ - $(CMIFILES) \ - threads.cma stdlib.cma unix.cma \ - "$(INSTALL_LIBDIR)/vmthreads" -ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true" - $(INSTALL_DATA) \ - $(CMIFILES:.cmi=.mli) $(CMIFILES:.cmi=.cmti) \ - "$(INSTALL_LIBDIR)/vmthreads" -endif - -installopt: - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -%.$(O): %.c - $(CC) -c $(OC_CFLAGS) $(OC_CPPFLAGS) $(OUTPUTOBJ)$@ $< - -.PHONY: depend -depend: -ifeq "$(TOOLCHAIN)" "msvc" - $(error Dependencies cannot be regenerated using the MSVC ports) -else - $(CC) -MM $(OC_CPPFLAGS) *.c > .depend - $(CAMLRUN) $(ROOTDIR)/boot/ocamlc -depend -slash *.mli *.ml >> .depend -endif - -include .depend diff --git a/otherlibs/threads/condition.ml b/otherlibs/threads/condition.ml deleted file mode 100644 index c685d813..00000000 --- a/otherlibs/threads/condition.ml +++ /dev/null @@ -1,35 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type t = { mutable waiting: Thread.t list } - -let create () = { waiting = [] } - -let wait cond mut = - Thread.critical_section := true; - Mutex.unlock mut; - cond.waiting <- Thread.self() :: cond.waiting; - Thread.sleep(); - Mutex.lock mut - -let signal cond = - match cond.waiting with (* atomic *) - [] -> () - | th :: rem -> cond.waiting <- rem (* atomic *); Thread.wakeup th - -let broadcast cond = - let w = cond.waiting in (* atomic *) - cond.waiting <- []; (* atomic *) - List.iter Thread.wakeup w diff --git a/otherlibs/threads/condition.mli b/otherlibs/threads/condition.mli deleted file mode 100644 index 2557fe78..00000000 --- a/otherlibs/threads/condition.mli +++ /dev/null @@ -1,53 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Condition variables to synchronize between threads. - - Condition variables are used when one thread wants to wait until another - thread has finished doing something: the former thread ``waits'' on the - condition variable, the latter thread ``signals'' the condition when it - is done. Condition variables should always be protected by a mutex. - The typical use is (if [D] is a shared data structure, [m] its mutex, - and [c] is a condition variable): - {[ - Mutex.lock m; - while (* some predicate P over D is not satisfied *) do - Condition.wait c m - done; - (* Modify D *) - if (* the predicate P over D is now satisfied *) then Condition.signal c; - Mutex.unlock m - ]} -*) - -type t -(** The type of condition variables. *) - -val create : unit -> t -(** Return a new condition variable. *) - -val wait : t -> Mutex.t -> unit -(** [wait c m] atomically unlocks the mutex [m] and suspends the - calling process on the condition variable [c]. The process will - restart after the condition variable [c] has been signalled. - The mutex [m] is locked again before [wait] returns. *) - -val signal : t -> unit -(** [signal c] restarts one of the processes waiting on the - condition variable [c]. *) - -val broadcast : t -> unit -(** [broadcast c] restarts all processes waiting on the - condition variable [c]. *) diff --git a/otherlibs/threads/event.ml b/otherlibs/threads/event.ml deleted file mode 100644 index b00a6fc3..00000000 --- a/otherlibs/threads/event.ml +++ /dev/null @@ -1,274 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* David Nowak and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Events *) -type 'a basic_event = - { poll: unit -> bool; - (* If communication can take place immediately, return true. *) - suspend: unit -> unit; - (* Offer the communication on the channel and get ready - to suspend current process. *) - result: unit -> 'a } - (* Return the result of the communication *) - -type 'a behavior = int ref -> Condition.t -> int -> 'a basic_event - -type 'a event = - Communication of 'a behavior - | Choose of 'a event list - | WrapAbort of 'a event * (unit -> unit) - | Guard of (unit -> 'a event) - -(* Communication channels *) -type 'a channel = - { mutable writes_pending: 'a communication Queue.t; - (* All offers to write on it *) - mutable reads_pending: 'a communication Queue.t } - (* All offers to read from it *) - -(* Communication offered *) -and 'a communication = - { performed: int ref; (* -1 if not performed yet, set to the number *) - (* of the matching communication after rendez-vous. *) - condition: Condition.t; (* To restart the blocked thread. *) - mutable data: 'a option; (* The data sent or received. *) - event_number: int } (* Event number in select *) - -(* Create a channel *) - -let new_channel () = - { writes_pending = Queue.create(); - reads_pending = Queue.create() } - -(* Basic synchronization function *) - -let masterlock = Mutex.create() - -let do_aborts abort_env genev performed = - if abort_env <> [] then begin - if performed >= 0 then begin - let ids_done = snd genev.(performed) in - List.iter - (fun (id,f) -> if not (List.mem id ids_done) then f ()) - abort_env - end else begin - List.iter (fun (_,f) -> f ()) abort_env - end - end - -let basic_sync abort_env genev = - let performed = ref (-1) in - let condition = Condition.create() in - let bev = Array.make (Array.length genev) - (fst (genev.(0)) performed condition 0) in - for i = 1 to Array.length genev - 1 do - bev.(i) <- (fst genev.(i)) performed condition i - done; - (* See if any of the events is already activable *) - let rec poll_events i = - if i >= Array.length bev - then false - else bev.(i).poll() || poll_events (i+1) in - Mutex.lock masterlock; - if not (poll_events 0) then begin - (* Suspend on all events *) - for i = 0 to Array.length bev - 1 do bev.(i).suspend() done; - (* Wait until the condition is signalled *) - Condition.wait condition masterlock - end; - Mutex.unlock masterlock; - (* Extract the result *) - if abort_env = [] then - (* Preserve tail recursion *) - bev.(!performed).result() - else begin - let num = !performed in - let result = bev.(num).result() in - (* Handle the aborts and return the result *) - do_aborts abort_env genev num; - result - end - -(* Apply a random permutation on an array *) - -let scramble_array a = - let len = Array.length a in - if len = 0 then invalid_arg "Event.choose"; - for i = len - 1 downto 1 do - let j = Random.int (i + 1) in - let temp = a.(i) in a.(i) <- a.(j); a.(j) <- temp - done; - a - -(* Main synchronization function *) - -let gensym = let count = ref 0 in fun () -> incr count; !count - -let rec flatten_event - (abort_list : int list) - (accu : ('a behavior * int list) list) - (accu_abort : (int * (unit -> unit)) list) - ev = - match ev with - Communication bev -> ((bev,abort_list) :: accu) , accu_abort - | WrapAbort (ev,fn) -> - let id = gensym () in - flatten_event (id :: abort_list) accu ((id,fn)::accu_abort) ev - | Choose evl -> - let rec flatten_list accu' accu_abort'= function - ev :: l -> - let (accu'',accu_abort'') = - flatten_event abort_list accu' accu_abort' ev in - flatten_list accu'' accu_abort'' l - | [] -> (accu',accu_abort') in - flatten_list accu accu_abort evl - | Guard fn -> flatten_event abort_list accu accu_abort (fn ()) - -let sync ev = - let (evl,abort_env) = flatten_event [] [] [] ev in - basic_sync abort_env (scramble_array(Array.of_list evl)) - -(* Event polling -- like sync, but non-blocking *) - -let basic_poll abort_env genev = - let performed = ref (-1) in - let condition = Condition.create() in - let bev = Array.make(Array.length genev) - (fst genev.(0) performed condition 0) in - for i = 1 to Array.length genev - 1 do - bev.(i) <- fst genev.(i) performed condition i - done; - (* See if any of the events is already activable *) - let rec poll_events i = - if i >= Array.length bev - then false - else bev.(i).poll() || poll_events (i+1) in - Mutex.lock masterlock; - let ready = poll_events 0 in - if ready then begin - (* Extract the result *) - Mutex.unlock masterlock; - let result = Some(bev.(!performed).result()) in - do_aborts abort_env genev !performed; result - end else begin - (* Cancel the communication offers *) - performed := 0; - Mutex.unlock masterlock; - do_aborts abort_env genev (-1); - None - end - -let poll ev = - let (evl,abort_env) = flatten_event [] [] [] ev in - basic_poll abort_env (scramble_array(Array.of_list evl)) - -(* Remove all communication opportunities already synchronized *) - -let cleanup_queue q = - let q' = Queue.create() in - Queue.iter (fun c -> if !(c.performed) = -1 then Queue.add c q') q; - q' - -(* Event construction *) - -let always data = - Communication(fun performed condition evnum -> - { poll = (fun () -> performed := evnum; true); - suspend = (fun () -> ()); - result = (fun () -> data) }) - -let send channel data = - Communication(fun performed condition evnum -> - let wcomm = - { performed = performed; - condition = condition; - data = Some data; - event_number = evnum } in - { poll = (fun () -> - let rec poll () = - let rcomm = Queue.take channel.reads_pending in - if !(rcomm.performed) >= 0 then - poll () - else begin - rcomm.data <- wcomm.data; - performed := evnum; - rcomm.performed := rcomm.event_number; - Condition.signal rcomm.condition - end in - try - poll(); - true - with Queue.Empty -> - false); - suspend = (fun () -> - channel.writes_pending <- cleanup_queue channel.writes_pending; - Queue.add wcomm channel.writes_pending); - result = (fun () -> ()) }) - -let receive channel = - Communication(fun performed condition evnum -> - let rcomm = - { performed = performed; - condition = condition; - data = None; - event_number = evnum } in - { poll = (fun () -> - let rec poll () = - let wcomm = Queue.take channel.writes_pending in - if !(wcomm.performed) >= 0 then - poll () - else begin - rcomm.data <- wcomm.data; - performed := evnum; - wcomm.performed := wcomm.event_number; - Condition.signal wcomm.condition - end in - try - poll(); - true - with Queue.Empty -> - false); - suspend = (fun () -> - channel.reads_pending <- cleanup_queue channel.reads_pending; - Queue.add rcomm channel.reads_pending); - result = (fun () -> - match rcomm.data with - None -> invalid_arg "Event.receive" - | Some res -> res) }) - -let choose evl = Choose evl - -let wrap_abort ev fn = WrapAbort(ev,fn) - -let guard fn = Guard fn - -let rec wrap ev fn = - match ev with - Communication genev -> - Communication(fun performed condition evnum -> - let bev = genev performed condition evnum in - { poll = bev.poll; - suspend = bev.suspend; - result = (fun () -> fn(bev.result())) }) - | Choose evl -> - Choose(List.map (fun ev -> wrap ev fn) evl) - | WrapAbort (ev, f') -> - WrapAbort (wrap ev fn, f') - | Guard gu -> - Guard(fun () -> wrap (gu()) fn) - -(* Convenience functions *) - -let select evl = sync(Choose evl) diff --git a/otherlibs/threads/event.mli b/otherlibs/threads/event.mli deleted file mode 100644 index a1921234..00000000 --- a/otherlibs/threads/event.mli +++ /dev/null @@ -1,81 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* David Nowak and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** First-class synchronous communication. - - This module implements synchronous inter-thread communications over - channels. As in John Reppy's Concurrent ML system, the communication - events are first-class values: they can be built and combined - independently before being offered for communication. -*) - -type 'a channel -(** The type of communication channels carrying values of type ['a]. *) - -val new_channel : unit -> 'a channel -(** Return a new channel. *) - -type +'a event -(** The type of communication events returning a result of type ['a]. *) - -(** [send ch v] returns the event consisting in sending the value [v] - over the channel [ch]. The result value of this event is [()]. *) -val send : 'a channel -> 'a -> unit event - -(** [receive ch] returns the event consisting in receiving a value - from the channel [ch]. The result value of this event is the - value received. *) -val receive : 'a channel -> 'a event - -val always : 'a -> 'a event -(** [always v] returns an event that is always ready for - synchronization. The result value of this event is [v]. *) - -val choose : 'a event list -> 'a event -(** [choose evl] returns the event that is the alternative of - all the events in the list [evl]. *) - -val wrap : 'a event -> ('a -> 'b) -> 'b event -(** [wrap ev fn] returns the event that performs the same communications - as [ev], then applies the post-processing function [fn] - on the return value. *) - -val wrap_abort : 'a event -> (unit -> unit) -> 'a event -(** [wrap_abort ev fn] returns the event that performs - the same communications as [ev], but if it is not selected - the function [fn] is called after the synchronization. *) - -val guard : (unit -> 'a event) -> 'a event -(** [guard fn] returns the event that, when synchronized, computes - [fn()] and behaves as the resulting event. This allows events with - side-effects to be computed at the time of the synchronization - operation. *) - -val sync : 'a event -> 'a -(** ``Synchronize'' on an event: offer all the communication - possibilities specified in the event to the outside world, - and block until one of the communications succeed. The result - value of that communication is returned. *) - -val select : 'a event list -> 'a -(** ``Synchronize'' on an alternative of events. - [select evl] is shorthand for [sync(choose evl)]. *) - -val poll : 'a event -> 'a option -(** Non-blocking version of {!Event.sync}: offer all the communication - possibilities specified in the event to the outside world, - and if one can take place immediately, perform it and return - [Some r] where [r] is the result value of that communication. - Otherwise, return [None] without blocking. *) diff --git a/otherlibs/threads/marshal.ml b/otherlibs/threads/marshal.ml deleted file mode 100644 index f09be91c..00000000 --- a/otherlibs/threads/marshal.ml +++ /dev/null @@ -1,60 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type extern_flags = - No_sharing - | Closures - | Compat_32 - -external to_bytes: 'a -> extern_flags list -> bytes - = "caml_output_value_to_bytes" - -external to_string: 'a -> extern_flags list -> string - = "caml_output_value_to_string" - -let to_channel chan v flags = - output_string chan (to_string v flags) - -external to_buffer_unsafe: - bytes -> int -> int -> 'a -> extern_flags list -> int - = "caml_output_value_to_buffer" - -let to_buffer buff ofs len v flags = - if ofs < 0 || len < 0 || ofs + len > Bytes.length buff - then invalid_arg "Marshal.to_buffer: substring out of bounds" - else to_buffer_unsafe buff ofs len v flags - -external from_channel: in_channel -> 'a = "caml_input_value" -external from_bytes_unsafe: bytes -> int -> 'a = "caml_input_value_from_bytes" -external data_size_unsafe: bytes -> int -> int = "caml_marshal_data_size" - -let header_size = 20 -let data_size buff ofs = - if ofs < 0 || ofs > Bytes.length buff - header_size - then invalid_arg "Marshal.data_size" - else data_size_unsafe buff ofs -let total_size buff ofs = header_size + data_size buff ofs - -let from_bytes buff ofs = - if ofs < 0 || ofs > Bytes.length buff - header_size - then invalid_arg "Marshal.from_bytes" - else begin - let len = data_size_unsafe buff ofs in - if ofs > Bytes.length buff - (header_size + len) - then invalid_arg "Marshal.from_bytes" - else from_bytes_unsafe buff ofs - end - -let from_string buff ofs = from_bytes (Bytes.unsafe_of_string buff) ofs diff --git a/otherlibs/threads/mutex.ml b/otherlibs/threads/mutex.ml deleted file mode 100644 index 8209d7d2..00000000 --- a/otherlibs/threads/mutex.ml +++ /dev/null @@ -1,38 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type t = { mutable locked: bool; mutable waiting: Thread.t list } - -let create () = { locked = false; waiting = [] } - -let rec lock m = - if m.locked then begin (* test and set atomic *) - Thread.critical_section := true; - m.waiting <- Thread.self() :: m.waiting; - Thread.sleep(); - lock m - end else begin - m.locked <- true (* test and set atomic *) - end - -let try_lock m = (* test and set atomic *) - if m.locked then false else begin m.locked <- true; true end - -let unlock m = - (* Don't play with Thread.critical_section here because of Condition.wait *) - let w = m.waiting in (* atomic *) - m.waiting <- []; (* atomic *) - m.locked <- false; (* atomic *) - List.iter Thread.wakeup w diff --git a/otherlibs/threads/mutex.mli b/otherlibs/threads/mutex.mli deleted file mode 100644 index 8953a159..00000000 --- a/otherlibs/threads/mutex.mli +++ /dev/null @@ -1,49 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Locks for mutual exclusion. - - Mutexes (mutual-exclusion locks) are used to implement critical sections - and protect shared mutable data structures against concurrent accesses. - The typical use is (if [m] is the mutex associated with the data structure - [D]): - {[ - Mutex.lock m; - (* Critical section that operates over D *); - Mutex.unlock m - ]} -*) - -type t -(** The type of mutexes. *) - -val create : unit -> t -(** Return a new mutex. *) - -val lock : t -> unit -(** Lock the given mutex. Only one thread can have the mutex locked - at any time. A thread that attempts to lock a mutex already locked - by another thread will suspend until the other thread unlocks - the mutex. *) - -val try_lock : t -> bool -(** Same as {!Mutex.lock}, but does not suspend the calling thread if - the mutex is already locked: just return [false] immediately - in that case. If the mutex is unlocked, lock it and - return [true]. *) - -val unlock : t -> unit -(** Unlock the given mutex. Other threads suspended trying to lock - the mutex will restart. *) diff --git a/otherlibs/threads/scheduler.c b/otherlibs/threads/scheduler.c deleted file mode 100644 index 7a69bfca..00000000 --- a/otherlibs/threads/scheduler.c +++ /dev/null @@ -1,878 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#define CAML_INTERNALS - -/* The thread scheduler */ - -#include -#include -#include - -#include "caml/alloc.h" -#include "caml/backtrace.h" -#include "caml/callback.h" -#include "caml/config.h" -#include "caml/fail.h" -#include "caml/io.h" -#include "caml/memory.h" -#include "caml/misc.h" -#include "caml/mlvalues.h" -#include "caml/printexc.h" -#include "caml/roots.h" -#include "caml/signals.h" -#include "caml/stacks.h" -#include "caml/sys.h" - -#if ! (defined(HAS_SELECT) && \ - defined(HAS_SETITIMER) && \ - defined(HAS_GETTIMEOFDAY) && \ - (defined(HAS_WAITPID) || defined(HAS_WAIT4))) -#warning "Cannot compile libthreads, system calls missing" -#endif - -#include -#include -#include -#include -#include -#include -#ifdef HAS_UNISTD -#include -#endif -#ifdef HAS_SYS_SELECT_H -#include -#endif - -#ifndef HAS_WAITPID -#define waitpid(pid,status,opts) wait4(pid,status,opts,NULL) -#endif - -#ifndef O_NONBLOCK -#define O_NONBLOCK O_NDELAY -#endif - -/* Configuration */ - -/* Initial size of stack when a thread is created (4kB) */ -#define Thread_stack_size (Stack_size / 4) - -/* Max computation time before rescheduling, in microseconds (50ms) */ -#define Thread_timeout 50000 - -/* The thread descriptors */ - -struct caml_thread_struct { - value ident; /* Unique id (for equality comparisons) */ - struct caml_thread_struct * next; /* Double linking of threads */ - struct caml_thread_struct * prev; - value * stack_low; /* The execution stack for this thread */ - value * stack_high; - value * stack_threshold; - value * sp; - value * trapsp; - value backtrace_pos; /* The backtrace info for this thread */ - backtrace_slot * backtrace_buffer; - value backtrace_last_exn; - value status; /* RUNNABLE, KILLED. etc (see below) */ - value fd; /* File descriptor on which we're doing read or write */ - value readfds, writefds, exceptfds; - /* Lists of file descriptors on which we're doing select() */ - value delay; /* Time until which this thread is blocked */ - value joining; /* Thread we're trying to join */ - value waitpid; /* PID of process we're waiting for */ - value retval; /* Value to return when thread resumes */ -}; - -typedef struct caml_thread_struct * caml_thread_t; - -#define RUNNABLE Val_int(0) -#define KILLED Val_int(1) -#define SUSPENDED Val_int(2) -#define BLOCKED_READ Val_int(4) -#define BLOCKED_WRITE Val_int(8) -#define BLOCKED_SELECT Val_int(16) -#define BLOCKED_DELAY Val_int(32) -#define BLOCKED_JOIN Val_int(64) -#define BLOCKED_WAIT Val_int(128) - -#define RESUMED_WAKEUP Val_int(0) -#define RESUMED_DELAY Val_int(1) -#define RESUMED_JOIN Val_int(2) -#define RESUMED_IO Val_int(3) - -#define TAG_RESUMED_SELECT 0 -#define TAG_RESUMED_WAIT 1 - -#define NO_FDS Val_unit -#define NO_DELAY Val_unit -#define NO_JOINING Val_unit -#define NO_WAITPID Val_int(0) - -#define DELAY_INFTY 1E30 /* +infty, for this purpose */ - -/* The thread currently active */ -static caml_thread_t curr_thread = NULL; -/* Identifier for next thread creation */ -static value next_ident = Val_int(0); - -#define Assign(dst,src) caml_modify((value *)&(dst), (value)(src)) - -/* Scan the stacks of the other threads */ - -static void (*prev_scan_roots_hook) (scanning_action); - -static void thread_scan_roots(scanning_action action) -{ - caml_thread_t th, start; - - /* Scan all active descriptors */ - start = curr_thread; - (*action)((value) curr_thread, (value *) &curr_thread); - /* Don't scan curr_thread->sp, this has already been done. - Don't scan local roots either, for the same reason. */ - for (th = start->next; th != start; th = th->next) { - caml_do_local_roots(action, th->sp, th->stack_high, NULL); - } - /* Hook */ - if (prev_scan_roots_hook != NULL) (*prev_scan_roots_hook)(action); -} - -/* Forward declarations for async I/O handling */ - -static int stdin_initial_status, stdout_initial_status, stderr_initial_status; -static void thread_restore_std_descr(void); - -/* Initialize the thread machinery */ - -value thread_initialize(value unit) /* ML */ -{ - /* Protect against repeated initialization (PR#1325) */ - if (curr_thread != NULL) return Val_unit; - /* Create a descriptor for the current thread */ - curr_thread = - (caml_thread_t) caml_alloc_shr(sizeof(struct caml_thread_struct) - / sizeof(value), 0); - curr_thread->ident = next_ident; - next_ident = Val_int(Int_val(next_ident) + 1); - curr_thread->next = curr_thread; - curr_thread->prev = curr_thread; - curr_thread->stack_low = caml_stack_low; - curr_thread->stack_high = caml_stack_high; - curr_thread->stack_threshold = caml_stack_threshold; - curr_thread->sp = caml_extern_sp; - curr_thread->trapsp = caml_trapsp; - curr_thread->backtrace_pos = Val_int(caml_backtrace_pos); - curr_thread->backtrace_buffer = caml_backtrace_buffer; - caml_initialize (&curr_thread->backtrace_last_exn, caml_backtrace_last_exn); - curr_thread->status = RUNNABLE; - curr_thread->fd = Val_int(0); - curr_thread->readfds = NO_FDS; - curr_thread->writefds = NO_FDS; - curr_thread->exceptfds = NO_FDS; - curr_thread->delay = NO_DELAY; - curr_thread->joining = NO_JOINING; - curr_thread->waitpid = NO_WAITPID; - curr_thread->retval = Val_unit; - /* Initialize GC */ - prev_scan_roots_hook = caml_scan_roots_hook; - caml_scan_roots_hook = thread_scan_roots; - /* Set standard file descriptors to non-blocking mode */ - stdin_initial_status = fcntl(0, F_GETFL); - stdout_initial_status = fcntl(1, F_GETFL); - stderr_initial_status = fcntl(2, F_GETFL); - if (stdin_initial_status != -1) - fcntl(0, F_SETFL, stdin_initial_status | O_NONBLOCK); - if (stdout_initial_status != -1) - fcntl(1, F_SETFL, stdout_initial_status | O_NONBLOCK); - if (stderr_initial_status != -1) - fcntl(2, F_SETFL, stderr_initial_status | O_NONBLOCK); - /* Register an at-exit function to restore the standard file descriptors */ - atexit(thread_restore_std_descr); - return Val_unit; -} - -/* Initialize the interval timer used for preemption */ - -value thread_initialize_preemption(value unit) /* ML */ -{ - struct itimerval timer; - - timer.it_interval.tv_sec = 0; - timer.it_interval.tv_usec = Thread_timeout; - timer.it_value = timer.it_interval; - setitimer(ITIMER_VIRTUAL, &timer, NULL); - return Val_unit; -} - -/* Create a thread */ - -value thread_new(value clos) /* ML */ -{ - caml_thread_t th; - /* Allocate the thread and its stack */ - Begin_root(clos); - th = (caml_thread_t) caml_alloc_shr(sizeof(struct caml_thread_struct) - / sizeof(value), 0); - End_roots(); - th->ident = next_ident; - next_ident = Val_int(Int_val(next_ident) + 1); - th->stack_low = (value *) caml_stat_alloc(Thread_stack_size); - th->stack_high = th->stack_low + Thread_stack_size / sizeof(value); - th->stack_threshold = th->stack_low + Stack_threshold / sizeof(value); - th->sp = th->stack_high; - th->trapsp = th->stack_high; - /* Set up a return frame that pretends we're applying the function to (). - This way, the next RETURN instruction will run the function. */ - th->sp -= 5; - th->sp[0] = Val_unit; /* dummy local to be popped by RETURN 1 */ - th->sp[1] = (value) Code_val(clos); - th->sp[2] = clos; - th->sp[3] = Val_long(0); /* no extra args */ - th->sp[4] = Val_unit; /* the () argument */ - /* Fake a C call frame */ - th->sp--; - th->sp[0] = Val_unit; /* a dummy environment */ - /* Finish initialization of th */ - th->backtrace_pos = Val_int(0); - th->backtrace_buffer = NULL; - th->backtrace_last_exn = Val_unit; - /* The thread is initially runnable */ - th->status = RUNNABLE; - th->fd = Val_int(0); - th->readfds = NO_FDS; - th->writefds = NO_FDS; - th->exceptfds = NO_FDS; - th->delay = NO_DELAY; - th->joining = NO_JOINING; - th->waitpid = NO_WAITPID; - th->retval = Val_unit; - /* Insert thread in doubly linked list of threads */ - th->prev = curr_thread->prev; - th->next = curr_thread; - Assign(curr_thread->prev->next, th); - Assign(curr_thread->prev, th); - /* Return thread */ - return (value) th; -} - -/* Return the thread identifier */ - -value thread_id(value th) /* ML */ -{ - return ((caml_thread_t)th)->ident; -} - -/* Return the current time as a floating-point number */ - -static double timeofday(void) -{ - struct timeval tv; - gettimeofday(&tv, NULL); - return (double) tv.tv_sec + (double) tv.tv_usec * 1e-6; -} - -/* Find a runnable thread and activate it */ - -#define FOREACH_THREAD(x) x = curr_thread; do { x = x->next; -#define END_FOREACH(x) } while (x != curr_thread) - -static value alloc_process_status(int pid, int status); -static void add_fdlist_to_set(value fdl, fd_set *set); -static value inter_fdlist_set(value fdl, fd_set *set, int *count); -static void find_bad_fd(int fd, fd_set *set); -static void find_bad_fds(value fdl, fd_set *set); - -static value schedule_thread(void) -{ - caml_thread_t run_thread, th; - fd_set readfds, writefds, exceptfds; - double delay, now; - int need_select, need_wait; - - /* Don't allow preemption during a callback */ - if (caml_callback_depth > 1) return curr_thread->retval; - - /* Save the status of the current thread */ - curr_thread->stack_low = caml_stack_low; - curr_thread->stack_high = caml_stack_high; - curr_thread->stack_threshold = caml_stack_threshold; - curr_thread->sp = caml_extern_sp; - curr_thread->trapsp = caml_trapsp; - curr_thread->backtrace_pos = Val_int(caml_backtrace_pos); - curr_thread->backtrace_buffer = caml_backtrace_buffer; - caml_modify (&curr_thread->backtrace_last_exn, caml_backtrace_last_exn); - -try_again: - /* Find if a thread is runnable. - Build fdsets and delay for select. - See if some join or wait operations succeeded. */ - run_thread = NULL; - FD_ZERO(&readfds); - FD_ZERO(&writefds); - FD_ZERO(&exceptfds); - delay = DELAY_INFTY; - now = -1.0; - need_select = 0; - need_wait = 0; - - FOREACH_THREAD(th) - if (th->status <= SUSPENDED) continue; - - if (th->status & (BLOCKED_READ - 1)) { - FD_SET(Int_val(th->fd), &readfds); - need_select = 1; - } - if (th->status & (BLOCKED_WRITE - 1)) { - FD_SET(Int_val(th->fd), &writefds); - need_select = 1; - } - if (th->status & (BLOCKED_SELECT - 1)) { - add_fdlist_to_set(th->readfds, &readfds); - add_fdlist_to_set(th->writefds, &writefds); - add_fdlist_to_set(th->exceptfds, &exceptfds); - need_select = 1; - } - if (th->status & (BLOCKED_DELAY - 1)) { - double th_delay; - if (now < 0.0) now = timeofday(); - th_delay = Double_val(th->delay) - now; - if (th_delay <= 0) { - th->status = RUNNABLE; - Assign(th->retval,RESUMED_DELAY); - } else { - if (th_delay < delay) delay = th_delay; - } - } - if (th->status & (BLOCKED_JOIN - 1)) { - if (((caml_thread_t)(th->joining))->status == KILLED) { - th->status = RUNNABLE; - Assign(th->retval, RESUMED_JOIN); - } - } - if (th->status & (BLOCKED_WAIT - 1)) { - int status, pid; - pid = waitpid(Int_val(th->waitpid), &status, WNOHANG); - if (pid > 0) { - th->status = RUNNABLE; - Assign(th->retval, alloc_process_status(pid, status)); - } else { - need_wait = 1; - } - } - END_FOREACH(th); - - /* Find if a thread is runnable. */ - run_thread = NULL; - FOREACH_THREAD(th) - if (th->status == RUNNABLE) { run_thread = th; break; } - END_FOREACH(th); - - /* Do the select if needed */ - if (need_select || run_thread == NULL) { - struct timeval delay_tv, * delay_ptr; - int retcode; - /* If a thread is blocked on wait, don't block forever */ - if (need_wait && delay > Thread_timeout * 1e-6) { - delay = Thread_timeout * 1e-6; - } - /* Convert delay to a timeval */ - /* If a thread is runnable, just poll */ - if (run_thread != NULL) { - delay_tv.tv_sec = 0; - delay_tv.tv_usec = 0; - delay_ptr = &delay_tv; - } - else if (delay != DELAY_INFTY) { - delay_tv.tv_sec = (unsigned int) delay; - delay_tv.tv_usec = (delay - (double) delay_tv.tv_sec) * 1E6; - delay_ptr = &delay_tv; - } - else { - delay_ptr = NULL; - } - caml_enter_blocking_section(); - retcode = select(FD_SETSIZE, &readfds, &writefds, &exceptfds, delay_ptr); - caml_leave_blocking_section(); - if (retcode == -1) - switch (errno) { - case EINTR: - break; - case EBADF: - /* One of the descriptors in the sets was closed or is bad. - Find it using fstat() and wake up the threads waiting on it - so that they'll get an error when operating on it. */ - FOREACH_THREAD(th) - if (th->status & (BLOCKED_READ - 1)) { - find_bad_fd(Int_val(th->fd), &readfds); - } - if (th->status & (BLOCKED_WRITE - 1)) { - find_bad_fd(Int_val(th->fd), &writefds); - } - if (th->status & (BLOCKED_SELECT - 1)) { - find_bad_fds(th->readfds, &readfds); - find_bad_fds(th->writefds, &writefds); - find_bad_fds(th->exceptfds, &exceptfds); - } - END_FOREACH(th); - retcode = FD_SETSIZE; - break; - default: - caml_sys_error(NO_ARG); - } - if (retcode > 0) { - /* Some descriptors are ready. - Mark the corresponding threads runnable. */ - FOREACH_THREAD(th) - if (retcode <= 0) break; - if ((th->status & (BLOCKED_READ - 1)) && - FD_ISSET(Int_val(th->fd), &readfds)) { - Assign(th->retval, RESUMED_IO); - th->status = RUNNABLE; - if (run_thread == NULL) run_thread = th; /* Found one. */ - /* Wake up only one thread per fd */ - FD_CLR(Int_val(th->fd), &readfds); - retcode--; - } - if ((th->status & (BLOCKED_WRITE - 1)) && - FD_ISSET(Int_val(th->fd), &writefds)) { - Assign(th->retval, RESUMED_IO); - th->status = RUNNABLE; - if (run_thread == NULL) run_thread = th; /* Found one. */ - /* Wake up only one thread per fd */ - FD_CLR(Int_val(th->fd), &readfds); - retcode--; - } - if (th->status & (BLOCKED_SELECT - 1)) { - value r = Val_unit, w = Val_unit, e = Val_unit; - Begin_roots3(r,w,e) - r = inter_fdlist_set(th->readfds, &readfds, &retcode); - w = inter_fdlist_set(th->writefds, &writefds, &retcode); - e = inter_fdlist_set(th->exceptfds, &exceptfds, &retcode); - if (r != NO_FDS || w != NO_FDS || e != NO_FDS) { - value retval = caml_alloc_small(3, TAG_RESUMED_SELECT); - Field(retval, 0) = r; - Field(retval, 1) = w; - Field(retval, 2) = e; - Assign(th->retval, retval); - th->status = RUNNABLE; - if (run_thread == NULL) run_thread = th; /* Found one. */ - } - End_roots(); - } - END_FOREACH(th); - } - /* If we get here with run_thread still NULL, one of the following - may have happened: - - a delay has expired - - a wait() needs to be polled again - - the select() failed (e.g. was interrupted) - In these cases, we go through the loop once more to make the - corresponding threads runnable. */ - if (run_thread == NULL && - (delay != DELAY_INFTY || need_wait || retcode == -1)) - goto try_again; - } - - /* If we haven't something to run at that point, we're in big trouble. */ - if (run_thread == NULL) caml_invalid_argument("Thread: deadlock"); - - /* Free everything the thread was waiting on */ - Assign(run_thread->readfds, NO_FDS); - Assign(run_thread->writefds, NO_FDS); - Assign(run_thread->exceptfds, NO_FDS); - Assign(run_thread->delay, NO_DELAY); - Assign(run_thread->joining, NO_JOINING); - run_thread->waitpid = NO_WAITPID; - - /* Activate the thread */ - curr_thread = run_thread; - caml_stack_low = curr_thread->stack_low; - caml_stack_high = curr_thread->stack_high; - caml_stack_threshold = curr_thread->stack_threshold; - caml_extern_sp = curr_thread->sp; - caml_trapsp = curr_thread->trapsp; - caml_backtrace_pos = Int_val(curr_thread->backtrace_pos); - caml_backtrace_buffer = curr_thread->backtrace_buffer; - caml_backtrace_last_exn = curr_thread->backtrace_last_exn; - return curr_thread->retval; -} - -/* Since context switching is not allowed in callbacks, a thread that - blocks during a callback is a deadlock. */ - -static void check_callback(void) -{ - if (caml_callback_depth > 1) - caml_fatal_error("Thread: deadlock during callback"); -} - -/* Reschedule without suspending the current thread */ - -value thread_yield(value unit) /* ML */ -{ - CAMLassert(curr_thread != NULL); - Assign(curr_thread->retval, Val_unit); - return schedule_thread(); -} - -/* Honor an asynchronous request for re-scheduling */ - -static void thread_reschedule(void) -{ - value accu; - - CAMLassert(curr_thread != NULL); - /* Pop accu from event frame, making it look like a C_CALL frame - followed by a RETURN frame */ - accu = *caml_extern_sp++; - /* Reschedule */ - Assign(curr_thread->retval, accu); - accu = schedule_thread(); - /* Push accu below C_CALL frame so that it looks like an event frame */ - *--caml_extern_sp = accu; -} - -/* Request a re-scheduling as soon as possible */ - -value thread_request_reschedule(value unit) /* ML */ -{ - caml_async_action_hook = thread_reschedule; - caml_something_to_do = 1; - return Val_unit; -} - -/* Suspend the current thread */ - -value thread_sleep(value unit) /* ML */ -{ - CAMLassert(curr_thread != NULL); - check_callback(); - curr_thread->status = SUSPENDED; - return schedule_thread(); -} - -/* Suspend the current thread on a read() or write() request */ - -static value thread_wait_rw(int kind, value fd) -{ - /* Don't do an error if we're not initialized yet - (we can be called from thread-safe Stdlib before initialization), - just return immediately. */ - if (curr_thread == NULL) return RESUMED_WAKEUP; - /* As a special case, if we're in a callback, don't fail but block - the whole process till I/O is possible */ - if (caml_callback_depth > 1) { - fd_set fds; - FD_ZERO(&fds); - FD_SET(Int_val(fd), &fds); - switch(kind) { - case BLOCKED_READ: select(FD_SETSIZE, &fds, NULL, NULL, NULL); break; - case BLOCKED_WRITE: select(FD_SETSIZE, NULL, &fds, NULL, NULL); break; - } - return RESUMED_IO; - } else { - curr_thread->fd = fd; - curr_thread->status = kind; - return schedule_thread(); - } -} - -value thread_wait_read(value fd) -{ - return thread_wait_rw(BLOCKED_READ, fd); -} - -value thread_wait_write(value fd) -{ - return thread_wait_rw(BLOCKED_WRITE, fd); -} - -/* Suspend the current thread on a read() or write() request with timeout */ - -static value thread_wait_timed_rw(int kind, value arg) -{ - double date; - - check_callback(); - curr_thread->fd = Field(arg, 0); - date = timeofday() + Double_val(Field(arg, 1)); - Assign(curr_thread->delay, caml_copy_double(date)); - curr_thread->status = kind | BLOCKED_DELAY; - return schedule_thread(); -} - -value thread_wait_timed_read(value arg) -{ - return thread_wait_timed_rw(BLOCKED_READ, arg); -} - -value thread_wait_timed_write(value arg) -{ - return thread_wait_timed_rw(BLOCKED_WRITE, arg); -} - -/* Suspend the current thread on a select() request */ - -value thread_select(value arg) /* ML */ -{ - double date; - check_callback(); - Assign(curr_thread->readfds, Field(arg, 0)); - Assign(curr_thread->writefds, Field(arg, 1)); - Assign(curr_thread->exceptfds, Field(arg, 2)); - date = Double_val(Field(arg, 3)); - if (date >= 0.0) { - date += timeofday(); - Assign(curr_thread->delay, caml_copy_double(date)); - curr_thread->status = BLOCKED_SELECT | BLOCKED_DELAY; - } else { - curr_thread->status = BLOCKED_SELECT; - } - return schedule_thread(); -} - -/* Primitives to implement suspension on buffered channels */ - -value thread_inchan_ready(value vchan) /* ML */ -{ - struct channel * chan = Channel(vchan); - return Val_bool(chan->curr < chan->max); -} - -value thread_outchan_ready(value vchan, value vsize) /* ML */ -{ - struct channel * chan = Channel(vchan); - intnat size = Long_val(vsize); - /* Negative size means we want to flush the buffer entirely */ - if (size < 0) { - return Val_bool(chan->curr == chan->buff); - } else { - int free = chan->end - chan->curr; - if (chan->curr == chan->buff) - return Val_bool(size < free); - else - return Val_bool(size <= free); - } -} - -/* Suspend the current thread for some time */ - -value thread_delay(value time) /* ML */ -{ - double date = timeofday() + Double_val(time); - CAMLassert(curr_thread != NULL); - check_callback(); - curr_thread->status = BLOCKED_DELAY; - Assign(curr_thread->delay, caml_copy_double(date)); - return schedule_thread(); -} - -/* Suspend the current thread until another thread terminates */ - -value thread_join(value th) /* ML */ -{ - check_callback(); - CAMLassert(curr_thread != NULL); - if (((caml_thread_t)th)->status == KILLED) return Val_unit; - curr_thread->status = BLOCKED_JOIN; - Assign(curr_thread->joining, th); - return schedule_thread(); -} - -/* Suspend the current thread until a Unix process exits */ - -value thread_wait_pid(value pid) /* ML */ -{ - CAMLassert(curr_thread != NULL); - check_callback(); - curr_thread->status = BLOCKED_WAIT; - curr_thread->waitpid = pid; - return schedule_thread(); -} - -/* Reactivate another thread */ - -value thread_wakeup(value thread) /* ML */ -{ - caml_thread_t th = (caml_thread_t) thread; - switch (th->status) { - case SUSPENDED: - th->status = RUNNABLE; - Assign(th->retval, RESUMED_WAKEUP); - break; - case KILLED: - caml_failwith("Thread.wakeup: killed thread"); - default: - caml_failwith("Thread.wakeup: thread not suspended"); - } - return Val_unit; -} - -/* Return the current thread */ - -value thread_self(value unit) /* ML */ -{ - CAMLassert(curr_thread != NULL); - return (value) curr_thread; -} - -/* Kill a thread */ - -value thread_kill(value thread) /* ML */ -{ - value retval = Val_unit; - caml_thread_t th = (caml_thread_t) thread; - if (th->status == KILLED) caml_failwith("Thread.kill: killed thread"); - /* Don't paint ourselves in a corner */ - if (th == th->next) caml_failwith("Thread.kill: cannot kill the last thread"); - /* This thread is no longer waiting on anything */ - th->status = KILLED; - /* If this is the current thread, activate another one */ - if (th == curr_thread) { - Begin_root(thread); - retval = schedule_thread(); - th = (caml_thread_t) thread; - End_roots(); - } - /* Remove thread from the doubly-linked list */ - Assign(th->prev->next, th->next); - Assign(th->next->prev, th->prev); - /* Free its resources */ - caml_stat_free((char *) th->stack_low); - th->stack_low = NULL; - th->stack_high = NULL; - th->stack_threshold = NULL; - th->sp = NULL; - th->trapsp = NULL; - if (th->backtrace_buffer != NULL) { - caml_stat_free(th->backtrace_buffer); - th->backtrace_buffer = NULL; - } - return retval; -} - -/* Print uncaught exception and backtrace */ - -value thread_uncaught_exception(value exn) /* ML */ -{ - char * msg = caml_format_exception(exn); - fprintf(stderr, "Thread %d killed on uncaught exception %s\n", - Int_val(curr_thread->ident), msg); - caml_stat_free(msg); - if (caml_backtrace_active) caml_print_exception_backtrace(); - fflush(stderr); - return Val_unit; -} - -/* Set a list of file descriptors in a fdset */ - -static void add_fdlist_to_set(value fdl, fd_set *set) -{ - for (/*nothing*/; fdl != NO_FDS; fdl = Field(fdl, 1)) { - int fd = Int_val(Field(fdl, 0)); - /* Ignore funky file descriptors, which can cause crashes */ - if (fd >= 0 && fd < FD_SETSIZE) FD_SET(fd, set); - } -} - -/* Build the intersection of a list and a fdset (the list of file descriptors - which are both in the list and in the fdset). */ - -static value inter_fdlist_set(value fdl, fd_set *set, int *count) -{ - value res = Val_unit; - value cons; - - Begin_roots2(fdl, res); - for (res = NO_FDS; fdl != NO_FDS; fdl = Field(fdl, 1)) { - int fd = Int_val(Field(fdl, 0)); - if (FD_ISSET(fd, set)) { - cons = caml_alloc_small(2, 0); - Field(cons, 0) = Val_int(fd); - Field(cons, 1) = res; - res = cons; - FD_CLR(fd, set); /* wake up only one thread per fd ready */ - (*count)--; - } - } - End_roots(); - return res; -} - -/* Find closed file descriptors in a waiting list and set them to 1 in - the given fdset */ - -static void find_bad_fd(int fd, fd_set *set) -{ - struct stat s; - if (fd >= 0 && fd < FD_SETSIZE && fstat(fd, &s) == -1 && errno == EBADF) - FD_SET(fd, set); -} - -static void find_bad_fds(value fdl, fd_set *set) -{ - for (/*nothing*/; fdl != NO_FDS; fdl = Field(fdl, 1)) - find_bad_fd(Int_val(Field(fdl, 0)), set); -} - -/* Auxiliary function for allocating the result of a waitpid() call */ - -#if !(defined(WIFEXITED) && defined(WEXITSTATUS) && defined(WIFSTOPPED) && \ - defined(WSTOPSIG) && defined(WTERMSIG)) -/* Assume old-style V7 status word */ -#define WIFEXITED(status) (((status) & 0xFF) == 0) -#define WEXITSTATUS(status) (((status) >> 8) & 0xFF) -#define WIFSTOPPED(status) (((status) & 0xFF) == 0xFF) -#define WSTOPSIG(status) (((status) >> 8) & 0xFF) -#define WTERMSIG(status) ((status) & 0x3F) -#endif - -#define TAG_WEXITED 0 -#define TAG_WSIGNALED 1 -#define TAG_WSTOPPED 2 - -static value alloc_process_status(int pid, int status) -{ - value st, res; - - if (WIFEXITED(status)) { - st = caml_alloc_small(1, TAG_WEXITED); - Field(st, 0) = Val_int(WEXITSTATUS(status)); - } - else if (WIFSTOPPED(status)) { - st = caml_alloc_small(1, TAG_WSTOPPED); - Field(st, 0) = Val_int(WSTOPSIG(status)); - } - else { - st = caml_alloc_small(1, TAG_WSIGNALED); - Field(st, 0) = Val_int(WTERMSIG(status)); - } - Begin_root(st); - res = caml_alloc_small(2, TAG_RESUMED_WAIT); - Field(res, 0) = Val_int(pid); - Field(res, 1) = st; - End_roots(); - return res; -} - -/* Restore the standard file descriptors to their initial state */ - -static void thread_restore_std_descr(void) -{ - if (stdin_initial_status != -1) fcntl(0, F_SETFL, stdin_initial_status); - if (stdout_initial_status != -1) fcntl(1, F_SETFL, stdout_initial_status); - if (stderr_initial_status != -1) fcntl(2, F_SETFL, stderr_initial_status); -} diff --git a/otherlibs/threads/stdlib.ml b/otherlibs/threads/stdlib.ml deleted file mode 100644 index d256f00a..00000000 --- a/otherlibs/threads/stdlib.ml +++ /dev/null @@ -1,707 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Same as ../../stdlib/stdlib.ml, except that I/O functions have - been redefined to not block the whole process, but only the calling - thread. *) - -(* Exceptions *) - -external register_named_value : string -> 'a -> unit - = "caml_register_named_value" - -let () = - (* for runtime/fail_nat.c *) - register_named_value "Pervasives.array_bound_error" - (Invalid_argument "index out of bounds") - - -external raise : exn -> 'a = "%raise" -external raise_notrace : exn -> 'a = "%raise_notrace" - -let failwith s = raise(Failure s) -let invalid_arg s = raise(Invalid_argument s) - -exception Exit -exception Match_failure = Match_failure -exception Assert_failure = Assert_failure -exception Invalid_argument = Invalid_argument -exception Failure = Failure -exception Not_found = Not_found -exception Out_of_memory = Out_of_memory -exception Stack_overflow = Stack_overflow -exception Sys_error = Sys_error -exception End_of_file = End_of_file -exception Division_by_zero = Division_by_zero -exception Sys_blocked_io = Sys_blocked_io -exception Undefined_recursive_module = Undefined_recursive_module - -(* Composition operators *) - -external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" -external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" - -(* Debugging *) - -external __LOC__ : string = "%loc_LOC" -external __FILE__ : string = "%loc_FILE" -external __LINE__ : int = "%loc_LINE" -external __MODULE__ : string = "%loc_MODULE" -external __POS__ : string * int * int * int = "%loc_POS" - -external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC" -external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE" -external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS" - -(* Comparisons *) - -external ( = ) : 'a -> 'a -> bool = "%equal" -external ( <> ) : 'a -> 'a -> bool = "%notequal" -external ( < ) : 'a -> 'a -> bool = "%lessthan" -external ( > ) : 'a -> 'a -> bool = "%greaterthan" -external ( <= ) : 'a -> 'a -> bool = "%lessequal" -external ( >= ) : 'a -> 'a -> bool = "%greaterequal" -external compare : 'a -> 'a -> int = "%compare" - -let min x y = if x <= y then x else y -let max x y = if x >= y then x else y - -external ( == ) : 'a -> 'a -> bool = "%eq" -external ( != ) : 'a -> 'a -> bool = "%noteq" - -(* Boolean operations *) - -external not : bool -> bool = "%boolnot" -external ( & ) : bool -> bool -> bool = "%sequand" -external ( && ) : bool -> bool -> bool = "%sequand" -external ( or ) : bool -> bool -> bool = "%sequor" -external ( || ) : bool -> bool -> bool = "%sequor" - -(* Integer operations *) - -external ( ~- ) : int -> int = "%negint" -external ( ~+ ) : int -> int = "%identity" -external succ : int -> int = "%succint" -external pred : int -> int = "%predint" -external ( + ) : int -> int -> int = "%addint" -external ( - ) : int -> int -> int = "%subint" -external ( * ) : int -> int -> int = "%mulint" -external ( / ) : int -> int -> int = "%divint" -external ( mod ) : int -> int -> int = "%modint" - -let abs x = if x >= 0 then x else -x - -external ( land ) : int -> int -> int = "%andint" -external ( lor ) : int -> int -> int = "%orint" -external ( lxor ) : int -> int -> int = "%xorint" - -let lnot x = x lxor (-1) - -external ( lsl ) : int -> int -> int = "%lslint" -external ( lsr ) : int -> int -> int = "%lsrint" -external ( asr ) : int -> int -> int = "%asrint" - -let max_int = (-1) lsr 1 -let min_int = max_int + 1 - -(* Floating-point operations *) - -external ( ~-. ) : float -> float = "%negfloat" -external ( ~+. ) : float -> float = "%identity" -external ( +. ) : float -> float -> float = "%addfloat" -external ( -. ) : float -> float -> float = "%subfloat" -external ( *. ) : float -> float -> float = "%mulfloat" -external ( /. ) : float -> float -> float = "%divfloat" -external ( ** ) : float -> float -> float = "caml_power_float" "pow" - [@@unboxed] [@@noalloc] -external exp : float -> float = "caml_exp_float" "exp" [@@unboxed] [@@noalloc] -external expm1 : float -> float = "caml_expm1_float" "caml_expm1" - [@@unboxed] [@@noalloc] -external acos : float -> float = "caml_acos_float" "acos" - [@@unboxed] [@@noalloc] -external asin : float -> float = "caml_asin_float" "asin" - [@@unboxed] [@@noalloc] -external atan : float -> float = "caml_atan_float" "atan" - [@@unboxed] [@@noalloc] -external atan2 : float -> float -> float = "caml_atan2_float" "atan2" - [@@unboxed] [@@noalloc] -external hypot : float -> float -> float - = "caml_hypot_float" "caml_hypot" [@@unboxed] [@@noalloc] -external cos : float -> float = "caml_cos_float" "cos" [@@unboxed] [@@noalloc] -external cosh : float -> float = "caml_cosh_float" "cosh" - [@@unboxed] [@@noalloc] -external log : float -> float = "caml_log_float" "log" [@@unboxed] [@@noalloc] -external log10 : float -> float = "caml_log10_float" "log10" - [@@unboxed] [@@noalloc] -external log1p : float -> float = "caml_log1p_float" "caml_log1p" - [@@unboxed] [@@noalloc] -external sin : float -> float = "caml_sin_float" "sin" [@@unboxed] [@@noalloc] -external sinh : float -> float = "caml_sinh_float" "sinh" - [@@unboxed] [@@noalloc] -external sqrt : float -> float = "caml_sqrt_float" "sqrt" - [@@unboxed] [@@noalloc] -external tan : float -> float = "caml_tan_float" "tan" [@@unboxed] [@@noalloc] -external tanh : float -> float = "caml_tanh_float" "tanh" - [@@unboxed] [@@noalloc] -external ceil : float -> float = "caml_ceil_float" "ceil" - [@@unboxed] [@@noalloc] -external floor : float -> float = "caml_floor_float" "floor" - [@@unboxed] [@@noalloc] -external abs_float : float -> float = "%absfloat" -external copysign : float -> float -> float - = "caml_copysign_float" "caml_copysign" - [@@unboxed] [@@noalloc] -external mod_float : float -> float -> float = "caml_fmod_float" "fmod" - [@@unboxed] [@@noalloc] -external frexp : float -> float * int = "caml_frexp_float" -external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) = - "caml_ldexp_float" "caml_ldexp_float_unboxed" [@@noalloc] -external modf : float -> float * float = "caml_modf_float" -external float : int -> float = "%floatofint" -external float_of_int : int -> float = "%floatofint" -external truncate : float -> int = "%intoffloat" -external int_of_float : float -> int = "%intoffloat" -external float_of_bits : int64 -> float - = "caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed" - [@@unboxed] [@@noalloc] -let infinity = - float_of_bits 0x7F_F0_00_00_00_00_00_00L -let neg_infinity = - float_of_bits 0xFF_F0_00_00_00_00_00_00L -let nan = - float_of_bits 0x7F_F0_00_00_00_00_00_01L -let max_float = - float_of_bits 0x7F_EF_FF_FF_FF_FF_FF_FFL -let min_float = - float_of_bits 0x00_10_00_00_00_00_00_00L -let epsilon_float = - float_of_bits 0x3C_B0_00_00_00_00_00_00L - -type fpclass = - FP_normal - | FP_subnormal - | FP_zero - | FP_infinite - | FP_nan -external classify_float : (float [@unboxed]) -> fpclass = - "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc] - -(* String and byte sequence operations -- more in modules String and Bytes *) - -external string_length : string -> int = "%string_length" -external bytes_length : bytes -> int = "%bytes_length" -external bytes_create : int -> bytes = "caml_create_bytes" -external string_blit : string -> int -> bytes -> int -> int -> unit - = "caml_blit_string" [@@noalloc] -external bytes_blit : bytes -> int -> bytes -> int -> int -> unit - = "caml_blit_bytes" [@@noalloc] -external bytes_unsafe_to_string : bytes -> string = "%bytes_to_string" -external bytes_unsafe_of_string : string -> bytes = "%bytes_of_string" - -let ( ^ ) s1 s2 = - let l1 = string_length s1 and l2 = string_length s2 in - let s = bytes_create (l1 + l2) in - string_blit s1 0 s 0 l1; - string_blit s2 0 s l1 l2; - bytes_unsafe_to_string s - -(* Character operations -- more in module Char *) - -external int_of_char : char -> int = "%identity" -external unsafe_char_of_int : int -> char = "%identity" -let char_of_int n = - if n < 0 || n > 255 then invalid_arg "char_of_int" else unsafe_char_of_int n - -(* Unit operations *) - -external ignore : 'a -> unit = "%ignore" - -(* Pair operations *) - -external fst : 'a * 'b -> 'a = "%field0" -external snd : 'a * 'b -> 'b = "%field1" - -(* References *) - -type 'a ref = { mutable contents : 'a } -external ref : 'a -> 'a ref = "%makemutable" -external ( ! ) : 'a ref -> 'a = "%field0" -external ( := ) : 'a ref -> 'a -> unit = "%setfield0" -external incr : int ref -> unit = "%incr" -external decr : int ref -> unit = "%decr" - -(* Result type *) - -type ('a,'b) result = Ok of 'a | Error of 'b - -(* String conversion functions *) - -external format_int : string -> int -> string = "caml_format_int" -external format_float : string -> float -> string = "caml_format_float" - -let string_of_bool b = - if b then "true" else "false" -let bool_of_string = function - | "true" -> true - | "false" -> false - | _ -> invalid_arg "bool_of_string" - -let bool_of_string_opt = function - | "true" -> Some true - | "false" -> Some false - | _ -> None - -let string_of_int n = - format_int "%d" n - -external int_of_string : string -> int = "caml_int_of_string" - -let int_of_string_opt s = - (* TODO: provide this directly as a non-raising primitive. *) - try Some (int_of_string s) - with Failure _ -> None - -external string_get : string -> int -> char = "%string_safe_get" - -let valid_float_lexem s = - let l = string_length s in - let rec loop i = - if i >= l then s ^ "." else - match string_get s i with - | '0' .. '9' | '-' -> loop (i + 1) - | _ -> s - in - loop 0 - -let string_of_float f = valid_float_lexem (format_float "%.12g" f) - -external float_of_string : string -> float = "caml_float_of_string" - -let float_of_string_opt s = - (* TODO: provide this directly as a non-raising primitive. *) - try Some (float_of_string s) - with Failure _ -> None - -(* List operations -- more in module List *) - -let rec ( @ ) l1 l2 = - match l1 with - [] -> l2 - | hd :: tl -> hd :: (tl @ l2) - -(* I/O operations *) - -type in_channel -type out_channel - -external open_descriptor_out : int -> out_channel - = "caml_ml_open_descriptor_out" -external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in" - -let stdin = open_descriptor_in 0 -let stdout = open_descriptor_out 1 -let stderr = open_descriptor_out 2 - -(* Non-blocking stuff *) - -external thread_wait_read_prim : Unix.file_descr -> unit = "thread_wait_read" -external thread_wait_write_prim : Unix.file_descr -> unit = "thread_wait_write" - -let thread_wait_read fd = thread_wait_read_prim fd -let thread_wait_write fd = thread_wait_write_prim fd - -external descr_inchan : in_channel -> Unix.file_descr - = "caml_channel_descriptor" -external descr_outchan : out_channel -> Unix.file_descr - = "caml_channel_descriptor" - -let wait_inchan ic = thread_wait_read (descr_inchan ic) - -let wait_outchan oc len = thread_wait_write (descr_outchan oc) - -(* General output functions *) - -type open_flag = - Open_rdonly | Open_wronly | Open_append - | Open_creat | Open_trunc | Open_excl - | Open_binary | Open_text | Open_nonblock - -external open_desc : string -> open_flag list -> int -> int = "caml_sys_open" - -external set_out_channel_name: out_channel -> string -> unit = - "caml_ml_set_channel_name" - -let open_out_gen mode perm name = - let c = open_descriptor_out(open_desc name mode perm) in - set_out_channel_name c name; - c - -let open_out name = - open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name - -let open_out_bin name = - open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name - -external flush_partial : out_channel -> bool = "caml_ml_flush_partial" - -let rec flush oc = - let success = - try - flush_partial oc - with Sys_blocked_io -> - wait_outchan oc (-1); false in - if success then () else flush oc - -external out_channels_list : unit -> out_channel list - = "caml_ml_out_channels_list" - -let flush_all () = - let rec iter = function - [] -> () - | a::l -> - begin try - flush a - with Sys_error _ -> - () (* ignore channels closed during a preceding flush. *) - end; - iter l - in iter (out_channels_list ()) - -external unsafe_output_partial : out_channel -> bytes -> int -> int -> int - = "caml_ml_output_partial" - -let rec unsafe_output oc buf pos len = - if len > 0 then begin - let written = - try - unsafe_output_partial oc buf pos len - with Sys_blocked_io -> - wait_outchan oc len; 0 in - unsafe_output oc buf (pos + written) (len - written) - end - -external output_char_blocking : out_channel -> char -> unit - = "caml_ml_output_char" -external output_byte_blocking : out_channel -> int -> unit - = "caml_ml_output_char" - -let rec output_char oc c = - try - output_char_blocking oc c - with Sys_blocked_io -> - wait_outchan oc 1; output_char oc c - -let output_bytes oc s = - unsafe_output oc s 0 (bytes_length s) - -let output_string oc s = - unsafe_output oc (bytes_unsafe_of_string s) 0 (string_length s) - -let output oc s ofs len = - if ofs < 0 || len < 0 || ofs > bytes_length s - len - then invalid_arg "output" - else unsafe_output oc s ofs len - -let output_substring oc s ofs len = - output oc (bytes_unsafe_of_string s) ofs len - -let rec output_byte oc b = - try - output_byte_blocking oc b - with Sys_blocked_io -> - wait_outchan oc 1; output_byte oc b - -let output_binary_int oc n = - output_byte oc (n asr 24); - output_byte oc (n asr 16); - output_byte oc (n asr 8); - output_byte oc n - -external marshal_to_string : 'a -> unit list -> string - = "caml_output_value_to_string" - -let output_value oc v = output_string oc (marshal_to_string v []) - -external seek_out_blocking : out_channel -> int -> unit = "caml_ml_seek_out" - -let seek_out oc pos = flush oc; seek_out_blocking oc pos - -external pos_out : out_channel -> int = "caml_ml_pos_out" -external out_channel_length : out_channel -> int = "caml_ml_channel_size" -external close_out_channel : out_channel -> unit = "caml_ml_close_channel" -let close_out oc = flush oc; close_out_channel oc -let close_out_noerr oc = - (try flush oc with _ -> ()); - (try close_out_channel oc with _ -> ()) -external set_binary_mode_out : out_channel -> bool -> unit - = "caml_ml_set_binary_mode" - -(* General input functions *) - -external set_in_channel_name: in_channel -> string -> unit = - "caml_ml_set_channel_name" - -let open_in_gen mode perm name = - let c = open_descriptor_in(open_desc name mode perm) in - set_in_channel_name c name; - c - -let open_in name = - open_in_gen [Open_rdonly; Open_text] 0 name - -let open_in_bin name = - open_in_gen [Open_rdonly; Open_binary] 0 name - -external input_char_blocking : in_channel -> char = "caml_ml_input_char" -external input_byte_blocking : in_channel -> int = "caml_ml_input_char" - -let rec input_char ic = - try - input_char_blocking ic - with Sys_blocked_io -> - wait_inchan ic; input_char ic - -external unsafe_input_blocking : in_channel -> bytes -> int -> int -> int - = "caml_ml_input" - -let rec unsafe_input ic s ofs len = - try - unsafe_input_blocking ic s ofs len - with Sys_blocked_io -> - wait_inchan ic; unsafe_input ic s ofs len - -let input ic s ofs len = - if ofs < 0 || len < 0 || ofs > bytes_length s - len - then invalid_arg "input" - else unsafe_input ic s ofs len - -let rec unsafe_really_input ic s ofs len = - if len <= 0 then () else begin - let r = unsafe_input ic s ofs len in - if r = 0 - then raise End_of_file - else unsafe_really_input ic s (ofs + r) (len - r) - end - -let really_input ic s ofs len = - if ofs < 0 || len < 0 || ofs > bytes_length s - len - then invalid_arg "really_input" - else unsafe_really_input ic s ofs len - -let really_input_string ic len = - let s = bytes_create len in - really_input ic s 0 len; - bytes_unsafe_to_string s - -external bytes_set : bytes -> int -> char -> unit = "%bytes_safe_set" - -let input_line ic = - let buf = ref (bytes_create 128) in - let pos = ref 0 in - begin try - while true do - if !pos = bytes_length !buf then begin - let newbuf = bytes_create (2 * !pos) in - bytes_blit !buf 0 newbuf 0 !pos; - buf := newbuf - end; - let c = input_char ic in - if c = '\n' then raise Exit; - bytes_set !buf !pos c; - incr pos - done - with Exit -> () - | End_of_file -> if !pos = 0 then raise End_of_file - end; - let res = bytes_create !pos in - bytes_blit !buf 0 res 0 !pos; - bytes_unsafe_to_string res - -let rec input_byte ic = - try - input_byte_blocking ic - with Sys_blocked_io -> - wait_inchan ic; input_byte ic - -let input_binary_int ic = - let b1 = input_byte ic in - let n1 = if b1 >= 128 then b1 - 256 else b1 in - let b2 = input_byte ic in - let b3 = input_byte ic in - let b4 = input_byte ic in - (n1 lsl 24) + (b2 lsl 16) + (b3 lsl 8) + b4 - -external unmarshal : bytes -> int -> 'a = "caml_input_value_from_string" -external marshal_data_size : bytes -> int -> int = "caml_marshal_data_size" - -let input_value ic = - let header = bytes_create 20 in - really_input ic header 0 20; - let bsize = marshal_data_size header 0 in - let buffer = bytes_create (20 + bsize) in - bytes_blit header 0 buffer 0 20; - really_input ic buffer 20 bsize; - unmarshal buffer 0 - -external seek_in : in_channel -> int -> unit = "caml_ml_seek_in" -external pos_in : in_channel -> int = "caml_ml_pos_in" -external in_channel_length : in_channel -> int = "caml_ml_channel_size" -external close_in : in_channel -> unit = "caml_ml_close_channel" -let close_in_noerr ic = (try close_in ic with _ -> ()) -external set_binary_mode_in : in_channel -> bool -> unit - = "caml_ml_set_binary_mode" - -(* Output functions on standard output *) - -let print_char c = output_char stdout c -let print_string s = output_string stdout s -let print_bytes s = output_bytes stdout s -let print_int i = output_string stdout (string_of_int i) -let print_float f = output_string stdout (string_of_float f) -let print_endline s = - output_string stdout s; output_char stdout '\n'; flush stdout -let print_newline () = output_char stdout '\n'; flush stdout - -(* Output functions on standard error *) - -let prerr_char c = output_char stderr c -let prerr_string s = output_string stderr s -let prerr_bytes s = output_bytes stderr s -let prerr_int i = output_string stderr (string_of_int i) -let prerr_float f = output_string stderr (string_of_float f) -let prerr_endline s = - output_string stderr s; output_char stderr '\n'; flush stderr -let prerr_newline () = output_char stderr '\n'; flush stderr - -(* Input functions on standard input *) - -let read_line () = flush stdout; input_line stdin -let read_int () = int_of_string(read_line()) -let read_int_opt () = int_of_string_opt(read_line()) -let read_float () = float_of_string(read_line()) -let read_float_opt () = float_of_string_opt(read_line()) - -(* Operations on large files *) - -module LargeFile = - struct - external seek_out : out_channel -> int64 -> unit = "caml_ml_seek_out_64" - external pos_out : out_channel -> int64 = "caml_ml_pos_out_64" - external out_channel_length : out_channel -> int64 - = "caml_ml_channel_size_64" - external seek_in : in_channel -> int64 -> unit = "caml_ml_seek_in_64" - external pos_in : in_channel -> int64 = "caml_ml_pos_in_64" - external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64" - end - -(* Formats *) - -type ('a, 'b, 'c, 'd, 'e, 'f) format6 - = ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6 - = Format of ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt - * string - -type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 - -type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 - -let string_of_format (Format (_fmt, str)) = str - -external format_of_string : - ('a, 'b, 'c, 'd, 'e, 'f) format6 -> - ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" - -let ( ^^ ) (Format (fmt1, str1)) (Format (fmt2, str2)) = - Format (CamlinternalFormatBasics.concat_fmt fmt1 fmt2, - str1 ^ "%," ^ str2) - -(* Miscellaneous *) - -external sys_exit : int -> 'a = "caml_sys_exit" - -let exit_function = ref flush_all - -let at_exit f = - let g = !exit_function in - (* MPR#7253, MPR#7796: make sure "f" is executed only once *) - let f_already_ran = ref false in - exit_function := - (fun () -> - if not !f_already_ran then begin f_already_ran := true; f() end; - g()) - -let do_at_exit () = (!exit_function) () - -let exit retcode = - do_at_exit (); - sys_exit retcode - -let _ = register_named_value "Pervasives.do_at_exit" do_at_exit - -(*MODULE_ALIASES*) -module Arg = Arg -module Array = Array -module ArrayLabels = ArrayLabels -module Bigarray = Bigarray -module Bool = Bool -module Buffer = Buffer -module Bytes = Bytes -module BytesLabels = BytesLabels -module Callback = Callback -module Char = Char -module Complex = Complex -module Digest = Digest -module Ephemeron = Ephemeron -module Filename = Filename -module Float = Float -module Format = Format -module Fun = Fun -module Gc = Gc -module Genlex = Genlex -module Hashtbl = Hashtbl -module Int = Int -module Int32 = Int32 -module Int64 = Int64 -module Lazy = Lazy -module Lexing = Lexing -module List = List -module ListLabels = ListLabels -module Map = Map -module Marshal = Marshal -module MoreLabels = MoreLabels -module Nativeint = Nativeint -module Obj = Obj -module Oo = Oo -module Option = Option -module Parsing = Parsing -module Pervasives = Pervasives -module Printexc = Printexc -module Printf = Printf -module Queue = Queue -module Random = Random -module Result = Result -module Scanf = Scanf -module Seq = Seq -module Set = Set -module Spacetime = Spacetime -module Stack = Stack -module StdLabels = StdLabels -module Stream = Stream -module String = String -module StringLabels = StringLabels -module Sys = Sys -module Uchar = Uchar -module Unit = Unit -module Weak = Weak diff --git a/otherlibs/threads/thread.ml b/otherlibs/threads/thread.ml deleted file mode 100644 index c4561e18..00000000 --- a/otherlibs/threads/thread.ml +++ /dev/null @@ -1,147 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* User-level threads *) - -type t - -let critical_section = ref false - -type resumption_status = - Resumed_wakeup - | Resumed_delay - | Resumed_join - | Resumed_io - | Resumed_select of - Unix.file_descr list * Unix.file_descr list * Unix.file_descr list - | Resumed_wait of int * Unix.process_status - -(* to avoid warning *) -let _ = [Resumed_wakeup; Resumed_delay; Resumed_join; - Resumed_io; Resumed_select ([], [], []); - Resumed_wait (0, Unix.WEXITED 0)] - -(* It is mucho important that the primitives that reschedule are called - through an ML function call, not directly. That's because when such a - primitive returns, the bytecode interpreter is only semi-obedient: - it takes sp from the new thread, but keeps pc from the old thread. - But that's OK if all calls to rescheduling primitives are immediately - followed by a RETURN operation, which will restore the correct pc - from the stack. Furthermore, the RETURNs must all have the same - frame size, which means that both the primitives and their ML wrappers - must take exactly one argument. *) - -external thread_initialize : unit -> unit = "thread_initialize" -external thread_initialize_preemption : unit -> unit - = "thread_initialize_preemption" -external thread_new : (unit -> unit) -> t = "thread_new" -external thread_yield : unit -> unit = "thread_yield" -external thread_request_reschedule : unit -> unit = "thread_request_reschedule" -external thread_sleep : unit -> unit = "thread_sleep" -external thread_wait_read : Unix.file_descr -> unit = "thread_wait_read" -external thread_wait_write : Unix.file_descr -> unit = "thread_wait_write" -external thread_wait_timed_read : - Unix.file_descr * float -> resumption_status (* remember: 1 arg *) - = "thread_wait_timed_read" -external thread_wait_timed_write : - Unix.file_descr * float -> resumption_status (* remember: 1 arg *) - = "thread_wait_timed_write" -external thread_select : - Unix.file_descr list * Unix.file_descr list * (* remember: 1 arg *) - Unix.file_descr list * float -> resumption_status - = "thread_select" -external thread_join : t -> unit = "thread_join" -external thread_delay : float -> unit = "thread_delay" -external thread_wait_pid : int -> resumption_status = "thread_wait_pid" -external thread_wakeup : t -> unit = "thread_wakeup" -external thread_self : unit -> t = "thread_self" [@@noalloc] -external thread_kill : t -> unit = "thread_kill" -external thread_uncaught_exception : exn -> unit = "thread_uncaught_exception" -external thread_id : t -> int = "thread_id" [@@noalloc] - -(* In sleep() below, we rely on the fact that signals are detected - only at function applications and beginning of loops, - making all other operations atomic. *) - -let yield () = thread_yield() -let sleep () = critical_section := false; thread_sleep() -let delay duration = thread_delay duration -let join th = thread_join th -let wakeup pid = thread_wakeup pid -let self () = thread_self() -let kill pid = thread_kill pid -let exit () = thread_kill(thread_self()) -let id t = thread_id t - -let select_aux arg = thread_select arg - -let select readfds writefds exceptfds delay = - match select_aux (readfds, writefds, exceptfds, delay) with - Resumed_select(r, w, e) -> (r, w, e) - | _ -> ([], [], []) - -let wait_read fd = thread_wait_read fd -let wait_write fd = thread_wait_write fd - -let wait_timed_read_aux arg = thread_wait_timed_read arg -let wait_timed_write_aux arg = thread_wait_timed_write arg - -let wait_timed_read fd delay = - match wait_timed_read_aux (fd, delay) with Resumed_io -> true | _ -> false - -let wait_timed_write fd delay = - match wait_timed_write_aux (fd, delay) with Resumed_io -> true | _ -> false - -let wait_pid_aux pid = thread_wait_pid pid - -let wait_pid pid = - match wait_pid_aux pid with - Resumed_wait(pid, status) -> (pid, status) - | _ -> invalid_arg "Thread.wait_pid" - -let wait_signal sigs = - let gotsig = ref 0 in - let self = thread_self() in - let sighandler s = gotsig := s; wakeup self in - let oldhdlrs = - List.map (fun s -> Sys.signal s (Sys.Signal_handle sighandler)) sigs in - if !gotsig = 0 then sleep(); - List.iter2 Sys.set_signal sigs oldhdlrs; - !gotsig - -(* For Thread.create, make sure the function passed to thread_new - always terminates by calling Thread.exit. *) - -let create fn arg = - thread_new - (fun () -> - try - fn arg; exit() - with x -> - flush stdout; flush stderr; - thread_uncaught_exception x; - exit()) - -(* Preemption *) - -let preempt signal = - if !critical_section then () else thread_request_reschedule() - -(* Initialization of the scheduler *) - -let _ = - thread_initialize(); - Sys.set_signal Sys.sigvtalrm (Sys.Signal_handle preempt); - thread_initialize_preemption() diff --git a/otherlibs/threads/thread.mli b/otherlibs/threads/thread.mli deleted file mode 100644 index a835a0fb..00000000 --- a/otherlibs/threads/thread.mli +++ /dev/null @@ -1,140 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Lightweight threads. *) - -type t -(** The type of thread handles. *) - - -(** {1 Thread creation and termination} *) - -val create : ('a -> 'b) -> 'a -> t -(** [Thread.create funct arg] creates a new thread of control, - in which the function application [funct arg] - is executed concurrently with the other threads of the program. - The application of [Thread.create] - returns the handle of the newly created thread. - The new thread terminates when the application [funct arg] - returns, either normally or by raising an uncaught exception. - In the latter case, the exception is printed on standard error, - but not propagated back to the parent thread. Similarly, the - result of the application [funct arg] is discarded and not - directly accessible to the parent thread. *) - -val self : unit -> t -(** Return the thread currently executing. *) - -val id : t -> int -(** Return the identifier of the given thread. A thread identifier - is an integer that identifies uniquely the thread. - It can be used to build data structures indexed by threads. *) - -val exit : unit -> unit -(** Terminate prematurely the currently executing thread. *) - -val kill : t -> unit -(** Terminate prematurely the thread whose handle is given. - This functionality is available only with bytecode-level threads. *) - -(** {1 Suspending threads} *) - -val delay : float -> unit -(** [delay d] suspends the execution of the calling thread for - [d] seconds. The other program threads continue to run during - this time. *) - -val join : t -> unit -(** [join th] suspends the execution of the calling thread - until the thread [th] has terminated. *) - -val wait_read : Unix.file_descr -> unit -(** See {!Thread.wait_write}.*) - -val wait_write : Unix.file_descr -> unit -(** Suspend the execution of the calling thread until at least - one character or EOF is available for reading ({!Thread.wait_read}) or - one character can be written without blocking ([wait_write]) - on the given Unix file descriptor. *) - -val wait_timed_read : Unix.file_descr -> float -> bool -(** See {!Thread.wait_timed_write}.*) - -val wait_timed_write : Unix.file_descr -> float -> bool -(** Same as {!Thread.wait_read} and {!Thread.wait_write}, but wait for at most - the amount of time given as second argument (in seconds). - Return [true] if the file descriptor is ready for input/output - and [false] if the timeout expired. *) - -val select : - Unix.file_descr list -> Unix.file_descr list -> Unix.file_descr list -> - float -> - Unix.file_descr list * Unix.file_descr list * Unix.file_descr list -(** Suspend the execution of the calling thread until input/output - becomes possible on the given Unix file descriptors. - The arguments and results have the same meaning as for - {!Unix.select}. *) - -val wait_pid : int -> int * Unix.process_status -(** [wait_pid p] suspends the execution of the calling thread - until the Unix process specified by the process identifier [p] - terminates. A pid [p] of [-1] means wait for any child. - A pid of [0] means wait for any child in the same process group - as the current process. Negative pid arguments represent - process groups. Returns the pid of the child caught and - its termination status, as per {!Unix.wait}. *) - -val wait_signal : int list -> int -(** [wait_signal sigs] suspends the execution of the calling thread - until the process receives one of the signals specified in the - list [sigs]. It then returns the number of the signal received. - Signal handlers attached to the signals in [sigs] will not - be invoked. Do not call [wait_signal] concurrently - from several threads on the same signals. *) - -val yield : unit -> unit -(** Re-schedule the calling thread without suspending it. - This function can be used to give scheduling hints, - telling the scheduler that now is a good time to - switch to other threads. *) - -(**/**) - -(** {1 Synchronization primitives} - - The following primitives provide the basis for implementing - synchronization functions between threads. Their direct use is - discouraged, as they are very low-level and prone to race conditions - and deadlocks. The modules {!Mutex}, {!Condition} and {!Event} - provide higher-level synchronization primitives. *) - -val critical_section : bool ref -(** Setting this reference to [true] deactivate thread preemption - (the timer interrupt that transfers control from thread to thread), - causing the current thread to run uninterrupted until - [critical_section] is reset to [false] or the current thread - explicitly relinquishes control using [sleep], [delay], - [wait_inchan] or [wait_descr]. *) - -val sleep : unit -> unit -(** Suspend the calling thread until another thread reactivates it - using {!Thread.wakeup}. Just before suspending the thread, - {!Thread.critical_section} is reset to [false]. Resetting - {!Thread.critical_section} and suspending the calling thread is an - atomic operation. *) - -val wakeup : t -> unit -(** Reactivate the given thread. After the call to [wakeup], - the suspended thread will resume execution at some future time. *) diff --git a/otherlibs/threads/threadUnix.ml b/otherlibs/threads/threadUnix.ml deleted file mode 100644 index 95b5857a..00000000 --- a/otherlibs/threads/threadUnix.ml +++ /dev/null @@ -1,68 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Module [ThreadUnix]: thread-compatible system calls *) - -let execv = Unix.execv -let execve = Unix.execve -let execvp = Unix.execvp -let wait = Unix.wait -let waitpid = Unix.waitpid -let system = Unix.system -let read = Unix.read -let write = Unix.write -let single_write = Unix.single_write -let write_substring = Unix.write_substring -let single_write_substring = Unix.single_write_substring -let select = Unix.select -let pipe = Unix.pipe -let open_process_in = Unix.open_process_in -let open_process_out = Unix.open_process_out -let open_process = Unix.open_process -let open_process_full = Unix.open_process_full -let sleep = Unix.sleep -let socket = Unix.socket -let socketpair = Unix.socketpair -let accept = Unix.accept -let connect = Unix.connect -let recv = Unix.recv -let recvfrom = Unix.recvfrom -let send = Unix.send -let send_substring = Unix.send_substring -let sendto = Unix.sendto -let sendto_substring = Unix.sendto_substring -let open_connection = Unix.open_connection -let establish_server = Unix.establish_server - -open Unix - -let rec timed_read fd buff ofs len timeout = - if Thread.wait_timed_read fd timeout - then begin try Unix.read fd buff ofs len - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - timed_read fd buff ofs len timeout - end - else raise (Unix_error(ETIMEDOUT, "timed_read", "")) - -let rec timed_write fd buff ofs len timeout = - if Thread.wait_timed_write fd timeout - then begin try Unix.write fd buff ofs len - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - timed_write fd buff ofs len timeout - end - else raise (Unix_error(ETIMEDOUT, "timed_write", "")) - -let timed_write_substring fd buff ofs len timeout = - timed_write fd (Bytes.unsafe_of_string buff) ofs len timeout diff --git a/otherlibs/threads/threadUnix.mli b/otherlibs/threads/threadUnix.mli deleted file mode 100644 index bd37f710..00000000 --- a/otherlibs/threads/threadUnix.mli +++ /dev/null @@ -1,104 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Thread-compatible system calls. - - @deprecated The functionality of this module has been merged back into - the {!Unix} module. Threaded programs can now call the functions - from module {!Unix} directly, and still get the correct behavior - (block the calling thread, if required, but do not block all threads - in the process). *) - -(** {1 Process handling} *) - -val execv : string -> string array -> unit -val execve : string -> string array -> string array -> unit -val execvp : string -> string array -> unit -val wait : unit -> int * Unix.process_status -val waitpid : Unix.wait_flag list -> int -> int * Unix.process_status -val system : string -> Unix.process_status - -(** {1 Basic input/output} *) - -val read : Unix.file_descr -> bytes -> int -> int -> int -val write : Unix.file_descr -> bytes -> int -> int -> int -val single_write : Unix.file_descr -> bytes -> int -> int -> int -val write_substring : Unix.file_descr -> string -> int -> int -> int -val single_write_substring : Unix.file_descr -> string -> int -> int -> int - -(** {1 Input/output with timeout} *) - -val timed_read : Unix.file_descr -> bytes -> int -> int -> float -> int -(** See {!ThreadUnix.timed_write}. *) - -val timed_write : Unix.file_descr -> bytes -> int -> int -> float -> int -(** Behave as {!ThreadUnix.read} and {!ThreadUnix.write}, except that - [Unix_error(ETIMEDOUT,_,_)] is raised if no data is - available for reading or ready for writing after [d] seconds. - The delay [d] is given in the fifth argument, in seconds. *) - -val timed_write_substring : - Unix.file_descr -> string -> int -> int -> float -> int -(** See {!ThreadUnix.timed_write}. *) - -(** {1 Polling} *) - -val select : - Unix.file_descr list -> Unix.file_descr list -> Unix.file_descr list -> - float -> - Unix.file_descr list * Unix.file_descr list * Unix.file_descr list - -(** {1 Pipes and redirections} *) - -val pipe : ?cloexec:bool -> unit -> Unix.file_descr * Unix.file_descr -val open_process_in : string -> in_channel -val open_process_out : string -> out_channel -val open_process : string -> in_channel * out_channel -val open_process_full : - string -> string array -> in_channel * out_channel * in_channel - -(** {1 Time} *) - -val sleep : int -> unit - -(** {1 Sockets} *) - -val socket : - ?cloexec:bool -> Unix.socket_domain -> Unix.socket_type -> int -> - Unix.file_descr -val socketpair : - ?cloexec:bool -> Unix.socket_domain -> Unix.socket_type -> int -> - Unix.file_descr * Unix.file_descr -val accept : - ?cloexec:bool -> Unix.file_descr -> Unix.file_descr * Unix.sockaddr -val connect : Unix.file_descr -> Unix.sockaddr -> unit -val recv : - Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int -val recvfrom : - Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> - int * Unix.sockaddr -val send : - Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int -val send_substring : - Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int -val sendto : - Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> - Unix.sockaddr -> int -val sendto_substring : - Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> - Unix.sockaddr -> int -val open_connection : Unix.sockaddr -> in_channel * out_channel -val establish_server : - (in_channel -> out_channel -> unit) -> Unix.sockaddr -> unit diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml deleted file mode 100644 index 86d04667..00000000 --- a/otherlibs/threads/unix.ml +++ /dev/null @@ -1,1210 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* An alternate implementation of the Unix module from ../unix - which is safe in conjunction with bytecode threads. *) - -(* Type definitions that matter for thread operations *) - -type file_descr = int - -type process_status = - WEXITED of int - | WSIGNALED of int - | WSTOPPED of int - -(* We can't call functions from Thread because of type circularities, - so we redefine here the functions that we need *) - -type resumption_status = - Resumed_wakeup - | Resumed_delay - | Resumed_join - | Resumed_io - | Resumed_select of file_descr list * file_descr list * file_descr list - | Resumed_wait of int * process_status - -(* to avoid warning *) -let _ = [Resumed_wakeup; Resumed_delay; Resumed_join; - Resumed_io; Resumed_select ([], [], []); - Resumed_wait (0, WEXITED 0)] - -external thread_initialize : unit -> unit = "thread_initialize" -external thread_wait_read : file_descr -> unit = "thread_wait_read" -external thread_wait_write : file_descr -> unit = "thread_wait_write" -external thread_select : - file_descr list * file_descr list * file_descr list * float - -> resumption_status - = "thread_select" -external thread_wait_pid : int -> resumption_status = "thread_wait_pid" -external thread_delay : float -> unit = "thread_delay" - -let wait_read fd = thread_wait_read fd -let wait_write fd = thread_wait_write fd -let select_aux arg = thread_select arg -let wait_pid_aux pid = thread_wait_pid pid -let delay duration = thread_delay duration - -(* Make sure that threads are initialized (PR#1516). *) - -let _ = thread_initialize() - -(* Back to the Unix module *) - -let shell = "/bin/sh" - -type error = - E2BIG - | EACCES - | EAGAIN - | EBADF - | EBUSY - | ECHILD - | EDEADLK - | EDOM - | EEXIST - | EFAULT - | EFBIG - | EINTR - | EINVAL - | EIO - | EISDIR - | EMFILE - | EMLINK - | ENAMETOOLONG - | ENFILE - | ENODEV - | ENOENT - | ENOEXEC - | ENOLCK - | ENOMEM - | ENOSPC - | ENOSYS - | ENOTDIR - | ENOTEMPTY - | ENOTTY - | ENXIO - | EPERM - | EPIPE - | ERANGE - | EROFS - | ESPIPE - | ESRCH - | EXDEV - | EWOULDBLOCK - | EINPROGRESS - | EALREADY - | ENOTSOCK - | EDESTADDRREQ - | EMSGSIZE - | EPROTOTYPE - | ENOPROTOOPT - | EPROTONOSUPPORT - | ESOCKTNOSUPPORT - | EOPNOTSUPP - | EPFNOSUPPORT - | EAFNOSUPPORT - | EADDRINUSE - | EADDRNOTAVAIL - | ENETDOWN - | ENETUNREACH - | ENETRESET - | ECONNABORTED - | ECONNRESET - | ENOBUFS - | EISCONN - | ENOTCONN - | ESHUTDOWN - | ETOOMANYREFS - | ETIMEDOUT - | ECONNREFUSED - | EHOSTDOWN - | EHOSTUNREACH - | ELOOP - | EOVERFLOW - | EUNKNOWNERR of int - -exception Unix_error of error * string * string - -let _ = Callback.register_exception "Unix.Unix_error" - (Unix_error(E2BIG, "", "")) - -external error_message : error -> string = "unix_error_message" - -let handle_unix_error f arg = - try - f arg - with Unix_error(err, fun_name, arg) -> - prerr_string Sys.argv.(0); - prerr_string ": \""; - prerr_string fun_name; - prerr_string "\" failed"; - if String.length arg > 0 then begin - prerr_string " on \""; - prerr_string arg; - prerr_string "\"" - end; - prerr_string ": "; - prerr_endline (error_message err); - exit 2 - -external environment : unit -> string array = "unix_environment" -external unsafe_environment : unit -> string array = "unix_environment_unsafe" -external getenv: string -> string = "caml_sys_getenv" -external unsafe_getenv: string -> string = "caml_sys_unsafe_getenv" -external putenv: string -> string -> unit = "unix_putenv" - -type interval_timer = - ITIMER_REAL - | ITIMER_VIRTUAL - | ITIMER_PROF - -type interval_timer_status = - { it_interval: float; (* Period *) - it_value: float } (* Current value of the timer *) - -external getitimer: interval_timer -> interval_timer_status = "unix_getitimer" -external setitimer: - interval_timer -> interval_timer_status -> interval_timer_status - = "unix_setitimer" - -type wait_flag = - WNOHANG - | WUNTRACED - -let stdin = 0 -let stdout = 1 -let stderr = 2 - -type open_flag = - O_RDONLY - | O_WRONLY - | O_RDWR - | O_NONBLOCK - | O_APPEND - | O_CREAT - | O_TRUNC - | O_EXCL - | O_NOCTTY - | O_DSYNC - | O_SYNC - | O_RSYNC - | O_SHARE_DELETE - | O_CLOEXEC - | O_KEEPEXEC - -type file_perm = int - - -external openfile : string -> open_flag list -> file_perm -> file_descr - = "unix_open" - -external close : file_descr -> unit = "unix_close" -external fsync : file_descr -> unit = "unix_fsync" -external unsafe_read : file_descr -> bytes -> int -> int -> int = "unix_read" -external unsafe_write : file_descr -> bytes -> int -> int -> int - = "unix_write" -external unsafe_single_write : file_descr -> bytes -> int -> int -> int - = "unix_single_write" - -let rec read fd buf ofs len = - try - if ofs < 0 || len < 0 || ofs > Bytes.length buf - len - then invalid_arg "Unix.read" - else unsafe_read fd buf ofs len - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - wait_read fd; read fd buf ofs len - -let rec write fd buf ofs len = - try - if ofs < 0 || len < 0 || ofs > Bytes.length buf - len - then invalid_arg "Unix.write" - else unsafe_write fd buf ofs len - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - wait_write fd; write fd buf ofs len - -let rec single_write fd buf ofs len = - try - if ofs < 0 || len < 0 || ofs > Bytes.length buf - len - then invalid_arg "Unix.single_write" - else unsafe_single_write fd buf ofs len - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - wait_write fd; single_write fd buf ofs len - -let write_substring fd buf ofs len = - write fd (Bytes.unsafe_of_string buf) ofs len - -let single_write_substring fd buf ofs len = - single_write fd (Bytes.unsafe_of_string buf) ofs len - -external in_channel_of_descr : file_descr -> in_channel - = "caml_ml_open_descriptor_in" -external out_channel_of_descr : file_descr -> out_channel - = "caml_ml_open_descriptor_out" -external descr_of_in_channel : in_channel -> file_descr - = "caml_channel_descriptor" -external descr_of_out_channel : out_channel -> file_descr - = "caml_channel_descriptor" - -type seek_command = - SEEK_SET - | SEEK_CUR - | SEEK_END - -external lseek : file_descr -> int -> seek_command -> int = "unix_lseek" -external truncate : string -> int -> unit = "unix_truncate" -external ftruncate : file_descr -> int -> unit = "unix_ftruncate" - -type file_kind = - S_REG - | S_DIR - | S_CHR - | S_BLK - | S_LNK - | S_FIFO - | S_SOCK - -type stats = - { st_dev : int; - st_ino : int; - st_kind : file_kind; - st_perm : file_perm; - st_nlink : int; - st_uid : int; - st_gid : int; - st_rdev : int; - st_size : int; - st_atime : float; - st_mtime : float; - st_ctime : float } - -external stat : string -> stats = "unix_stat" -external lstat : string -> stats = "unix_lstat" -external fstat : file_descr -> stats = "unix_fstat" -external isatty : file_descr -> bool = "unix_isatty" -external unlink : string -> unit = "unix_unlink" -external rename : string -> string -> unit = "unix_rename" -external link : ?follow:bool -> string -> string -> unit = "unix_link" - -module LargeFile = - struct - external lseek : file_descr -> int64 -> seek_command -> int64 - = "unix_lseek_64" - external truncate : string -> int64 -> unit = "unix_truncate_64" - external ftruncate : file_descr -> int64 -> unit = "unix_ftruncate_64" - type stats = - { st_dev : int; - st_ino : int; - st_kind : file_kind; - st_perm : file_perm; - st_nlink : int; - st_uid : int; - st_gid : int; - st_rdev : int; - st_size : int64; - st_atime : float; - st_mtime : float; - st_ctime : float; - } - external stat : string -> stats = "unix_stat_64" - external lstat : string -> stats = "unix_lstat_64" - external fstat : file_descr -> stats = "unix_fstat_64" - end - -external map_internal: - file_descr -> ('a, 'b) Stdlib.Bigarray.kind - -> 'c Stdlib.Bigarray.layout - -> bool -> int array -> int64 - -> ('a, 'b, 'c) Stdlib.Bigarray.Genarray.t - = "caml_unix_map_file_bytecode" "caml_unix_map_file" - -let map_file fd ?(pos=0L) kind layout shared dims = - map_internal fd kind layout shared dims pos - -type access_permission = - R_OK - | W_OK - | X_OK - | F_OK - -external chmod : string -> file_perm -> unit = "unix_chmod" -external fchmod : file_descr -> file_perm -> unit = "unix_fchmod" -external chown : string -> int -> int -> unit = "unix_chown" -external fchown : file_descr -> int -> int -> unit = "unix_fchown" -external umask : int -> int = "unix_umask" -external access : string -> access_permission list -> unit = "unix_access" - -external dup : ?cloexec: bool -> file_descr -> file_descr = "unix_dup" -external dup2 : - ?cloexec: bool -> file_descr -> file_descr -> unit = "unix_dup2" -external set_nonblock : file_descr -> unit = "unix_set_nonblock" -external clear_nonblock : file_descr -> unit = "unix_clear_nonblock" -external set_close_on_exec : file_descr -> unit = "unix_set_close_on_exec" -external clear_close_on_exec : file_descr -> unit = "unix_clear_close_on_exec" - -external mkdir : string -> file_perm -> unit = "unix_mkdir" -external rmdir : string -> unit = "unix_rmdir" -external chdir : string -> unit = "unix_chdir" -external getcwd : unit -> string = "unix_getcwd" -external chroot : string -> unit = "unix_chroot" - -type dir_handle - -external opendir : string -> dir_handle = "unix_opendir" -external readdir : dir_handle -> string = "unix_readdir" -external rewinddir : dir_handle -> unit = "unix_rewinddir" -external closedir : dir_handle -> unit = "unix_closedir" - -external _pipe : - ?cloexec: bool -> unit -> file_descr * file_descr = "unix_pipe" - -let pipe ?cloexec () = - let (out_fd, in_fd as fd_pair) = _pipe ?cloexec () in - set_nonblock in_fd; - set_nonblock out_fd; - fd_pair - -external symlink : ?to_dir:bool -> string -> string -> unit = "unix_symlink" -external has_symlink : unit -> bool = "unix_has_symlink" -external readlink : string -> string = "unix_readlink" -external mkfifo : string -> file_perm -> unit = "unix_mkfifo" - -let select readfds writefds exceptfds delay = - match select_aux (readfds, writefds, exceptfds, delay) with - Resumed_select(r, w, e) -> (r, w, e) - | _ -> ([], [], []) - -type lock_command = - F_ULOCK - | F_LOCK - | F_TLOCK - | F_TEST - | F_RLOCK - | F_TRLOCK - -external lockf : file_descr -> lock_command -> int -> unit = "unix_lockf" - -external _execv : string -> string array -> 'a = "unix_execv" -external _execve : string -> string array -> string array -> 'a = "unix_execve" -external _execvp : string -> string array -> 'a = "unix_execvp" -external _execvpe : string -> string array -> string array -> 'a - = "unix_execvpe" - -(* Disable the timer interrupt before doing exec, because some OS - keep sending timer interrupts to the exec'ed code. - Also restore blocking mode on stdin, stdout and stderr, - since this is what most programs expect! *) - -let safe_clear_nonblock fd = - try clear_nonblock fd with Unix_error(_,_,_) -> () -let safe_set_nonblock fd = - try set_nonblock fd with Unix_error(_,_,_) -> () - -let do_exec fn = - let oldtimer = - setitimer ITIMER_VIRTUAL {it_interval = 0.0; it_value = 0.0} in - safe_clear_nonblock stdin; - safe_clear_nonblock stdout; - safe_clear_nonblock stderr; - try - fn () - with Unix_error(_,_,_) as exn -> - ignore(setitimer ITIMER_VIRTUAL oldtimer); - safe_set_nonblock stdin; - safe_set_nonblock stdout; - safe_set_nonblock stderr; - raise exn - -let execv proc args = - do_exec (fun () -> _execv proc args) - -let execve proc args env = - do_exec (fun () -> _execve proc args env) - -let execvp proc args = - do_exec (fun () -> _execvp proc args) - -let execvpe proc args = - do_exec (fun () -> _execvpe proc args) - -external fork : unit -> int = "unix_fork" -external _waitpid : wait_flag list -> int -> int * process_status - = "unix_waitpid" - -let wait_pid pid = - match wait_pid_aux pid with - Resumed_wait(pid, status) -> (pid, status) - | _ -> invalid_arg "Thread.wait_pid" - -let wait () = wait_pid (-1) - -let waitpid flags pid = - if List.mem WNOHANG flags - then _waitpid flags pid - else wait_pid pid - -external getpid : unit -> int = "unix_getpid" -external getppid : unit -> int = "unix_getppid" -external nice : int -> int = "unix_nice" - -external kill : int -> int -> unit = "unix_kill" -type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK -external sigprocmask: sigprocmask_command -> int list -> int list - = "unix_sigprocmask" -external sigpending: unit -> int list = "unix_sigpending" -external sigsuspend: int list -> unit = "unix_sigsuspend" - -let pause() = - let sigs = sigprocmask SIG_BLOCK [] in sigsuspend sigs - -type process_times = - { tms_utime : float; - tms_stime : float; - tms_cutime : float; - tms_cstime : float } - -type tm = - { tm_sec : int; - tm_min : int; - tm_hour : int; - tm_mday : int; - tm_mon : int; - tm_year : int; - tm_wday : int; - tm_yday : int; - tm_isdst : bool } - -external time : unit -> float = "unix_time" -external gettimeofday : unit -> float = "unix_gettimeofday" -external gmtime : float -> tm = "unix_gmtime" -external localtime : float -> tm = "unix_localtime" -external mktime : tm -> float * tm = "unix_mktime" -external alarm : int -> int = "unix_alarm" - -let sleepf = delay -let sleep secs = delay (float secs) - -external times : unit -> process_times = "unix_times" -external utimes : string -> float -> float -> unit = "unix_utimes" - -external getuid : unit -> int = "unix_getuid" -external geteuid : unit -> int = "unix_geteuid" -external setuid : int -> unit = "unix_setuid" -external getgid : unit -> int = "unix_getgid" -external getegid : unit -> int = "unix_getegid" -external setgid : int -> unit = "unix_setgid" -external getgroups : unit -> int array = "unix_getgroups" -external setgroups : int array -> unit = "unix_setgroups" -external initgroups : string -> int -> unit = "unix_initgroups" - -type passwd_entry = - { pw_name : string; - pw_passwd : string; - pw_uid : int; - pw_gid : int; - pw_gecos : string; - pw_dir : string; - pw_shell : string } - -type group_entry = - { gr_name : string; - gr_passwd : string; - gr_gid : int; - gr_mem : string array } - - -external getlogin : unit -> string = "unix_getlogin" -external getpwnam : string -> passwd_entry = "unix_getpwnam" -external getgrnam : string -> group_entry = "unix_getgrnam" -external getpwuid : int -> passwd_entry = "unix_getpwuid" -external getgrgid : int -> group_entry = "unix_getgrgid" - -type inet_addr = string - -external inet_addr_of_string : string -> inet_addr - = "unix_inet_addr_of_string" -external string_of_inet_addr : inet_addr -> string - = "unix_string_of_inet_addr" - -let inet_addr_any = inet_addr_of_string "0.0.0.0" -let inet_addr_loopback = inet_addr_of_string "127.0.0.1" -let inet6_addr_any = - try inet_addr_of_string "::" with Failure _ -> inet_addr_any -let inet6_addr_loopback = - try inet_addr_of_string "::1" with Failure _ -> inet_addr_loopback - -let is_inet6_addr s = String.length s = 16 - -type socket_domain = - PF_UNIX - | PF_INET - | PF_INET6 - -type socket_type = - SOCK_STREAM - | SOCK_DGRAM - | SOCK_RAW - | SOCK_SEQPACKET - -type sockaddr = - ADDR_UNIX of string - | ADDR_INET of inet_addr * int - -let domain_of_sockaddr = function - ADDR_UNIX _ -> PF_UNIX - | ADDR_INET(a, _) -> if is_inet6_addr a then PF_INET6 else PF_INET - -type shutdown_command = - SHUTDOWN_RECEIVE - | SHUTDOWN_SEND - | SHUTDOWN_ALL - -type msg_flag = - MSG_OOB - | MSG_DONTROUTE - | MSG_PEEK - -external _socket : - ?cloexec: bool -> socket_domain -> socket_type -> int -> file_descr - = "unix_socket" -external _socketpair : - ?cloexec: bool -> socket_domain -> socket_type -> int -> - file_descr * file_descr - = "unix_socketpair" - -let socket ?cloexec dom typ proto = - let s = _socket ?cloexec dom typ proto in - set_nonblock s; - s - -let socketpair ?cloexec dom typ proto = - let (s1, s2 as spair) = _socketpair ?cloexec dom typ proto in - set_nonblock s1; set_nonblock s2; - spair - -external _accept : - ?cloexec: bool -> file_descr -> file_descr * sockaddr = "unix_accept" - -let rec accept ?cloexec req = - wait_read req; - try - let (s, caller as result) = _accept ?cloexec req in - set_nonblock s; - result - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> accept req - -external bind : file_descr -> sockaddr -> unit = "unix_bind" -external listen : file_descr -> int -> unit = "unix_listen" -external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" -external getsockname : file_descr -> sockaddr = "unix_getsockname" -external getpeername : file_descr -> sockaddr = "unix_getpeername" - -external _connect : file_descr -> sockaddr -> unit = "unix_connect" - -let connect s addr = - try - _connect s addr - with Unix_error((EINPROGRESS | EWOULDBLOCK | EAGAIN), _, _) -> - wait_write s; - (* Check if it really worked *) - ignore(getpeername s) - -external unsafe_recv : - file_descr -> bytes -> int -> int -> msg_flag list -> int - = "unix_recv" -external unsafe_recvfrom : - file_descr -> bytes -> int -> int -> msg_flag list -> int * sockaddr - = "unix_recvfrom" -external unsafe_send : - file_descr -> bytes -> int -> int -> msg_flag list -> int - = "unix_send" -external unsafe_sendto : - file_descr -> bytes -> int -> int -> msg_flag list -> sockaddr -> int - = "unix_sendto" "unix_sendto_native" - -let rec recv fd buf ofs len flags = - try - if ofs < 0 || len < 0 || ofs > Bytes.length buf - len - then invalid_arg "Unix.recv" - else unsafe_recv fd buf ofs len flags - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - wait_read fd; recv fd buf ofs len flags - -let rec recvfrom fd buf ofs len flags = - try - if ofs < 0 || len < 0 || ofs > Bytes.length buf - len - then invalid_arg "Unix.recvfrom" - else unsafe_recvfrom fd buf ofs len flags - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - wait_read fd; - recvfrom fd buf ofs len flags - -let rec send fd buf ofs len flags = - try - if ofs < 0 || len < 0 || ofs > Bytes.length buf - len - then invalid_arg "Unix.send" - else unsafe_send fd buf ofs len flags - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - wait_write fd; - send fd buf ofs len flags - -let rec sendto fd buf ofs len flags addr = - try - if ofs < 0 || len < 0 || ofs > Bytes.length buf - len - then invalid_arg "Unix.sendto" - else unsafe_sendto fd buf ofs len flags addr - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - wait_write fd; - sendto fd buf ofs len flags addr - -let send_substring fd buf ofs len flags = - send fd (Bytes.unsafe_of_string buf) ofs len flags - -let sendto_substring fd buf ofs len flags addr = - sendto fd (Bytes.unsafe_of_string buf) ofs len flags addr - -type socket_bool_option = - SO_DEBUG - | SO_BROADCAST - | SO_REUSEADDR - | SO_KEEPALIVE - | SO_DONTROUTE - | SO_OOBINLINE - | SO_ACCEPTCONN - | TCP_NODELAY - | IPV6_ONLY - - -type socket_int_option = - SO_SNDBUF - | SO_RCVBUF - | SO_ERROR - | SO_TYPE - | SO_RCVLOWAT - | SO_SNDLOWAT - -type socket_optint_option = SO_LINGER - -type socket_float_option = - SO_RCVTIMEO - | SO_SNDTIMEO - -type socket_error_option = SO_ERROR - -module SO: sig - type ('opt, 'v) t - val bool: (socket_bool_option, bool) t - val int: (socket_int_option, int) t - val optint: (socket_optint_option, int option) t - val float: (socket_float_option, float) t - val error: (socket_error_option, error option) t - val get: ('opt, 'v) t -> file_descr -> 'opt -> 'v - val set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit -end = struct - type ('opt, 'v) t = int - let bool = 0 - let int = 1 - let optint = 2 - let float = 3 - let error = 4 - external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v - = "unix_getsockopt" - external set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit - = "unix_setsockopt" -end - -let getsockopt fd opt = SO.get SO.bool fd opt -let setsockopt fd opt v = SO.set SO.bool fd opt v - -let getsockopt_int fd opt = SO.get SO.int fd opt -let setsockopt_int fd opt v = SO.set SO.int fd opt v - -let getsockopt_optint fd opt = SO.get SO.optint fd opt -let setsockopt_optint fd opt v = SO.set SO.optint fd opt v - -let getsockopt_float fd opt = SO.get SO.float fd opt -let setsockopt_float fd opt v = SO.set SO.float fd opt v - -let getsockopt_error fd = SO.get SO.error fd SO_ERROR - -type host_entry = - { h_name : string; - h_aliases : string array; - h_addrtype : socket_domain; - h_addr_list : inet_addr array } - -type protocol_entry = - { p_name : string; - p_aliases : string array; - p_proto : int } - -type service_entry = - { s_name : string; - s_aliases : string array; - s_port : int; - s_proto : string } - -external gethostname : unit -> string = "unix_gethostname" -external gethostbyname : string -> host_entry = "unix_gethostbyname" -external gethostbyaddr : inet_addr -> host_entry = "unix_gethostbyaddr" -external getprotobyname : string -> protocol_entry - = "unix_getprotobyname" -external getprotobynumber : int -> protocol_entry - = "unix_getprotobynumber" -external getservbyname : string -> string -> service_entry - = "unix_getservbyname" -external getservbyport : int -> string -> service_entry - = "unix_getservbyport" -type addr_info = - { ai_family : socket_domain; - ai_socktype : socket_type; - ai_protocol : int; - ai_addr : sockaddr; - ai_canonname : string } - -type getaddrinfo_option = - AI_FAMILY of socket_domain - | AI_SOCKTYPE of socket_type - | AI_PROTOCOL of int - | AI_NUMERICHOST - | AI_CANONNAME - | AI_PASSIVE - -external getaddrinfo_system - : string -> string -> getaddrinfo_option list -> addr_info list - = "unix_getaddrinfo" - -let getaddrinfo_emulation node service opts = - (* Parse options *) - let opt_socktype = ref None - and opt_protocol = ref 0 - and opt_passive = ref false in - List.iter - (function AI_SOCKTYPE s -> opt_socktype := Some s - | AI_PROTOCOL p -> opt_protocol := p - | AI_PASSIVE -> opt_passive := true - | _ -> ()) - opts; - (* Determine socket types and port numbers *) - let get_port ty kind = - if service = "" then [ty, 0] else - try - [ty, int_of_string service] - with Failure _ -> - try - [ty, (getservbyname service kind).s_port] - with Not_found -> [] - in - let ports = - match !opt_socktype with - | None -> - get_port SOCK_STREAM "tcp" @ get_port SOCK_DGRAM "udp" - | Some SOCK_STREAM -> - get_port SOCK_STREAM "tcp" - | Some SOCK_DGRAM -> - get_port SOCK_DGRAM "udp" - | Some ty -> - if service = "" then [ty, 0] else [] in - (* Determine IP addresses *) - let addresses = - if node = "" then - if List.mem AI_PASSIVE opts - then [inet_addr_any, "0.0.0.0"] - else [inet_addr_loopback, "127.0.0.1"] - else - try - [inet_addr_of_string node, node] - with Failure _ -> - try - let he = gethostbyname node in - List.map - (fun a -> (a, he.h_name)) - (Array.to_list he.h_addr_list) - with Not_found -> - [] in - (* Cross-product of addresses and ports *) - List.flatten - (List.map - (fun (ty, port) -> - List.map - (fun (addr, name) -> - { ai_family = PF_INET; - ai_socktype = ty; - ai_protocol = !opt_protocol; - ai_addr = ADDR_INET(addr, port); - ai_canonname = name }) - addresses) - ports) - -let getaddrinfo node service opts = - try - List.rev(getaddrinfo_system node service opts) - with Invalid_argument _ -> - getaddrinfo_emulation node service opts - -type name_info = - { ni_hostname : string; - ni_service : string } - -type getnameinfo_option = - NI_NOFQDN - | NI_NUMERICHOST - | NI_NAMEREQD - | NI_NUMERICSERV - | NI_DGRAM - -external getnameinfo_system - : sockaddr -> getnameinfo_option list -> name_info - = "unix_getnameinfo" - -let getnameinfo_emulation addr opts = - match addr with - | ADDR_UNIX f -> - { ni_hostname = ""; ni_service = f } (* why not? *) - | ADDR_INET(a, p) -> - let hostname = - try - if List.mem NI_NUMERICHOST opts then raise Not_found; - (gethostbyaddr a).h_name - with Not_found -> - if List.mem NI_NAMEREQD opts then raise Not_found; - string_of_inet_addr a in - let service = - try - if List.mem NI_NUMERICSERV opts then raise Not_found; - let kind = if List.mem NI_DGRAM opts then "udp" else "tcp" in - (getservbyport p kind).s_name - with Not_found -> - Int.to_string p in - { ni_hostname = hostname; ni_service = service } - -let getnameinfo addr opts = - try - getnameinfo_system addr opts - with Invalid_argument _ -> - getnameinfo_emulation addr opts - -type terminal_io = { - mutable c_ignbrk: bool; - mutable c_brkint: bool; - mutable c_ignpar: bool; - mutable c_parmrk: bool; - mutable c_inpck: bool; - mutable c_istrip: bool; - mutable c_inlcr: bool; - mutable c_igncr: bool; - mutable c_icrnl: bool; - mutable c_ixon: bool; - mutable c_ixoff: bool; - mutable c_opost: bool; - mutable c_obaud: int; - mutable c_ibaud: int; - mutable c_csize: int; - mutable c_cstopb: int; - mutable c_cread: bool; - mutable c_parenb: bool; - mutable c_parodd: bool; - mutable c_hupcl: bool; - mutable c_clocal: bool; - mutable c_isig: bool; - mutable c_icanon: bool; - mutable c_noflsh: bool; - mutable c_echo: bool; - mutable c_echoe: bool; - mutable c_echok: bool; - mutable c_echonl: bool; - mutable c_vintr: char; - mutable c_vquit: char; - mutable c_verase: char; - mutable c_vkill: char; - mutable c_veof: char; - mutable c_veol: char; - mutable c_vmin: int; - mutable c_vtime: int; - mutable c_vstart: char; - mutable c_vstop: char - } - -external tcgetattr: file_descr -> terminal_io = "unix_tcgetattr" - -type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH - -external tcsetattr: file_descr -> setattr_when -> terminal_io -> unit - = "unix_tcsetattr" -external tcsendbreak: file_descr -> int -> unit = "unix_tcsendbreak" -external tcdrain: file_descr -> unit = "unix_tcdrain" - -type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH - -external tcflush: file_descr -> flush_queue -> unit = "unix_tcflush" - -type flow_action = TCOOFF | TCOON | TCIOFF | TCION - -external tcflow: file_descr -> flow_action -> unit = "unix_tcflow" - -external setsid : unit -> int = "unix_setsid" - -(* High-level process management (system, popen) *) - -let rec waitpid_non_intr pid = - try waitpid [] pid - with Unix_error (EINTR, _, _) -> waitpid_non_intr pid - -let system cmd = - match fork() with - 0 -> begin try - execv shell [| shell; "-c"; cmd |] - with _ -> - exit 127 - end - | id -> snd(waitpid_non_intr id) - -(* Make sure [fd] is not one of the standard descriptors 0, 1, 2, - by duplicating it if needed. *) - -let rec file_descr_not_standard fd = - if fd >= 3 then fd else begin - let res = file_descr_not_standard (dup fd) in - close fd; - res - end - -let perform_redirections new_stdin new_stdout new_stderr = - let new_stdin = file_descr_not_standard new_stdin in - let new_stdout = file_descr_not_standard new_stdout in - let new_stderr = file_descr_not_standard new_stderr in - dup2 ~cloexec:false new_stdin stdin; close new_stdin; - dup2 ~cloexec:false new_stdout stdout; close new_stdout; - dup2 ~cloexec:false new_stderr stderr; close new_stderr - -let create_process cmd args new_stdin new_stdout new_stderr = - match fork() with - 0 -> - begin try - perform_redirections new_stdin new_stdout new_stderr; - execvp cmd args - with _ -> - exit 127 - end - | id -> id - -let create_process_env cmd args env new_stdin new_stdout new_stderr = - match fork() with - 0 -> - begin try - perform_redirections new_stdin new_stdout new_stderr; - execvpe cmd args env - with _ -> - exit 127 - end - | id -> id - -type popen_process = - Process of in_channel * out_channel - | Process_in of in_channel - | Process_out of out_channel - | Process_full of in_channel * out_channel * in_channel - -let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t) - -let open_proc prog args envopt proc input output error = - match fork() with - 0 -> begin try - perform_redirections input output error; - match envopt with - | Some env -> execve prog args env - | None -> execv prog args - with _ -> - exit 127 - end - | id -> Hashtbl.add popen_processes proc id - -let open_process_args_in prog args = - let (in_read, in_write) = pipe ~cloexec:true () in - let inchan = in_channel_of_descr in_read in - try - open_proc prog args None (Process_in inchan) stdin in_write stderr; - close in_write; - inchan - with e -> - close_in inchan; - close in_write; - raise e - -let open_process_args_out prog args = - let (out_read, out_write) = pipe ~cloexec:true () in - let outchan = out_channel_of_descr out_write in - try - open_proc prog args None (Process_out outchan) out_read stdout stderr; - close out_read; - outchan - with e -> - close_out outchan; - close out_read; - raise e - -let open_process_args prog args = - let (in_read, in_write) = pipe ~cloexec:true () in - let inchan = in_channel_of_descr in_read in - try - let (out_read, out_write) = pipe ~cloexec:true () in - let outchan = out_channel_of_descr out_write in - try - open_proc prog args None - (Process(inchan, outchan)) out_read in_write stderr; - close out_read; - close in_write; - (inchan, outchan) - with e -> - close_out outchan; - close out_read; - raise e - with e -> - close_in inchan; - close in_write; - raise e - -let open_process_args_full prog args env = - let (in_read, in_write) = pipe ~cloexec:true () in - let inchan = in_channel_of_descr in_read in - try - let (out_read, out_write) = pipe ~cloexec:true () in - let outchan = out_channel_of_descr out_write in - try - let (err_read, err_write) = pipe ~cloexec:true () in - let errchan = in_channel_of_descr err_read in - try - open_proc prog args (Some env) (Process_full(inchan, outchan, errchan)) - out_read in_write err_write; - close out_read; - close in_write; - close err_write; - (inchan, outchan, errchan) - with e -> - close_in errchan; - close err_write; - raise e - with e -> - close_out outchan; - close out_read; - raise e - with e -> - close_in inchan; - close in_write; - raise e - -let open_process_shell fn cmd = - fn shell [|shell; "-c"; cmd|] -let open_process_in cmd = - open_process_shell open_process_args_in cmd -let open_process_out cmd = - open_process_shell open_process_args_out cmd -let open_process cmd = - open_process_shell open_process_args cmd -let open_process_full cmd = - open_process_shell open_process_args_full cmd - -let find_proc_id fun_name proc = - try - Hashtbl.find popen_processes proc - with Not_found -> - raise(Unix_error(EBADF, fun_name, "")) - -let remove_proc_id proc = - Hashtbl.remove popen_processes proc - -let process_in_pid inchan = - find_proc_id "process_in_pid" (Process_in inchan) -let process_out_pid outchan = - find_proc_id "process_out_pid" (Process_out outchan) -let process_pid (inchan, outchan) = - find_proc_id "process_pid" (Process(inchan, outchan)) -let process_full_pid (inchan, outchan, errchan) = - find_proc_id "process_full_pid" - (Process_full(inchan, outchan, errchan)) - -let close_process_in inchan = - let proc = Process_in inchan in - let pid = find_proc_id "close_process_in" proc in - remove_proc_id proc; - close_in inchan; - snd(waitpid_non_intr pid) - -let close_process_out outchan = - let proc = Process_out outchan in - let pid = find_proc_id "close_process_out" proc in - remove_proc_id proc; - (* The application may have closed [outchan] already to signal - end-of-input to the process. *) - begin try close_out outchan with Sys_error _ -> () end; - snd(waitpid_non_intr pid) - -let close_process (inchan, outchan) = - let proc = Process(inchan, outchan) in - let pid = find_proc_id "close_process" proc in - remove_proc_id proc; - close_in inchan; - begin try close_out outchan with Sys_error _ -> () end; - snd(waitpid_non_intr pid) - -let close_process_full (inchan, outchan, errchan) = - let proc = Process_full(inchan, outchan, errchan) in - let pid = find_proc_id "close_process_full" proc in - remove_proc_id proc; - close_in inchan; - begin try close_out outchan with Sys_error _ -> () end; - close_in errchan; - snd(waitpid_non_intr pid) - -(* High-level network functions *) - -let open_connection sockaddr = - let sock = - socket ~cloexec:true (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in - try - connect sock sockaddr; - (in_channel_of_descr sock, out_channel_of_descr sock) - with exn -> - close sock; raise exn - -let shutdown_connection inchan = - shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND - -let rec accept_non_intr s = - try accept ~cloexec:true s - with Unix_error (EINTR, _, _) -> accept_non_intr s - -let establish_server server_fun sockaddr = - let sock = - socket ~cloexec:true (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in - setsockopt sock SO_REUSEADDR true; - bind sock sockaddr; - listen sock 5; - while true do - let (s, caller) = accept_non_intr sock in - (* The "double fork" trick, the process which calls server_fun will not - leave a zombie process *) - match fork() with - 0 -> if fork() <> 0 then exit 0; (* The son exits, the grandson works *) - close sock; - let inchan = in_channel_of_descr s in - let outchan = out_channel_of_descr s in - server_fun inchan outchan; - (* Do not close inchan nor outchan, as the server_fun could - have done it already, and we are about to exit anyway - (PR#3794) *) - exit 0 - | id -> close s; ignore(waitpid_non_intr id) (* Reclaim the son *) - done diff --git a/otherlibs/unix/mmap.c b/otherlibs/unix/mmap.c index e949f55f..15465ddc 100644 --- a/otherlibs/unix/mmap.c +++ b/otherlibs/unix/mmap.c @@ -38,29 +38,9 @@ #include #endif -/* Temporary compatibility stuff so that this file can also be compiled - from otherlibs/bigarray/ and included in the bigarray library. */ - -#ifdef IN_OCAML_BIGARRAY -#define MAP_FILE_FUNCTION caml_ba_map_file -#define MAP_FILE_FUNCTION_BYTECODE caml_ba_map_file_bytecode -#define UNMAP_FILE_FUNCTION caml_ba_unmap_file -#define ALLOC_FUNCTION caml_ba_mapped_alloc -#define CAML_MAP_FILE "Bigarray.map_file" -#define MAP_FILE_ERROR() caml_sys_error(NO_ARG) -#else -#define MAP_FILE_FUNCTION caml_unix_map_file -#define MAP_FILE_FUNCTION_BYTECODE caml_unix_map_file_bytecode -#define UNMAP_FILE_FUNCTION caml_unix_unmap_file -#define ALLOC_FUNCTION caml_unix_mapped_alloc -#define MAP_FILE_FUNCTION caml_unix_map_file -#define CAML_MAP_FILE "Unix.map_file" -#define MAP_FILE_ERROR() uerror("map_file", Nothing) -#endif - /* Defined in [mmap_ba.c] */ CAMLextern value -ALLOC_FUNCTION(int flags, int num_dims, void * data, intnat * dim); +caml_unix_mapped_alloc(int flags, int num_dims, void * data, intnat * dim); #if defined(HAS_MMAP) @@ -114,8 +94,8 @@ static int caml_grow_file(int fd, file_offset size) } -CAMLprim value MAP_FILE_FUNCTION(value vfd, value vkind, value vlayout, - value vshared, value vdim, value vstart) +CAMLprim value caml_unix_map_file(value vfd, value vkind, value vlayout, + value vshared, value vdim, value vstart) { int fd, flags, major_dim, shared; intnat num_dims, i; @@ -133,12 +113,12 @@ CAMLprim value MAP_FILE_FUNCTION(value vfd, value vkind, value vlayout, /* Extract dimensions from OCaml array */ num_dims = Wosize_val(vdim); if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS) - caml_invalid_argument(CAML_MAP_FILE ": bad number of dimensions"); + caml_invalid_argument("Unix.map_file: bad number of dimensions"); for (i = 0; i < num_dims; i++) { dim[i] = Long_val(Field(vdim, i)); if (dim[i] == -1 && i == major_dim) continue; if (dim[i] < 0) - caml_invalid_argument(CAML_MAP_FILE ": negative dimension"); + caml_invalid_argument("Unix.map_file: negative dimension"); } /* Determine file size. We avoid lseek here because it is fragile, and because some mappable file types do not support it @@ -146,7 +126,7 @@ CAMLprim value MAP_FILE_FUNCTION(value vfd, value vkind, value vlayout, caml_enter_blocking_section(); if (fstat(fd, &st) == -1) { caml_leave_blocking_section(); - MAP_FILE_ERROR(); + uerror("map_file", Nothing); } file_size = st.st_size; /* Determine array size in bytes (or size of array without the major @@ -159,21 +139,21 @@ CAMLprim value MAP_FILE_FUNCTION(value vfd, value vkind, value vlayout, /* Determine major dimension from file size */ if (file_size < startpos) { caml_leave_blocking_section(); - caml_failwith(CAML_MAP_FILE ": file position exceeds file size"); + caml_failwith("Unix.map_file: file position exceeds file size"); } data_size = file_size - startpos; dim[major_dim] = (uintnat) (data_size / array_size); array_size = dim[major_dim] * array_size; if (array_size != data_size) { caml_leave_blocking_section(); - caml_failwith(CAML_MAP_FILE ": file size doesn't match array dimensions"); + caml_failwith("Unix.map_file: file size doesn't match array dimensions"); } } else { /* Check that file is large enough, and grow it otherwise */ if (file_size < startpos + array_size) { if (caml_grow_file(fd, startpos + array_size) == -1) { /* PR#5543 */ caml_leave_blocking_section(); - MAP_FILE_ERROR(); + uerror("map_file", Nothing); } } } @@ -188,16 +168,16 @@ CAMLprim value MAP_FILE_FUNCTION(value vfd, value vkind, value vlayout, else addr = NULL; /* PR#5463 - mmap fails on empty region */ caml_leave_blocking_section(); - if (addr == (void *) MAP_FAILED) MAP_FILE_ERROR(); + if (addr == (void *) MAP_FAILED) uerror("map_file", Nothing); addr = (void *) ((uintnat) addr + delta); /* Build and return the OCaml bigarray */ - return ALLOC_FUNCTION(flags, num_dims, addr, dim); + return caml_unix_mapped_alloc(flags, num_dims, addr, dim); } #else -CAMLprim value MAP_FILE_FUNCTION(value vfd, value vkind, value vlayout, - value vshared, value vdim, value vpos) +CAMLprim value caml_unix_map_file(value vfd, value vkind, value vlayout, + value vshared, value vdim, value vpos) { caml_invalid_argument("Unix.map_file: not supported"); return Val_unit; @@ -205,13 +185,13 @@ CAMLprim value MAP_FILE_FUNCTION(value vfd, value vkind, value vlayout, #endif -CAMLprim value MAP_FILE_FUNCTION_BYTECODE(value * argv, int argn) +CAMLprim value caml_unix_map_file_bytecode(value * argv, int argn) { - return MAP_FILE_FUNCTION(argv[0], argv[1], argv[2], - argv[3], argv[4], argv[5]); + return caml_unix_map_file(argv[0], argv[1], argv[2], + argv[3], argv[4], argv[5]); } -void UNMAP_FILE_FUNCTION(void * addr, uintnat len) +void caml_ba_unmap_file(void * addr, uintnat len) { #if defined(HAS_MMAP) uintnat page = sysconf(_SC_PAGESIZE); diff --git a/otherlibs/unix/mmap_ba.c b/otherlibs/unix/mmap_ba.c index f85bcc2f..bdb5c60f 100644 --- a/otherlibs/unix/mmap_ba.c +++ b/otherlibs/unix/mmap_ba.c @@ -24,28 +24,17 @@ /* Allocation of bigarrays for memory-mapped files. This is the OS-independent part of [mmap.c]. */ -/* Temporary compatibility stuff so that this file can also be compiled - from otherlibs/bigarray/ and included in the bigarray library. */ - -#ifdef IN_OCAML_BIGARRAY -#define UNMAP_FILE_FUNCTION caml_ba_unmap_file -#define ALLOC_FUNCTION caml_ba_mapped_alloc -#else -#define UNMAP_FILE_FUNCTION caml_unix_unmap_file -#define ALLOC_FUNCTION caml_unix_mapped_alloc -#endif - -CAMLextern void UNMAP_FILE_FUNCTION(void * addr, uintnat len); +CAMLextern void caml_ba_unmap_file(void * addr, uintnat len); static void caml_ba_mapped_finalize(value v) { struct caml_ba_array * b = Caml_ba_array_val(v); CAMLassert((b->flags & CAML_BA_MANAGED_MASK) == CAML_BA_MAPPED_FILE); if (b->proxy == NULL) { - UNMAP_FILE_FUNCTION(b->data, caml_ba_byte_size(b)); + caml_ba_unmap_file(b->data, caml_ba_byte_size(b)); } else { if (-- b->proxy->refcount == 0) { - UNMAP_FILE_FUNCTION(b->proxy->data, b->proxy->size); + caml_ba_unmap_file(b->proxy->data, b->proxy->size); free(b->proxy); } } @@ -65,11 +54,11 @@ static struct custom_operations caml_ba_mapped_ops = { custom_fixed_length_default }; -/* [caml_ba_mapped_alloc] allocates a new bigarray object in the heap +/* [caml_unix_mapped_alloc] allocates a new bigarray object in the heap corresponding to a memory-mapped file. */ CAMLexport value -ALLOC_FUNCTION(int flags, int num_dims, void * data, intnat * dim) +caml_unix_mapped_alloc(int flags, int num_dims, void * data, intnat * dim) { uintnat asize; int i; diff --git a/otherlibs/unix/open.c b/otherlibs/unix/open.c index 859dbe44..cae1ce0f 100644 --- a/otherlibs/unix/open.c +++ b/otherlibs/unix/open.c @@ -74,7 +74,7 @@ CAMLprim value unix_open(value path, value flags, value perm) if (cloexec) cv_flags |= O_CLOEXEC; #endif p = caml_stat_strdup(String_val(path)); - /* open on a named FIFO can block (PR#1533) */ + /* open on a named FIFO can block (PR#8005) */ caml_enter_blocking_section(); fd = open(p, cv_flags, Int_val(perm)); caml_leave_blocking_section(); diff --git a/otherlibs/unix/sleep.c b/otherlibs/unix/sleep.c index 54724312..bada9ae7 100644 --- a/otherlibs/unix/sleep.c +++ b/otherlibs/unix/sleep.c @@ -35,26 +35,31 @@ CAMLprim value unix_sleep(value duration) { struct timespec t; int ret; - caml_enter_blocking_section(); t.tv_sec = (time_t) d; t.tv_nsec = (d - t.tv_sec) * 1e9; do { + caml_enter_blocking_section(); ret = nanosleep(&t, &t); + /* MPR#7903: if we were interrupted by a signal, and this signal + is handled in OCaml, we should run its handler now, + not at the end of the full sleep duration. Leaving the blocking + section and re-entering it does the job. */ + caml_leave_blocking_section(); } while (ret == -1 && errno == EINTR); - caml_leave_blocking_section(); if (ret == -1) uerror("sleep", Nothing); } #elif defined(HAS_SELECT) { struct timeval t; int ret; - caml_enter_blocking_section(); t.tv_sec = (time_t) d; t.tv_usec = (d - t.tv_sec) * 1e6; do { + caml_enter_blocking_section(); ret = select(0, NULL, NULL, NULL, &t); + /* MPR#7903: same comment as above */ + caml_leave_blocking_section(); } while (ret == -1 && errno == EINTR); - caml_leave_blocking_section(); if (ret == -1) uerror("sleep", Nothing); } #else diff --git a/otherlibs/unix/socketaddr.c b/otherlibs/unix/socketaddr.c index 8f7eeeb1..3e053246 100644 --- a/otherlibs/unix/socketaddr.c +++ b/otherlibs/unix/socketaddr.c @@ -102,25 +102,49 @@ void get_sockaddr(value mladr, } } +value alloc_unix_sockaddr(value path) { + CAMLparam1(path); + CAMLlocal1(res); + res = caml_alloc_small(1, 0); + Field(res,0) = path; + CAMLreturn(res); +} + value alloc_sockaddr(union sock_addr_union * adr /*in*/, socklen_param_type adr_len, int close_on_error) { value res; +#ifndef _WIN32 + if (adr_len < offsetof(struct sockaddr, sa_data)) { + // Only possible for an unnamed AF_UNIX socket, in + // which case sa_family might be uninitialized. + return alloc_unix_sockaddr(caml_alloc_string(0)); + } +#endif + switch(adr->s_gen.sa_family) { #ifndef _WIN32 case AF_UNIX: - { value n; - /* Based on recommendation in section BUGS of Linux unix(7). See - http://man7.org/linux/man-pages/man7/unix.7.html */ - mlsize_t path_length = - strnlen(adr->s_unix.sun_path, - adr_len - offsetof(struct sockaddr_un, sun_path)); - n = caml_alloc_initialized_string(path_length, - (char *)adr->s_unix.sun_path); - Begin_root (n); - res = caml_alloc_small(1, 0); - Field(res,0) = n; - End_roots(); + { /* Based on recommendation in section BUGS of Linux unix(7). See + http://man7.org/linux/man-pages/man7/unix.7.html. */ + mlsize_t struct_offset = offsetof(struct sockaddr_un, sun_path); + mlsize_t path_length = 0; + if (adr_len > struct_offset) { + path_length = adr_len - struct_offset; + + /* paths _may_ be null-terminated, but Linux abstract sockets + * start with a null, and may contain internal nulls. */ + path_length = ( +#ifdef __linux__ + (adr->s_unix.sun_path[0] == '\0') ? path_length : +#endif + strnlen(adr->s_unix.sun_path, path_length) + ); + } + + res = alloc_unix_sockaddr( + caml_alloc_initialized_string(path_length, (char *)adr->s_unix.sun_path) + ); break; } #endif diff --git a/otherlibs/unix/unixsupport.c b/otherlibs/unix/unixsupport.c index 9bbb9343..937146b2 100644 --- a/otherlibs/unix/unixsupport.c +++ b/otherlibs/unix/unixsupport.c @@ -253,7 +253,7 @@ int error_table[] = { EHOSTUNREACH, ELOOP, EOVERFLOW /*, EUNKNOWNERR */ }; -static value * unix_error_exn = NULL; +static const value * unix_error_exn = NULL; value unix_error_of_code (int errcode) { diff --git a/otherlibs/unix/wait.c b/otherlibs/unix/wait.c index 448b3f31..d0f06bfc 100644 --- a/otherlibs/unix/wait.c +++ b/otherlibs/unix/wait.c @@ -43,6 +43,9 @@ static value alloc_process_status(int pid, int status) { value st, res; + // status is undefined when pid is zero so we set a default value. + if (pid == 0) status = 0; + if (WIFEXITED(status)) { st = caml_alloc_small(1, TAG_WEXITED); Field(st, 0) = Val_int(WEXITSTATUS(status)); diff --git a/otherlibs/win32graph/Makefile b/otherlibs/win32graph/Makefile deleted file mode 100644 index 66cd62b2..00000000 --- a/otherlibs/win32graph/Makefile +++ /dev/null @@ -1,39 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -#* * -#* Copyright 2001 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -LIBNAME=graphics -COBJS=open.$(O) draw.$(O) events.$(O) -CAMLOBJS=graphics.cmo -WIN32LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,gdi32) $(call SYSLIB,user32) -LINKOPTS=-cclib "\"$(WIN32LIBS)\"" -LDOPTS=-ldopt "$(WIN32LIBS)" - -include ../Makefile.otherlibs.common - -graphics.ml: ../graph/graphics.ml - cp ../graph/graphics.ml graphics.ml -graphics.mli: ../graph/graphics.mli - cp ../graph/graphics.mli graphics.mli - -.PHONY: -depend: - -graphics.cmo: graphics.cmi -graphics.cmx: graphics.cmi -draw.$(O): libgraph.h -open.$(O): libgraph.h - -clean:: partialclean - rm -f graphics.ml graphics.mli diff --git a/otherlibs/win32graph/draw.c b/otherlibs/win32graph/draw.c deleted file mode 100644 index 3c76eb8a..00000000 --- a/otherlibs/win32graph/draw.c +++ /dev/null @@ -1,649 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Developed by Jacob Navia, based on code by J-M Geffroy and X Leroy */ -/* */ -/* Copyright 2001 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include -#include "caml/mlvalues.h" -#include "caml/alloc.h" -#include "caml/fail.h" -#include "libgraph.h" -#include "caml/custom.h" -#include "caml/memory.h" - -HDC gcMetaFile; -int grdisplay_mode; -int grremember_mode; -GR_WINDOW grwindow; - -static void GetCurrentPosition(HDC hDC,POINT *pt) -{ - MoveToEx(hDC,0,0,pt); - MoveToEx(hDC,pt->x,pt->y,0); -} - -static value gr_draw_or_fill_arc(value vx, value vy, value vrx, value vry, - value vstart, value vend, BOOL fill); - -CAMLprim value caml_gr_plot(value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - gr_check_open(); - if(grremember_mode) - SetPixel(grwindow.gcBitmap, x, Wcvt(y),grwindow.CurrentColor); - if(grdisplay_mode) { - SetPixel(grwindow.gc, x, Wcvt(y),grwindow.CurrentColor); - } - return Val_unit; -} - -CAMLprim value caml_gr_moveto(value vx, value vy) -{ - grwindow.grx = Int_val(vx); - grwindow.gry = Int_val(vy); - if(grremember_mode) - MoveToEx(grwindow.gcBitmap,grwindow.grx,Wcvt(grwindow.gry),0); - if (grdisplay_mode) - MoveToEx(grwindow.gc,grwindow.grx,Wcvt(grwindow.gry),0); - return Val_unit; -} - -CAMLprim value caml_gr_current_x(value unit) -{ - return Val_int(grwindow.grx); -} - -CAMLprim value caml_gr_current_y(value unit) -{ - return Val_int(grwindow.gry); -} - -CAMLprim value caml_gr_lineto(value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - gr_check_open(); - SelectObject(grwindow.gc,grwindow.CurrentPen); - SelectObject(grwindow.gcBitmap,grwindow.CurrentPen); - if (grremember_mode) - LineTo(grwindow.gcBitmap,x,Wcvt(y)); - if (grdisplay_mode) - LineTo(grwindow.gc, x, Wcvt(y)); - grwindow.grx = x; - grwindow.gry = y; - return Val_unit; -} - -CAMLprim value caml_gr_draw_rect(value vx, value vy, value vw, value vh) -{ - int x, y, w, h; - POINT pt[5]; - x=Int_val(vx); - y=Wcvt(Int_val(vy)); - w=Int_val(vw); - h=Int_val(vh); - - pt[0].x = x; pt[0].y = y - h; - pt[1].x = x + w; pt[1].y = y - h; - pt[2].x = x + w; pt[2].y = y; - pt[3].x = x; pt[3].y = y; - pt[4].x = x; pt[4].y = y - h; - if (grremember_mode) { - Polyline(grwindow.gcBitmap,pt, 5); - } - if (grdisplay_mode) { - Polyline(grwindow.gc,pt, 5); - } - return Val_unit; -} - -CAMLprim value caml_gr_draw_text(value text,value x) -{ - POINT pt; - int oldmode = SetBkMode(grwindow.gc,TRANSPARENT); - SetBkMode(grwindow.gcBitmap,TRANSPARENT); - SetTextAlign(grwindow.gcBitmap, TA_UPDATECP|TA_BOTTOM); - SetTextAlign(grwindow.gc, TA_UPDATECP|TA_BOTTOM); - if (grremember_mode) { - TextOutA(grwindow.gcBitmap,0,0,String_val(text),x); - } - if(grdisplay_mode) { - TextOutA(grwindow.gc,0,0,String_val(text),x); - } - GetCurrentPosition(grwindow.gc,&pt); - grwindow.grx = pt.x; - grwindow.gry = grwindow.height - pt.y; - SetBkMode(grwindow.gc,oldmode); - SetBkMode(grwindow.gcBitmap,oldmode); - return Val_unit; -} - -CAMLprim value caml_gr_fill_rect(value vx, value vy, value vw, value vh) -{ - int x = Int_val(vx); - int y = Int_val(vy); - int w = Int_val(vw); - int h = Int_val(vh); - RECT rc; - - gr_check_open(); - rc.left = x; - rc.top = Wcvt(y); - rc.right = x+w; - rc.bottom = Wcvt(y)-h; - if (grdisplay_mode) - FillRect(grwindow.gc,&rc,grwindow.CurrentBrush); - if (grremember_mode) - FillRect(grwindow.gcBitmap,&rc,grwindow.CurrentBrush); - return Val_unit; -} - -CAMLprim value caml_gr_sound(value freq, value vdur) -{ - Beep(freq,vdur); - return Val_unit; -} - -CAMLprim value caml_gr_point_color(value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - COLORREF rgb; - unsigned long b,g,r; - - gr_check_open(); - rgb = GetPixel(grwindow.gcBitmap,x,Wcvt(y)); - b = (unsigned long)((rgb & 0xFF0000) >> 16); - g = (unsigned long)((rgb & 0x00FF00) >> 8); - r = (unsigned long)(rgb & 0x0000FF); - return Val_long((r<<16) + (g<<8) + b); -} - -CAMLprim value caml_gr_circle(value x,value y,value radius) -{ - int left,top,right,bottom; - - gr_check_open(); - left = x - radius/2; - top = Wcvt(y) - radius/2; - right = left+radius; - bottom = top+radius; - Ellipse(grwindow.gcBitmap,left,top,right,bottom); - return Val_unit; -} - -CAMLprim value caml_gr_set_window_title(value text) -{ - SetWindowTextA(grwindow.hwnd,(char *)text); - return Val_unit; -} - -CAMLprim value caml_gr_draw_arc(value *argv, int argc) -{ - return gr_draw_or_fill_arc(argv[0], argv[1], argv[2], argv[3], - argv[4], argv[5], FALSE); -} - -CAMLprim value caml_gr_draw_arc_nat(value vx, value vy, value vrx, value vry, - value vstart, value vend) -{ - return gr_draw_or_fill_arc(vx, vy, vrx, vry, vstart, vend, FALSE); -} - -CAMLprim value caml_gr_set_line_width(value vwidth) -{ - int width = Int_val(vwidth); - HPEN oldPen,newPen; - - gr_check_open(); - oldPen = grwindow.CurrentPen; - newPen = CreatePen(PS_SOLID,width,grwindow.CurrentColor); - SelectObject(grwindow.gcBitmap,newPen); - SelectObject(grwindow.gc,newPen); - DeleteObject(oldPen); - grwindow.CurrentPen = newPen; - return Val_unit; -} - -CAMLprim value caml_gr_set_color(value vcolor) -{ - HBRUSH oldBrush, newBrush; - LOGBRUSH lb; - LOGPEN pen; - HPEN newPen; - int color = Long_val(vcolor); - - int r = (color & 0xFF0000) >> 16, - g = (color & 0x00FF00) >> 8 , - b = color & 0x0000FF; - COLORREF c = RGB(r,g,b); - memset(&lb,0,sizeof(lb)); - memset(&pen,0,sizeof(LOGPEN)); - gr_check_open(); - GetObject(grwindow.CurrentPen,sizeof(LOGPEN),&pen); - pen.lopnColor = c; - newPen = CreatePenIndirect(&pen); - SelectObject(grwindow.gcBitmap,newPen); - SelectObject(grwindow.gc,newPen); - DeleteObject(grwindow.CurrentPen); - grwindow.CurrentPen = newPen; - SetTextColor(grwindow.gc,c); - SetTextColor(grwindow.gcBitmap,c); - oldBrush = grwindow.CurrentBrush; - lb.lbStyle = BS_SOLID; - lb.lbColor = c; - newBrush = CreateBrushIndirect(&lb); - SelectObject(grwindow.gc,newBrush); - SelectObject(grwindow.gcBitmap,newBrush); - DeleteObject(oldBrush); - grwindow.CurrentBrush = newBrush; - grwindow.CurrentColor = c; - return Val_unit; -} - - -static value gr_draw_or_fill_arc(value vx, value vy, value vrx, value vry, - value vstart, value vend, BOOL fill) -{ - int x, y, r_x, r_y, start, end; - int x1, y1, x2, y2, x3, y3, x4, y4; - double cvt = 3.141592653/180.0; - - r_x = Int_val(vrx); - r_y = Int_val(vry); - if ((r_x < 0) || (r_y < 0)) - caml_invalid_argument("draw_arc: radius must be positive"); - x = Int_val(vx); - y = Int_val(vy); - start = Int_val(vstart); - end = Int_val(vend); - - // Upper-left corner of bounding rect. - x1= x - r_x; - y1= y + r_y; - // Lower-right corner of bounding rect. - x2= x + r_x; - y2= y - r_y; - // Starting point - x3=x + (int)(100.0*cos(cvt*start)); - y3=y + (int)(100.0*sin(cvt*start)); - // Ending point - x4=x + (int)(100.0*cos(cvt*end)); - y4=y + (int)(100.0*sin(cvt*end)); - - if (grremember_mode) { - SelectObject(grwindow.gcBitmap,grwindow.CurrentPen); - SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); - if( fill ) - Pie(grwindow.gcBitmap,x1, Wcvt(y1), x2, Wcvt(y2), - x3, Wcvt(y3), x4, Wcvt(y4)); - else - Arc(grwindow.gcBitmap,x1, Wcvt(y1), x2, Wcvt(y2), - x3, Wcvt(y3), x4, Wcvt(y4)); - } - if( grdisplay_mode ) { - SelectObject(grwindow.gc,grwindow.CurrentPen); - SelectObject(grwindow.gc,grwindow.CurrentBrush); - if (fill) - Pie(grwindow.gc,x1, Wcvt(y1), x2, Wcvt(y2), - x3, Wcvt(y3), x4, Wcvt(y4)); - else - Arc(grwindow.gc,x1, Wcvt(y1), x2, Wcvt(y2), - x3, Wcvt(y3), x4, Wcvt(y4)); - } - return Val_unit; -} - -CAMLprim value caml_gr_get_mousex(value unit) -{ - POINT pt; - GetCursorPos(&pt); - MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); - return pt.x; -} - -CAMLprim value caml_gr_get_mousey(value unit) -{ - POINT pt; - GetCursorPos(&pt); - MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); - return grwindow.height - pt.y - 1; -} - - -static void gr_font(char *fontname) -{ - HFONT hf = CreationFont(fontname); - - if (hf && hf != INVALID_HANDLE_VALUE) { - HFONT oldFont = SelectObject(grwindow.gc,hf); - SelectObject(grwindow.gcBitmap,hf); - DeleteObject(grwindow.CurrentFont); - grwindow.CurrentFont = hf; - } -} - -CAMLprim value caml_gr_set_font(value fontname) -{ - gr_check_open(); - gr_font(String_val(fontname)); - return Val_unit; -} - -CAMLprim value caml_gr_set_text_size (value sz) -{ - return Val_unit; -} - -CAMLprim value caml_gr_draw_char(value chr) -{ - char str[1]; - gr_check_open(); - str[0] = Int_val(chr); - caml_gr_draw_text((value)str, 1); - return Val_unit; -} - -CAMLprim value caml_gr_draw_string(value str) -{ - gr_check_open(); - caml_gr_draw_text(str, caml_string_length(str)); - return Val_unit; -} - -CAMLprim value caml_gr_text_size(value str) -{ - SIZE extent; - value res; - - mlsize_t len = caml_string_length(str); - if (len > 32767) len = 32767; - - GetTextExtentPointA(grwindow.gc,String_val(str), len,&extent); - - res = caml_alloc_tuple(2); - Field(res, 0) = Val_long(extent.cx); - Field(res, 1) = Val_long(extent.cy); - - return res; -} - -CAMLprim value caml_gr_fill_poly(value vect) -{ - int n_points, i; - POINT *p,*poly; - n_points = Wosize_val(vect); - if (n_points < 3) - gr_fail("fill_poly: not enough points",0); - - poly = (POINT *)caml_stat_alloc(n_points*sizeof(POINT)); - - p = poly; - for( i = 0; i < n_points; i++ ){ - p->x = Int_val(Field(Field(vect,i),0)); - p->y = Wcvt(Int_val(Field(Field(vect,i),1))); - p++; - } - if (grremember_mode) { - SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); - Polygon(grwindow.gcBitmap,poly,n_points); - } - if (grdisplay_mode) { - SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); - Polygon(grwindow.gc,poly,n_points); - } - caml_stat_free(poly); - - return Val_unit; -} - -CAMLprim value caml_gr_fill_arc(value *argv, int argc) -{ - return gr_draw_or_fill_arc(argv[0], argv[1], argv[2], argv[3], - argv[4], argv[5], TRUE); -} - -CAMLprim value caml_gr_fill_arc_nat(value vx, value vy, value vrx, value vry, - value vstart, value vend) -{ - return gr_draw_or_fill_arc(vx, vy, vrx, vry, vstart, vend, TRUE); -} - -// Image primitives -struct image { - int w; - int h; - HBITMAP data; - HBITMAP mask; -}; - -#define Width(i) (((struct image *)Data_custom_val(i))->w) -#define Height(i) (((struct image *)Data_custom_val(i))->h) -#define Data(i) (((struct image *)Data_custom_val(i))->data) -#define Mask(i) (((struct image *)Data_custom_val(i))->mask) -#define Max_image_mem 500000 - -static void finalize_image (value i) -{ - DeleteObject (Data(i)); - if (Mask(i) != NULL) DeleteObject(Mask(i)); -} - -static struct custom_operations image_ops = { - "_image", - finalize_image, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default, - custom_compare_ext_default, - custom_fixed_length_default -}; - -CAMLprim value caml_gr_create_image(value vw, value vh) -{ - HBITMAP cbm; - value res; - int w = Int_val(vw); - int h = Int_val(vh); - - if (w < 0 || h < 0) - gr_fail("create_image: width and height must be positive",0); - - cbm = CreateCompatibleBitmap(grwindow.gc, w, h); - if (cbm == NULL) - gr_fail("create_image: cannot create bitmap", 0); - res = caml_alloc_custom(&image_ops, sizeof(struct image), - w * h, Max_image_mem); - if (res) { - Width (res) = w; - Height (res) = h; - Data (res) = cbm; - Mask (res) = NULL; - } - return res; -} - -CAMLprim value caml_gr_blit_image (value i, value x, value y) -{ - HBITMAP oldBmp = SelectObject(grwindow.tempDC,Data(i)); - int xsrc = Int_val(x); - int ysrc = Wcvt(Int_val(y) + Height(i) - 1); - BitBlt(grwindow.tempDC,0, 0, Width(i), Height(i), - grwindow.gcBitmap, xsrc, ysrc, SRCCOPY); - SelectObject(grwindow.tempDC,oldBmp); - return Val_unit; -} - - -CAMLprim value caml_gr_draw_image(value i, value x, value y) -{ - HBITMAP oldBmp; - - int xdst = Int_val(x); - int ydst = Wcvt(Int_val(y)+Height(i)-1); - if (Mask(i) == NULL) { - if (grremember_mode) { - oldBmp = SelectObject(grwindow.tempDC,Data(i)); - BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i), - Height(i), - grwindow.tempDC, 0, 0, SRCCOPY); - SelectObject(grwindow.tempDC,oldBmp); - } - if (grdisplay_mode) { - oldBmp = SelectObject(grwindow.tempDC,Data(i)); - BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCCOPY); - SelectObject(grwindow.tempDC,oldBmp); - } - } - else { - if (grremember_mode) { - oldBmp = SelectObject(grwindow.tempDC,Mask(i)); - BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i), - Height(i), - grwindow.tempDC, 0, 0, SRCAND); - SelectObject(grwindow.tempDC,Data(i)); - BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i), - Height(i), - grwindow.tempDC, 0, 0, SRCPAINT); - SelectObject(grwindow.tempDC,oldBmp); - } - if (grdisplay_mode) { - oldBmp = SelectObject(grwindow.tempDC,Mask(i)); - BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCAND); - SelectObject(grwindow.tempDC,Data(i)); - BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCPAINT); - SelectObject(grwindow.tempDC,oldBmp); - } - } - - return Val_unit; -} - -CAMLprim value caml_gr_make_image(value matrix) -{ - int width, height,has_transp,i,j; - value img; - HBITMAP oldBmp; - height = Wosize_val(matrix); - if (height == 0) { - width = 0; - } - else { - width = Wosize_val(Field(matrix, 0)); - for (i = 1; i < height; i++) { - if (width != (int) Wosize_val(Field(matrix, i))) - gr_fail("make_image: non-rectangular matrix",0); - } - } - Begin_roots1(matrix) - img = caml_gr_create_image(Val_int(width), Val_int(height)); - End_roots(); - has_transp = 0; - oldBmp = SelectObject(grwindow.tempDC,Data(img)); - for (i = 0; i < height; i++) { - for (j = 0; j < width; j++) { - int col = Long_val (Field (Field (matrix, i), j)); - if (col == -1){ - has_transp = 1; - SetPixel(grwindow.tempDC,j, i, 0); - } - else { - int red = (col >> 16) & 0xFF; - int green = (col >> 8) & 0xFF; - int blue = col & 0xFF; - SetPixel(grwindow.tempDC,j, i, - RGB(red, green, blue)); - } - } - } - SelectObject(grwindow.tempDC,oldBmp); - if (has_transp) { - HBITMAP cbm; - cbm = CreateCompatibleBitmap(grwindow.gc, width, height); - Mask(img) = cbm; - oldBmp = SelectObject(grwindow.tempDC,Mask(img)); - for (i = 0; i < height; i++) { - for (j = 0; j < width; j++) { - int col = Long_val (Field (Field (matrix,i),j)); - SetPixel(grwindow.tempDC,j, i, - col == -1 ? 0xFFFFFF : 0); - } - } - SelectObject(grwindow.tempDC,oldBmp); - } - return img; -} - -static value alloc_int_vect(mlsize_t size) -{ - value res; - mlsize_t i; - - if (size == 0) return Atom(0); - if (size <= Max_young_wosize) { - res = caml_alloc(size, 0); - } - else { - res = caml_alloc_shr(size, 0); - } - for (i = 0; i < size; i++) { - Field(res, i) = Val_long(0); - } - return res; -} - -CAMLprim value caml_gr_dump_image (value img) -{ - int height = Height(img); - int width = Width(img); - value matrix = Val_unit; - int i, j; - HBITMAP oldBmp; - - Begin_roots2(img, matrix) - matrix = alloc_int_vect (height); - for (i = 0; i < height; i++) { - caml_modify (&Field (matrix, i), alloc_int_vect (width)); - } - End_roots(); - - oldBmp = SelectObject(grwindow.tempDC,Data(img)); - for (i = 0; i < height; i++) { - for (j = 0; j < width; j++) { - int col = GetPixel(grwindow.tempDC,j, i); - int blue = (col >> 16) & 0xFF; - int green = (col >> 8) & 0xFF; - int red = col & 0xFF; - Field(Field(matrix, i), j) = Val_long((red << 16) + - (green << 8) + blue); - } - } - SelectObject(grwindow.tempDC,oldBmp); - if (Mask(img) != NULL) { - oldBmp = SelectObject(grwindow.tempDC,Mask(img)); - for (i = 0; i < height; i++) { - for (j = 0; j < width; j++) { - if (GetPixel(grwindow.tempDC,j, i) != 0) - Field(Field(matrix, i), j) = - Val_long(-1); - } - } - SelectObject(grwindow.tempDC,oldBmp); - } - return matrix; -} diff --git a/otherlibs/win32graph/events.c b/otherlibs/win32graph/events.c deleted file mode 100755 index 810d8632..00000000 --- a/otherlibs/win32graph/events.c +++ /dev/null @@ -1,210 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2004 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include "caml/mlvalues.h" -#include "caml/alloc.h" -#include "libgraph.h" -#include - -enum { - EVENT_BUTTON_DOWN = 1, - EVENT_BUTTON_UP = 2, - EVENT_KEY_PRESSED = 4, - EVENT_MOUSE_MOTION = 8, - EVENT_WINDOW_CLOSED = 16 -}; - -struct event_data { - short mouse_x, mouse_y; - unsigned char kind; - unsigned char button; - unsigned char key; -}; - -static struct event_data caml_gr_queue[SIZE_QUEUE]; -static unsigned int caml_gr_head = 0; /* position of next read */ -static unsigned int caml_gr_tail = 0; /* position of next write */ - -static int caml_gr_event_mask = EVENT_KEY_PRESSED; -static int last_button = 0; -static LPARAM last_pos = 0; - -HANDLE caml_gr_queue_semaphore = NULL; -CRITICAL_SECTION caml_gr_queue_mutex; - -void caml_gr_init_event_queue(void) -{ - if (caml_gr_queue_semaphore == NULL) { - caml_gr_queue_semaphore = CreateSemaphore(NULL, 0, SIZE_QUEUE, NULL); - InitializeCriticalSection(&caml_gr_queue_mutex); - } -} - -#define QueueIsEmpty (caml_gr_tail == caml_gr_head) - -static void caml_gr_enqueue_event(int kind, LPARAM mouse_xy, - int button, int key) -{ - struct event_data * ev; - - if ((caml_gr_event_mask & kind) == 0) return; - EnterCriticalSection(&caml_gr_queue_mutex); - ev = &(caml_gr_queue[caml_gr_tail]); - ev->kind = kind; - ev->mouse_x = GET_X_LPARAM(mouse_xy); - ev->mouse_y = GET_Y_LPARAM(mouse_xy); - ev->button = (button != 0); - ev->key = key; - caml_gr_tail = (caml_gr_tail + 1) % SIZE_QUEUE; - /* If queue was full, it now appears empty; - drop oldest entry from queue. */ - if (QueueIsEmpty) { - caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE; - } else { - /* One more event in queue */ - ReleaseSemaphore(caml_gr_queue_semaphore, 1, NULL); - } - LeaveCriticalSection(&caml_gr_queue_mutex); -} - -void caml_gr_handle_event(UINT msg, WPARAM wParam, LPARAM lParam) -{ - switch (msg) { - case WM_LBUTTONDOWN: - case WM_RBUTTONDOWN: - case WM_MBUTTONDOWN: - last_button = 1; - last_pos = lParam; - caml_gr_enqueue_event(EVENT_BUTTON_DOWN, lParam, 1, 0); - break; - - case WM_LBUTTONUP: - case WM_RBUTTONUP: - case WM_MBUTTONUP: - last_button = 0; - last_pos = lParam; - caml_gr_enqueue_event(EVENT_BUTTON_UP, lParam, 0, 0); - break; - - case WM_CHAR: - caml_gr_enqueue_event(EVENT_KEY_PRESSED, last_pos, last_button, wParam); - break; - - case WM_MOUSEMOVE: - last_pos = lParam; - caml_gr_enqueue_event(EVENT_MOUSE_MOTION, lParam, last_button, 0); - break; - case WM_DESTROY: - // Release any calls to Graphics.wait_next_event - ReleaseSemaphore(caml_gr_queue_semaphore, 1, NULL); - break; - } -} - -static value caml_gr_wait_allocate_result(int mouse_x, int mouse_y, - int button, - int keypressed, int key) -{ - value res = caml_alloc_small(5, 0); - Field(res, 0) = Val_int(mouse_x); - Field(res, 1) = Val_int(grwindow.height - 1 - mouse_y); - Field(res, 2) = Val_bool(button); - Field(res, 3) = Val_bool(keypressed); - Field(res, 4) = Val_int(key & 0xFF); - return res; -} - -static value caml_gr_wait_event_poll(void) -{ - int key, keypressed, i; - - /* Look inside event queue for pending KeyPress events */ - EnterCriticalSection(&caml_gr_queue_mutex); - key = 0; - keypressed = 0; - for (i = caml_gr_head; i != caml_gr_tail; i = (i + 1) % SIZE_QUEUE) { - if (caml_gr_queue[i].kind == EVENT_KEY_PRESSED) { - keypressed = 1; - key = caml_gr_queue[i].key; - break; - } - } - LeaveCriticalSection(&caml_gr_queue_mutex); - /* Use global vars for mouse position and buttons */ - return caml_gr_wait_allocate_result(GET_X_LPARAM(last_pos), - GET_Y_LPARAM(last_pos), - last_button, - keypressed, key); -} - -static value caml_gr_wait_event_blocking(int mask) -{ - struct event_data ev; - - /* Increase the selected events if needed */ - caml_gr_event_mask |= mask; - /* Pop events from queue until one matches */ - do { - /* Wait for event queue to be non-empty */ - WaitForSingleObject(caml_gr_queue_semaphore, INFINITE); - /* Pop oldest event in queue */ - EnterCriticalSection(&caml_gr_queue_mutex); - ev = caml_gr_queue[caml_gr_head]; - /* Empty queue means the window was closed */ - if (QueueIsEmpty) { - ev.kind = EVENT_WINDOW_CLOSED; - } else { - caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE; - } - LeaveCriticalSection(&caml_gr_queue_mutex); - /* Check if it matches */ - } while ((ev.kind & mask) == 0); - - if (ev.kind == EVENT_WINDOW_CLOSED) { - gr_fail("graphic screen not opened", NULL); - } - - return caml_gr_wait_allocate_result(ev.mouse_x, ev.mouse_y, ev.button, - ev.kind == EVENT_KEY_PRESSED, - ev.key); -} - -CAMLprim value caml_gr_wait_event(value eventlist) /* ML */ -{ - int mask, poll; - - gr_check_open(); - mask = EVENT_WINDOW_CLOSED; - poll = 0; - while (eventlist != Val_int(0)) { - switch (Int_val(Field(eventlist, 0))) { - case 0: /* Button_down */ - mask |= EVENT_BUTTON_DOWN; break; - case 1: /* Button_up */ - mask |= EVENT_BUTTON_UP; break; - case 2: /* Key_pressed */ - mask |= EVENT_KEY_PRESSED; break; - case 3: /* Mouse_motion */ - mask |= EVENT_MOUSE_MOTION; break; - case 4: /* Poll */ - poll = 1; break; - } - eventlist = Field(eventlist, 1); - } - if (poll) - return caml_gr_wait_event_poll(); - else - return caml_gr_wait_event_blocking(mask); -} diff --git a/otherlibs/win32graph/libgraph.h b/otherlibs/win32graph/libgraph.h deleted file mode 100644 index 674f92f5..00000000 --- a/otherlibs/win32graph/libgraph.h +++ /dev/null @@ -1,78 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Jacob Navia, after Xavier Leroy */ -/* */ -/* Copyright 2001 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include -#include -#include - -struct canvas { - int w, h; /* Dimensions of the drawable */ - HWND win; /* The drawable itself */ - HDC gc; /* The associated graphics context */ -}; - -extern HWND grdisplay; /* The display connection */ -extern COLORREF grbackground; -extern BOOL grdisplay_mode; /* Display-mode flag */ -extern BOOL grremember_mode; /* Remember-mode flag */ -extern int grx, gry; /* Coordinates of the current point */ -extern int grcolor; /* Current *CAML* drawing color (can be -1) */ -extern HFONT * grfont; /* Current font */ - -extern BOOL direct_rgb; -extern int byte_order; -extern int bitmap_unit; -extern int bits_per_pixel; - -#define Wcvt(y) (grwindow.height - 1 - (y)) -#define Bcvt(y) (grwindow.height - 1 - (y)) -#define WtoB(y) ((y) + WindowRect.bottom - grwindow.h) - -#define DEFAULT_SCREEN_WIDTH 1024 -#define DEFAULT_SCREEN_HEIGHT 768 -#define BORDER_WIDTH 2 -#define WINDOW_NAME "OCaml graphics" -#define ICON_NAME "OCaml graphics" -#define SIZE_QUEUE 256 - -void gr_fail(char *fmt, char *arg); -void gr_check_open(void); -CAMLprim value caml_gr_set_color(value vcolor); - -// Windows specific definitions -extern RECT WindowRect; -extern int grCurrentColor; - -typedef struct tagWindow { - HDC gc; - HDC gcBitmap; - HWND hwnd; - HBRUSH CurrentBrush; - HPEN CurrentPen; - DWORD CurrentColor; - int width; - int height; - int grx; - int gry; - HBITMAP hBitmap; - HFONT CurrentFont; - int CurrentFontSize; - HDC tempDC; // For image operations; -} GR_WINDOW; - -extern GR_WINDOW grwindow; -HFONT CreationFont(char *name); -extern void caml_gr_init_event_queue(void); -extern void caml_gr_handle_event(UINT msg, WPARAM wParam, LPARAM lParam); diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c deleted file mode 100644 index 3bde8a2f..00000000 --- a/otherlibs/win32graph/open.c +++ /dev/null @@ -1,372 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Developed by Jacob Navia, based on code by J-M Geffroy and X Leroy */ -/* */ -/* Copyright 2001 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#include -#include -#include "caml/mlvalues.h" -#include "caml/fail.h" -#include "libgraph.h" -#include "caml/callback.h" -#include - -static value gr_reset(void); -static long tid; -static HANDLE threadHandle; -HWND grdisplay = NULL; -int grscreen; -COLORREF grwhite, grblack; -COLORREF grbackground; -int grCurrentColor; -struct canvas grbstore; -BOOL grdisplay_mode; -BOOL grremember_mode; -int grx, gry; -int grcolor; -extern HFONT * grfont; -MSG msg; - -static char *szOcamlWindowClass = "OcamlWindowClass"; -static BOOL gr_initialized = 0; -CAMLprim value caml_gr_clear_graph(value unit); -HANDLE hInst; - -HFONT CreationFont(char *name) -{ - LOGFONTA CurrentFont; - memset(&CurrentFont, 0, sizeof(LOGFONTA)); - CurrentFont.lfCharSet = ANSI_CHARSET; - CurrentFont.lfWeight = FW_NORMAL; - CurrentFont.lfHeight = grwindow.CurrentFontSize; - CurrentFont.lfPitchAndFamily = (BYTE) (FIXED_PITCH | FF_MODERN); - strncpy(CurrentFont.lfFaceName, name, sizeof(CurrentFont.lfFaceName)); - CurrentFont.lfFaceName[sizeof(CurrentFont.lfFaceName) - 1] = 0; - return (CreateFontIndirectA(&CurrentFont)); -} - -void SetCoordinates(HWND hwnd) -{ - RECT rc; - - GetClientRect(hwnd,&rc); - grwindow.width = rc.right; - grwindow.height = rc.bottom; - gr_reset(); -} - -void ResetForClose(HWND hwnd) -{ - DeleteDC(grwindow.tempDC); - DeleteDC(grwindow.gcBitmap); - DeleteObject(grwindow.hBitmap); - memset(&grwindow,0,sizeof(grwindow)); - gr_initialized = 0; -} - - - -static LRESULT CALLBACK GraphicsWndProc(HWND hwnd,UINT msg,WPARAM wParam, - LPARAM lParam) -{ - PAINTSTRUCT ps; - HDC hdc; - - switch (msg) { - // Create the MDI client invisible window - case WM_CREATE: - break; - case WM_PAINT: - hdc = BeginPaint(hwnd,&ps); - BitBlt(hdc,0,0,grwindow.width,grwindow.height, - grwindow.gcBitmap,0,0,SRCCOPY); - EndPaint(hwnd,&ps); - break; - // Move the child windows - case WM_SIZE: - // Position the MDI client window between the tool and - // status bars - if (wParam != SIZE_MINIMIZED) { - SetCoordinates(hwnd); - } - - return 0; - // End application - case WM_DESTROY: - ResetForClose(hwnd); - break; - } - caml_gr_handle_event(msg, wParam, lParam); - return DefWindowProcA(hwnd, msg, wParam, lParam); -} - -int DoRegisterClass(void) -{ - WNDCLASSA wc; - - memset(&wc,0,sizeof(WNDCLASS)); - wc.style = CS_HREDRAW|CS_VREDRAW|CS_OWNDC ; - wc.lpfnWndProc = (WNDPROC)GraphicsWndProc; - wc.hInstance = hInst; - wc.hbrBackground = (HBRUSH)(COLOR_WINDOW+1); - wc.lpszClassName = szOcamlWindowClass; - wc.lpszMenuName = 0; - wc.hCursor = LoadCursor(NULL,IDC_ARROW); - wc.hIcon = 0; - return RegisterClassA(&wc); -} - -static value gr_reset(void) -{ - RECT rc; - int screenx,screeny; - - screenx = GetSystemMetrics(SM_CXSCREEN); - screeny = GetSystemMetrics(SM_CYSCREEN); - GetClientRect(grwindow.hwnd,&rc); - grwindow.gc = GetDC(grwindow.hwnd); - grwindow.width = rc.right; - grwindow.height = rc.bottom; - if (grwindow.gcBitmap == (HDC)0) { - grwindow.hBitmap = CreateCompatibleBitmap(grwindow.gc,screenx, - screeny); - grwindow.gcBitmap = CreateCompatibleDC(grwindow.gc); - grwindow.tempDC = CreateCompatibleDC(grwindow.gc); - SelectObject(grwindow.gcBitmap,grwindow.hBitmap); - SetMapMode(grwindow.gcBitmap,MM_TEXT); - MoveToEx(grwindow.gcBitmap,0,grwindow.height-1,0); - BitBlt(grwindow.gcBitmap,0,0,screenx,screeny, - grwindow.gcBitmap,0,0,WHITENESS); - grwindow.CurrentFontSize = 15; - grwindow.CurrentFont = CreationFont("Courier"); - } - grwindow.CurrentColor = GetSysColor(COLOR_WINDOWTEXT); - grwindow.grx = 0; - grwindow.gry = 0; - grwindow.CurrentPen = SelectObject(grwindow.gc, - GetStockObject(WHITE_PEN)); - SelectObject(grwindow.gc,grwindow.CurrentPen); - SelectObject(grwindow.gcBitmap,grwindow.CurrentPen); - grwindow.CurrentBrush = SelectObject(grwindow.gc, - GetStockObject(WHITE_BRUSH)); - SelectObject(grwindow.gc,grwindow.CurrentBrush); - SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); - caml_gr_set_color(Val_long(0)); - SelectObject(grwindow.gc,grwindow.CurrentFont); - SelectObject(grwindow.gcBitmap,grwindow.CurrentFont); - grdisplay_mode = grremember_mode = 1; - MoveToEx(grwindow.gc,0,grwindow.height-1,0); - MoveToEx(grwindow.gcBitmap,0,grwindow.height-1,0); - SetTextAlign(grwindow.gcBitmap,TA_BOTTOM); - SetTextAlign(grwindow.gc,TA_BOTTOM); - return Val_unit; -} - -void SuspendGraphicThread(void) -{ - SuspendThread(threadHandle); -} - -void ResumeGraphicThread(void) -{ - ResumeThread(threadHandle); -} - -/* For handshake between the event handling thread and the main thread */ -static char * open_graph_errmsg; -static HANDLE open_graph_event; - -static DWORD WINAPI gr_open_graph_internal(value arg) -{ - RECT rc; - int ret; - int event; - int x, y, w, h; - int screenx,screeny; - int attributes; - static int registered; - MSG msg; - - gr_initialized = TRUE; - hInst = GetModuleHandle(NULL); - x = y = w = h = CW_USEDEFAULT; - sscanf(String_val(arg), "%dx%d+%d+%d", &w, &h, &x, &y); - - /* Open the display */ - if (grwindow.hwnd == NULL || !IsWindow(grwindow.hwnd)) { - if (!registered) { - registered = DoRegisterClass(); - if (!registered) { - open_graph_errmsg = "Cannot register the window class"; - SetEvent(open_graph_event); - return 1; - } - } - grwindow.hwnd = CreateWindowA(szOcamlWindowClass, - WINDOW_NAME, - WS_OVERLAPPEDWINDOW, - x,y, - w,h, - NULL,0,hInst,NULL); - if (grwindow.hwnd == NULL) { - open_graph_errmsg = "Cannot create window"; - SetEvent(open_graph_event); - return 1; - } -#if 0 - if (x != CW_USEDEFAULT) { - rc.left = 0; - rc.top = 0; - rc.right = w; - rc.bottom = h; - AdjustWindowRect(&rc,GetWindowLong(grwindow.hwnd,GWL_STYLE),0); - MoveWindow(grwindow.hwnd,x,y,rc.right-rc.left,rc.bottom-rc.top,1); - } -#endif - } - gr_reset(); - ShowWindow(grwindow.hwnd,SW_SHOWNORMAL); - - /* Position the current point at origin */ - grwindow.grx = 0; - grwindow.gry = 0; - - caml_gr_init_event_queue(); - - /* The global data structures are now correctly initialized. - Restart the OCaml main thread. */ - open_graph_errmsg = NULL; - SetEvent(open_graph_event); - - /* Enter the message handling loop */ - while (GetMessage(&msg,NULL,0,0)) { - TranslateMessage(&msg); // Translates virtual key codes - DispatchMessage(&msg); // Dispatches message to window - if (!IsWindow(grwindow.hwnd)) - break; - } - return 0; -} - -CAMLprim value caml_gr_open_graph(value arg) -{ - DWORD tid; - if (gr_initialized) return Val_unit; - open_graph_event = CreateEvent(NULL, FALSE, FALSE, NULL); - threadHandle = - CreateThread(NULL,0, - (LPTHREAD_START_ROUTINE)gr_open_graph_internal,(void **)arg, - 0, - &tid); - WaitForSingleObject(open_graph_event, INFINITE); - CloseHandle(open_graph_event); - if (open_graph_errmsg != NULL) gr_fail("%s", open_graph_errmsg); - return Val_unit; -} - -CAMLprim value caml_gr_close_graph(value unit) -{ - if (gr_initialized) { - PostMessage(grwindow.hwnd, WM_CLOSE, 0, 0); - WaitForSingleObject(threadHandle, INFINITE); - } - return Val_unit; -} - -CAMLprim value caml_gr_clear_graph(value unit) -{ - gr_check_open(); - if(grremember_mode) { - BitBlt(grwindow.gcBitmap,0,0,grwindow.width,grwindow.height, - grwindow.gcBitmap,0,0,WHITENESS); - } - if(grdisplay_mode) { - BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height, - grwindow.gc,0,0,WHITENESS); - } - return Val_unit; -} - -CAMLprim value caml_gr_size_x(value unit) -{ - gr_check_open(); - return Val_int(grwindow.width); -} - -CAMLprim value caml_gr_size_y(value unit) -{ - gr_check_open(); - return Val_int(grwindow.height); -} - -CAMLprim value caml_gr_resize_window (value vx, value vy) -{ - gr_check_open (); - - /* FIXME TODO implement this function... */ - - return Val_unit; -} - -CAMLprim value caml_gr_synchronize(value unit) -{ - gr_check_open(); - BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height, - grwindow.gcBitmap,0,0,SRCCOPY); - return Val_unit ; -} - -CAMLprim value caml_gr_display_mode(value flag) -{ - grdisplay_mode = (Int_val(flag)) ? 1 : 0; - return Val_unit ; -} - -CAMLprim value caml_gr_remember_mode(value flag) -{ - grremember_mode = (Int_val(flag)) ? 1 : 0; - return Val_unit ; -} - -CAMLprim value caml_gr_sigio_signal(value unit) -{ - return Val_unit; -} - -CAMLprim value caml_gr_sigio_handler(value unit) -{ - return Val_unit; -} - - -/* Processing of graphic errors */ - -static value * graphic_failure_exn = NULL; -void gr_fail(char *fmt, char *arg) -{ - char buffer[1024]; - - if (graphic_failure_exn == NULL) { - graphic_failure_exn = caml_named_value("Graphics.Graphic_failure"); - if (graphic_failure_exn == NULL) - caml_invalid_argument("Exception Graphics.Graphic_failure not " - "initialized, must link graphics.cma"); - } - sprintf(buffer, fmt, arg); - caml_raise_with_string(*graphic_failure_exn, buffer); -} - -void gr_check_open(void) -{ - if (!gr_initialized) gr_fail("graphic screen not opened", NULL); -} diff --git a/otherlibs/win32unix/mmap.c b/otherlibs/win32unix/mmap.c index 6a97e7f0..da08a19f 100644 --- a/otherlibs/win32unix/mmap.c +++ b/otherlibs/win32unix/mmap.c @@ -26,31 +26,12 @@ #include "caml/osdeps.h" #include "unixsupport.h" -/* Temporary compatibility stuff so that this file can also be compiled - from otherlibs/bigarray/ and included in the bigarray library. */ - -#ifdef IN_OCAML_BIGARRAY -#define MAP_FILE_FUNCTION caml_ba_map_file -#define MAP_FILE_FUNCTION_BYTECODE caml_ba_map_file_bytecode -#define UNMAP_FILE_FUNCTION caml_ba_unmap_file -#define ALLOC_FUNCTION caml_ba_mapped_alloc -#define CAML_MAP_FILE "Bigarray.map_file" -static void caml_ba_sys_error(void); -#define MAP_FILE_ERROR() caml_ba_sys_error() -#else -#define MAP_FILE_FUNCTION caml_unix_map_file -#define MAP_FILE_FUNCTION_BYTECODE caml_unix_map_file_bytecode -#define UNMAP_FILE_FUNCTION caml_unix_unmap_file -#define ALLOC_FUNCTION caml_unix_mapped_alloc -#define MAP_FILE_FUNCTION caml_unix_map_file -#define CAML_MAP_FILE "Unix.map_file" -#define MAP_FILE_ERROR() \ - do { win32_maperr(GetLastError()); uerror("map_file", Nothing); } while(0) -#endif +#define uerror(func, arg) \ + do { win32_maperr(GetLastError()); uerror(func, arg); } while(0) /* Defined in [mmap_ba.c] */ CAMLextern value -ALLOC_FUNCTION(int flags, int num_dims, void * data, intnat * dim); +caml_unix_mapped_alloc(int flags, int num_dims, void * data, intnat * dim); #ifndef INVALID_SET_FILE_POINTER #define INVALID_SET_FILE_POINTER (-1) @@ -67,8 +48,8 @@ static __int64 caml_set_file_pointer(HANDLE h, __int64 dist, DWORD mode) return i.QuadPart; } -CAMLprim value MAP_FILE_FUNCTION(value vfd, value vkind, value vlayout, - value vshared, value vdim, value vstart) +CAMLprim value caml_unix_map_file(value vfd, value vkind, value vlayout, + value vshared, value vdim, value vstart) { HANDLE fd, fmap; int flags, major_dim, mode, perm; @@ -89,18 +70,18 @@ CAMLprim value MAP_FILE_FUNCTION(value vfd, value vkind, value vlayout, /* Extract dimensions from OCaml array */ num_dims = Wosize_val(vdim); if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS) - caml_invalid_argument(CAML_MAP_FILE ": bad number of dimensions"); + caml_invalid_argument("Unix.map_file: bad number of dimensions"); for (i = 0; i < num_dims; i++) { dim[i] = Long_val(Field(vdim, i)); if (dim[i] == -1 && i == major_dim) continue; if (dim[i] < 0) - caml_invalid_argument(CAML_MAP_FILE ": negative dimension"); + caml_invalid_argument("Unix.map_file: negative dimension"); } /* Determine file size */ currpos = caml_set_file_pointer(fd, 0, FILE_CURRENT); - if (currpos == -1) MAP_FILE_ERROR(); + if (currpos == -1) uerror("map_file", Nothing); file_size = caml_set_file_pointer(fd, 0, FILE_END); - if (file_size == -1) MAP_FILE_ERROR(); + if (file_size == -1) uerror("map_file", Nothing); /* Determine array size in bytes (or size of array without the major dimension if that dimension wasn't specified) */ array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK]; @@ -110,12 +91,12 @@ CAMLprim value MAP_FILE_FUNCTION(value vfd, value vkind, value vlayout, if (dim[major_dim] == -1) { /* Determine first/last dimension from file size */ if (file_size < startpos) - caml_failwith(CAML_MAP_FILE ": file position exceeds file size"); + caml_failwith("Unix.map_file: file position exceeds file size"); data_size = file_size - startpos; dim[major_dim] = (uintnat) (data_size / array_size); array_size = dim[major_dim] * array_size; if (array_size != data_size) - caml_failwith(CAML_MAP_FILE ": file size doesn't match array dimensions"); + caml_failwith("Unix.map_file: file size doesn't match array dimensions"); } /* Restore original file position */ caml_set_file_pointer(fd, currpos, FILE_BEGIN); @@ -129,7 +110,7 @@ CAMLprim value MAP_FILE_FUNCTION(value vfd, value vkind, value vlayout, } li.QuadPart = startpos + array_size; fmap = CreateFileMapping(fd, NULL, perm, li.HighPart, li.LowPart, NULL); - if (fmap == NULL) MAP_FILE_ERROR(); + if (fmap == NULL) uerror("map_file", Nothing); /* Determine offset so that the mapping starts at the given file pos */ GetSystemInfo(&sysinfo); delta = (uintnat) (startpos % sysinfo.dwAllocationGranularity); @@ -137,21 +118,21 @@ CAMLprim value MAP_FILE_FUNCTION(value vfd, value vkind, value vlayout, li.QuadPart = startpos - delta; addr = MapViewOfFile(fmap, mode, li.HighPart, li.LowPart, array_size + delta); - if (addr == NULL) MAP_FILE_ERROR(); + if (addr == NULL) uerror("map_file", Nothing); addr = (void *) ((uintnat) addr + delta); /* Close the file mapping */ CloseHandle(fmap); /* Build and return the OCaml bigarray */ - return ALLOC_FUNCTION(flags, num_dims, addr, dim); + return caml_unix_mapped_alloc(flags, num_dims, addr, dim); } -CAMLprim value MAP_FILE_FUNCTION_BYTECODE(value * argv, int argn) +CAMLprim value caml_unix_map_file_bytecode(value * argv, int argn) { - return MAP_FILE_FUNCTION(argv[0], argv[1], argv[2], - argv[3], argv[4], argv[5]); + return caml_unix_map_file(argv[0], argv[1], argv[2], + argv[3], argv[4], argv[5]); } -void UNMAP_FILE_FUNCTION(void * addr, uintnat len) +void caml_ba_unmap_file(void * addr, uintnat len) { SYSTEM_INFO sysinfo; uintnat delta; diff --git a/otherlibs/win32unix/nonblock.c b/otherlibs/win32unix/nonblock.c old mode 100755 new mode 100644 diff --git a/otherlibs/win32unix/unixsupport.c b/otherlibs/win32unix/unixsupport.c index 71769e94..c6005bfc 100644 --- a/otherlibs/win32unix/unixsupport.c +++ b/otherlibs/win32unix/unixsupport.c @@ -265,7 +265,7 @@ int error_table[] = { EHOSTUNREACH, ELOOP, EOVERFLOW /*, EUNKNOWNERR */ }; -static value * unix_error_exn = NULL; +static const value * unix_error_exn = NULL; value unix_error_of_code (int errcode) { diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml old mode 100755 new mode 100644 diff --git a/parsing/ast_iterator.mli b/parsing/ast_iterator.mli old mode 100755 new mode 100644 diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index f2fcd92f..8488f153 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -803,7 +803,7 @@ module PpxContext = struct lid "for_package", make_option make_string !Clflags.for_package; lid "debug", make_bool !Clflags.debug; lid "use_threads", make_bool !Clflags.use_threads; - lid "use_vmthreads", make_bool !Clflags.use_vmthreads; + lid "use_vmthreads", make_bool false; lid "recursive_types", make_bool !Clflags.recursive_types; lid "principal", make_bool !Clflags.principal; lid "transparent_modules", make_bool !Clflags.transparent_modules; @@ -878,7 +878,8 @@ module PpxContext = struct | "use_threads" -> Clflags.use_threads := get_bool payload | "use_vmthreads" -> - Clflags.use_vmthreads := get_bool payload + if get_bool payload then + raise_errorf "Internal error: vmthreads not supported after 4.09.0" | "recursive_types" -> Clflags.recursive_types := get_bool payload | "principal" -> diff --git a/parsing/builtin_attributes.ml b/parsing/builtin_attributes.ml old mode 100755 new mode 100644 diff --git a/parsing/builtin_attributes.mli b/parsing/builtin_attributes.mli old mode 100755 new mode 100644 index 35e78abf..03949eea --- a/parsing/builtin_attributes.mli +++ b/parsing/builtin_attributes.mli @@ -32,14 +32,13 @@ *) - val check_alerts: Location.t -> Parsetree.attributes -> string -> unit val check_alerts_inclusion: def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes -> Parsetree.attributes -> string -> unit -val alerts_of_attrs: Parsetree.attributes -> string Misc.Stdlib.String.Map.t -val alerts_of_sig: Parsetree.signature -> string Misc.Stdlib.String.Map.t -val alerts_of_str: Parsetree.structure -> string Misc.Stdlib.String.Map.t +val alerts_of_attrs: Parsetree.attributes -> Misc.alerts +val alerts_of_sig: Parsetree.signature -> Misc.alerts +val alerts_of_str: Parsetree.structure -> Misc.alerts val check_deprecated_mutable: Location.t -> Parsetree.attributes -> string -> unit diff --git a/parsing/depend.mli b/parsing/depend.mli index cbed53b9..74c095f9 100644 --- a/parsing/depend.mli +++ b/parsing/depend.mli @@ -30,7 +30,7 @@ val weaken_map : String.Set.t -> map_tree -> map_tree val free_structure_names : String.Set.t ref -(** dependencies found by preprocessing tools (plugins) *) +(** dependencies found by preprocessing tools *) val pp_deps : string list ref val open_module : bound_map -> Longident.t -> bound_map diff --git a/parsing/location.ml b/parsing/location.ml index 1c0cda3a..25cba42c 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -190,9 +190,10 @@ let print_loc ppf loc = if loc.loc_start.pos_fname = "" then !input_name else loc.loc_start.pos_fname in - let line = loc.loc_start.pos_lnum in + let startline = loc.loc_start.pos_lnum in + let endline = loc.loc_end.pos_lnum in let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in - let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_bol in + let endchar = loc.loc_end.pos_cnum - loc.loc_end.pos_bol in let first = ref true in let capitalize s = @@ -210,8 +211,13 @@ let print_loc ppf loc = existing setup of editors that parse locations in error messages (e.g. Emacs). *) comma (); - Format.fprintf ppf "%s %i" (capitalize "line") - (if line_valid line then line else 1); + let startline = if line_valid startline then startline else 1 in + let endline = if line_valid endline then endline else startline in + begin if startline = endline then + Format.fprintf ppf "%s %i" (capitalize "line") startline + else + Format.fprintf ppf "%s %i-%i" (capitalize "lines") startline endline + end; if chars_valid ~startchar ~endchar then ( comma (); @@ -660,10 +666,9 @@ let is_quotable_loc loc = && loc.loc_end.pos_fname = !input_name let error_style () = - let open Misc.Error_style in match !Clflags.error_style with - | Some Contextual | None -> Contextual - | Some Short -> Short + | Some setting -> setting + | None -> Misc.Error_style.default_setting let batch_mode_printer : report_printer = let pp_loc _self report ppf loc = @@ -882,17 +887,6 @@ let () = (function | Sys_error msg -> Some (errorf ~loc:(in_file !input_name) "I/O error: %s" msg) - - | Misc.HookExnWrapper {error = e; hook_name; - hook_info={Misc.sourcefile}} -> - let sub = match error_of_exn e with - | None | Some `Already_displayed -> - [msg "%s" (Printexc.to_string e)] - | Some (`Ok err) -> - (msg ~loc:err.main.loc "%t" err.main.txt) :: err.sub - in - Some - (errorf ~loc:(in_file sourcefile) ~sub "In hook %S:" hook_name) | _ -> None ) diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 1590a89d..318ece49 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -471,7 +471,7 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = | Ppat_constraint (p, ct) -> pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct | Ppat_lazy p -> - pp f "@[<2>(lazy@;%a)@]" (pattern1 ctxt) p + pp f "@[<2>(lazy@;%a)@]" (simple_pattern ctxt) p | Ppat_exception p -> pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p | Ppat_extension e -> extension ctxt f e @@ -586,6 +586,7 @@ and expression ctxt f x = (attributes ctxt) x.pexp_attributes else match x.pexp_desc with | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ + | Pexp_newtype _ when ctxt.pipe || ctxt.semi -> paren true (expression reset_ctxt) f x | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse -> @@ -598,6 +599,9 @@ and expression ctxt f x = pp f "@[<2>fun@;%a->@;%a@]" (label_exp ctxt) (l, e0, p) (expression ctxt) e + | Pexp_newtype (lid, e) -> + pp f "@[<2>fun@;(type@;%s)@;->@;%a@]" lid.txt + (expression ctxt) e | Pexp_function l -> pp f "@[function%a@]" (case_list ctxt) l | Pexp_match (e, l) -> @@ -762,8 +766,6 @@ and simple_expr ctxt f x = | Pexp_constant c -> constant f c; | Pexp_pack me -> pp f "(module@;%a)" (module_expr ctxt) me - | Pexp_newtype (lid, e) -> - pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e | Pexp_tuple l -> pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l | Pexp_constraint (e, ct) -> diff --git a/runtime/.depend b/runtime/.depend index 3b707ee4..a89d380d 100644 --- a/runtime/.depend +++ b/runtime/.depend @@ -2018,292 +2018,6 @@ win32_ni.$(O): win32.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ caml/address_class.h caml/misc.h caml/osdeps.h caml/memory.h \ caml/signals.h caml/sys.h caml/config.h -afl_np.$(O): afl.c caml/config.h caml/m.h caml/s.h caml/misc.h caml/config.h \ - caml/mlvalues.h caml/misc.h caml/osdeps.h caml/memory.h caml/gc.h \ - caml/mlvalues.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h -alloc_np.$(O): alloc.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \ - caml/mlvalues.h caml/custom.h caml/major_gc.h caml/freelist.h \ - caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ - caml/address_class.h caml/mlvalues.h caml/stacks.h caml/memory.h -array_np.$(O): array.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \ - caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ - caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ - caml/mlvalues.h caml/signals.h caml/spacetime.h caml/io.h caml/stack.h -backtrace_np.$(O): backtrace.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ - caml/s.h caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \ - caml/freelist.h caml/minor_gc.h caml/address_class.h caml/backtrace.h \ - caml/exec.h caml/backtrace_prim.h caml/backtrace.h caml/fail.h -backtrace_byt_np.$(O): backtrace_byt.c caml/config.h caml/m.h caml/s.h \ - caml/mlvalues.h caml/config.h caml/misc.h caml/alloc.h caml/mlvalues.h \ - caml/custom.h caml/io.h caml/instruct.h caml/intext.h caml/io.h \ - caml/exec.h caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \ - caml/freelist.h caml/minor_gc.h caml/address_class.h caml/startup.h \ - caml/exec.h caml/stacks.h caml/memory.h caml/sys.h caml/backtrace.h \ - caml/fail.h caml/backtrace_prim.h caml/backtrace.h -backtrace_nat_np.$(O): backtrace_nat.c caml/alloc.h caml/misc.h caml/config.h \ - caml/m.h caml/s.h caml/mlvalues.h caml/backtrace.h caml/exec.h \ - caml/backtrace_prim.h caml/backtrace.h caml/memory.h caml/gc.h \ - caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ - caml/misc.h caml/mlvalues.h caml/stack.h -bigarray_np.$(O): bigarray.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ - caml/s.h caml/mlvalues.h caml/bigarray.h caml/custom.h caml/fail.h \ - caml/intext.h caml/io.h caml/hash.h caml/memory.h caml/gc.h \ - caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ - caml/mlvalues.h caml/signals.h -callback_np.$(O): callback.c caml/callback.h caml/mlvalues.h caml/config.h \ - caml/m.h caml/s.h caml/misc.h caml/fail.h caml/memory.h caml/gc.h \ - caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ - caml/mlvalues.h -clambda_checks_np.$(O): clambda_checks.c caml/mlvalues.h caml/config.h caml/m.h \ - caml/s.h caml/misc.h -compact_np.$(O): compact.c caml/address_class.h caml/config.h caml/m.h caml/s.h \ - caml/misc.h caml/mlvalues.h caml/config.h caml/finalise.h caml/roots.h \ - caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \ - caml/major_gc.h caml/memory.h caml/mlvalues.h caml/roots.h caml/weak.h \ - caml/compact.h -compare_np.$(O): compare.c caml/custom.h caml/mlvalues.h caml/config.h caml/m.h \ - caml/s.h caml/misc.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ - caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ - caml/mlvalues.h -custom_np.$(O): custom.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ - caml/s.h caml/mlvalues.h caml/custom.h caml/fail.h caml/gc_ctrl.h \ - caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h caml/mlvalues.h caml/signals.h -debugger_np.$(O): debugger.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ - caml/s.h caml/mlvalues.h caml/config.h caml/debugger.h caml/misc.h \ - caml/osdeps.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ - caml/minor_gc.h caml/address_class.h -dynlink_np.$(O): dynlink.c caml/config.h caml/m.h caml/s.h caml/alloc.h \ - caml/misc.h caml/config.h caml/mlvalues.h caml/dynlink.h caml/fail.h \ - caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ - caml/minor_gc.h caml/address_class.h caml/misc.h caml/osdeps.h \ - caml/memory.h caml/prims.h caml/signals.h -dynlink_nat_np.$(O): dynlink_nat.c caml/misc.h caml/config.h caml/m.h caml/s.h \ - caml/mlvalues.h caml/misc.h caml/memory.h caml/gc.h caml/mlvalues.h \ - caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ - caml/stack.h caml/callback.h caml/alloc.h caml/intext.h caml/io.h \ - caml/osdeps.h caml/memory.h caml/fail.h caml/signals.h caml/hooks.h -extern_np.$(O): extern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ - caml/s.h caml/mlvalues.h caml/config.h caml/custom.h caml/fail.h \ - caml/gc.h caml/intext.h caml/io.h caml/io.h caml/md5.h caml/memory.h \ - caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h caml/misc.h caml/mlvalues.h caml/reverse.h -fail_byt_np.$(O): fail_byt.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ - caml/s.h caml/mlvalues.h caml/fail.h caml/io.h caml/gc.h caml/memory.h \ - caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h caml/misc.h caml/mlvalues.h caml/printexc.h \ - caml/signals.h caml/stacks.h caml/memory.h -fail_nat_np.$(O): fail_nat.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ - caml/s.h caml/mlvalues.h caml/fail.h caml/io.h caml/gc.h caml/memory.h \ - caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h caml/mlvalues.h caml/printexc.h caml/signals.h \ - caml/stack.h caml/roots.h caml/memory.h caml/callback.h -finalise_np.$(O): finalise.c caml/callback.h caml/mlvalues.h caml/config.h \ - caml/m.h caml/s.h caml/misc.h caml/compact.h caml/fail.h caml/finalise.h \ - caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ - caml/minor_gc.h caml/address_class.h caml/minor_gc.h caml/mlvalues.h \ - caml/roots.h caml/signals.h -fix_code_np.$(O): fix_code.c caml/config.h caml/m.h caml/s.h caml/debugger.h \ - caml/misc.h caml/config.h caml/mlvalues.h caml/fix_code.h \ - caml/instruct.h caml/intext.h caml/io.h caml/md5.h caml/memory.h \ - caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h caml/misc.h caml/mlvalues.h caml/reverse.h -floats_np.$(O): floats.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ - caml/s.h caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h \ - caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ - caml/mlvalues.h caml/misc.h caml/reverse.h caml/stacks.h caml/memory.h -freelist_np.$(O): freelist.c caml/config.h caml/m.h caml/s.h caml/freelist.h \ - caml/misc.h caml/config.h caml/mlvalues.h caml/gc.h caml/gc_ctrl.h \ - caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h caml/major_gc.h caml/misc.h caml/mlvalues.h -gc_ctrl_np.$(O): gc_ctrl.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ - caml/s.h caml/mlvalues.h caml/backtrace.h caml/exec.h caml/compact.h \ - caml/custom.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \ - caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \ - caml/major_gc.h caml/memory.h caml/minor_gc.h caml/misc.h \ - caml/mlvalues.h caml/signals.h caml/stack.h caml/startup_aux.h -globroots_np.$(O): globroots.c caml/memory.h caml/config.h caml/m.h caml/s.h \ - caml/gc.h caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ - caml/minor_gc.h caml/address_class.h caml/misc.h caml/mlvalues.h \ - caml/roots.h caml/memory.h caml/globroots.h caml/roots.h -hash_np.$(O): hash.c caml/mlvalues.h caml/config.h caml/m.h caml/s.h \ - caml/misc.h caml/custom.h caml/mlvalues.h caml/memory.h caml/gc.h \ - caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ - caml/hash.h -instrtrace_np.$(O): instrtrace.c -intern_np.$(O): intern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ - caml/s.h caml/mlvalues.h caml/callback.h caml/config.h caml/custom.h \ - caml/fail.h caml/gc.h caml/intext.h caml/io.h caml/io.h caml/md5.h \ - caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h caml/mlvalues.h caml/misc.h caml/reverse.h -interp_np.$(O): interp.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ - caml/s.h caml/mlvalues.h caml/backtrace.h caml/exec.h caml/callback.h \ - caml/debugger.h caml/fail.h caml/fix_code.h caml/instrtrace.h \ - caml/instruct.h caml/interp.h caml/major_gc.h caml/freelist.h \ - caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ - caml/address_class.h caml/misc.h caml/mlvalues.h caml/prims.h \ - caml/signals.h caml/stacks.h caml/memory.h caml/startup_aux.h \ - caml/jumptbl.h -ints_np.$(O): ints.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \ - caml/mlvalues.h caml/custom.h caml/fail.h caml/intext.h caml/io.h \ - caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h caml/misc.h caml/mlvalues.h -io_np.$(O): io.c caml/config.h caml/m.h caml/s.h caml/alloc.h caml/misc.h \ - caml/config.h caml/mlvalues.h caml/custom.h caml/fail.h caml/io.h \ - caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h caml/misc.h caml/mlvalues.h caml/osdeps.h \ - caml/memory.h caml/signals.h caml/sys.h -lexing_np.$(O): lexing.c caml/fail.h caml/misc.h caml/config.h caml/m.h \ - caml/s.h caml/mlvalues.h caml/mlvalues.h caml/stacks.h caml/memory.h \ - caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h -main_np.$(O): main.c caml/misc.h caml/config.h caml/m.h caml/s.h \ - caml/mlvalues.h caml/misc.h caml/sys.h caml/osdeps.h caml/memory.h \ - caml/gc.h caml/mlvalues.h caml/major_gc.h caml/freelist.h \ - caml/minor_gc.h caml/address_class.h -major_gc_np.$(O): major_gc.c caml/compact.h caml/config.h caml/m.h caml/s.h \ - caml/misc.h caml/mlvalues.h caml/custom.h caml/config.h caml/fail.h \ - caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \ - caml/freelist.h caml/minor_gc.h caml/address_class.h caml/freelist.h \ - caml/gc.h caml/gc_ctrl.h caml/major_gc.h caml/misc.h caml/mlvalues.h \ - caml/roots.h caml/signals.h caml/weak.h -md5_np.$(O): md5.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \ - caml/mlvalues.h caml/fail.h caml/md5.h caml/io.h caml/memory.h caml/gc.h \ - caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ - caml/mlvalues.h caml/io.h caml/reverse.h -memory_np.$(O): memory.c caml/address_class.h caml/config.h caml/m.h caml/s.h \ - caml/misc.h caml/mlvalues.h caml/config.h caml/fail.h caml/freelist.h \ - caml/gc.h caml/gc_ctrl.h caml/major_gc.h caml/freelist.h caml/memory.h \ - caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \ - caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/signals.h -meta_np.$(O): meta.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \ - caml/mlvalues.h caml/config.h caml/fail.h caml/fix_code.h caml/interp.h \ - caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \ - caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \ - caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h caml/stacks.h \ - caml/memory.h caml/backtrace_prim.h caml/backtrace.h caml/exec.h -minor_gc_np.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \ - caml/m.h caml/s.h caml/misc.h caml/config.h caml/fail.h caml/finalise.h \ - caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ - caml/minor_gc.h caml/address_class.h caml/gc.h caml/gc_ctrl.h \ - caml/major_gc.h caml/memory.h caml/minor_gc.h caml/misc.h \ - caml/mlvalues.h caml/roots.h caml/signals.h caml/weak.h -misc_np.$(O): misc.c caml/config.h caml/m.h caml/s.h caml/misc.h caml/config.h \ - caml/memory.h caml/gc.h caml/mlvalues.h caml/misc.h caml/major_gc.h \ - caml/freelist.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \ - caml/memory.h caml/version.h -obj_np.$(O): obj.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \ - caml/mlvalues.h caml/fail.h caml/gc.h caml/interp.h caml/major_gc.h \ - caml/freelist.h caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ - caml/address_class.h caml/minor_gc.h caml/misc.h caml/mlvalues.h \ - caml/prims.h caml/spacetime.h caml/io.h caml/stack.h -parsing_np.$(O): parsing.c caml/config.h caml/m.h caml/s.h caml/mlvalues.h \ - caml/config.h caml/misc.h caml/memory.h caml/gc.h caml/mlvalues.h \ - caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ - caml/alloc.h -prims_np.$(O): prims.c caml/mlvalues.h caml/config.h caml/m.h caml/s.h \ - caml/misc.h caml/prims.h -printexc_np.$(O): printexc.c caml/backtrace.h caml/mlvalues.h caml/config.h \ - caml/m.h caml/s.h caml/misc.h caml/exec.h caml/callback.h \ - caml/debugger.h caml/fail.h caml/misc.h caml/mlvalues.h caml/printexc.h \ - caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h -roots_byt_np.$(O): roots_byt.c caml/finalise.h caml/roots.h caml/misc.h \ - caml/config.h caml/m.h caml/s.h caml/memory.h caml/gc.h caml/mlvalues.h \ - caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ - caml/globroots.h caml/major_gc.h caml/memory.h caml/minor_gc.h \ - caml/misc.h caml/mlvalues.h caml/roots.h caml/stacks.h -roots_nat_np.$(O): roots_nat.c caml/finalise.h caml/roots.h caml/misc.h \ - caml/config.h caml/m.h caml/s.h caml/memory.h caml/gc.h caml/mlvalues.h \ - caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ - caml/globroots.h caml/memory.h caml/major_gc.h caml/minor_gc.h \ - caml/misc.h caml/mlvalues.h caml/stack.h caml/roots.h -signals_np.$(O): signals.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ - caml/s.h caml/mlvalues.h caml/callback.h caml/config.h caml/fail.h \ - caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h caml/misc.h caml/mlvalues.h caml/roots.h \ - caml/memory.h caml/signals.h caml/signals_machdep.h caml/sys.h -signals_byt_np.$(O): signals_byt.c caml/config.h caml/m.h caml/s.h \ - caml/memory.h caml/config.h caml/gc.h caml/mlvalues.h caml/misc.h \ - caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ - caml/osdeps.h caml/memory.h caml/signals.h caml/signals_machdep.h -signals_nat_np.$(O): signals_nat.c caml/fail.h caml/misc.h caml/config.h \ - caml/m.h caml/s.h caml/mlvalues.h caml/memory.h caml/gc.h \ - caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ - caml/osdeps.h caml/memory.h caml/signals.h caml/signals_machdep.h \ - signals_osdep.h caml/stack.h caml/spacetime.h caml/io.h caml/stack.h -spacetime_byt_np.$(O): spacetime_byt.c caml/fail.h caml/misc.h caml/config.h \ - caml/m.h caml/s.h caml/mlvalues.h caml/mlvalues.h -spacetime_nat_np.$(O): spacetime_nat.c caml/config.h caml/m.h caml/s.h \ - caml/alloc.h caml/misc.h caml/config.h caml/mlvalues.h \ - caml/backtrace_prim.h caml/backtrace.h caml/exec.h caml/fail.h caml/gc.h \ - caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \ - caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \ - caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/osdeps.h caml/memory.h \ - caml/roots.h caml/signals.h caml/stack.h caml/sys.h caml/spacetime.h \ - caml/stack.h -spacetime_snapshot_np.$(O): spacetime_snapshot.c caml/alloc.h caml/misc.h \ - caml/config.h caml/m.h caml/s.h caml/mlvalues.h caml/backtrace_prim.h \ - caml/backtrace.h caml/exec.h caml/config.h caml/custom.h caml/fail.h \ - caml/gc.h caml/gc_ctrl.h caml/intext.h caml/io.h caml/major_gc.h \ - caml/freelist.h caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ - caml/address_class.h caml/minor_gc.h caml/misc.h caml/mlvalues.h \ - caml/roots.h caml/memory.h caml/signals.h caml/stack.h caml/sys.h \ - caml/spacetime.h caml/stack.h -stacks_np.$(O): stacks.c caml/config.h caml/m.h caml/s.h caml/fail.h \ - caml/misc.h caml/config.h caml/mlvalues.h caml/misc.h caml/mlvalues.h \ - caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ - caml/minor_gc.h caml/address_class.h -startup_aux_np.$(O): startup_aux.c caml/backtrace.h caml/mlvalues.h \ - caml/config.h caml/m.h caml/s.h caml/misc.h caml/exec.h caml/memory.h \ - caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h caml/callback.h caml/major_gc.h caml/osdeps.h \ - caml/memory.h caml/startup_aux.h -startup_byt_np.$(O): startup_byt.c caml/config.h caml/m.h caml/s.h caml/alloc.h \ - caml/misc.h caml/config.h caml/mlvalues.h caml/backtrace.h caml/exec.h \ - caml/callback.h caml/custom.h caml/debugger.h caml/dynlink.h caml/exec.h \ - caml/fail.h caml/fix_code.h caml/freelist.h caml/gc_ctrl.h \ - caml/instrtrace.h caml/interp.h caml/intext.h caml/io.h caml/io.h \ - caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h caml/minor_gc.h caml/misc.h caml/mlvalues.h \ - caml/osdeps.h caml/memory.h caml/prims.h caml/printexc.h caml/reverse.h \ - caml/signals.h caml/stacks.h caml/sys.h caml/startup.h \ - caml/startup_aux.h caml/version.h -startup_nat_np.$(O): startup_nat.c caml/callback.h caml/mlvalues.h \ - caml/config.h caml/m.h caml/s.h caml/misc.h caml/backtrace.h caml/exec.h \ - caml/custom.h caml/debugger.h caml/fail.h caml/freelist.h caml/gc.h \ - caml/gc_ctrl.h caml/intext.h caml/io.h caml/memory.h caml/gc.h \ - caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ - caml/misc.h caml/mlvalues.h caml/osdeps.h caml/memory.h caml/printexc.h \ - caml/stack.h caml/startup_aux.h caml/sys.h -str_np.$(O): str.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \ - caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ - caml/freelist.h caml/minor_gc.h caml/address_class.h caml/mlvalues.h \ - caml/misc.h -sys_np.$(O): sys.c caml/config.h caml/m.h caml/s.h caml/alloc.h caml/misc.h \ - caml/config.h caml/mlvalues.h caml/debugger.h caml/fail.h caml/gc_ctrl.h \ - caml/io.h caml/misc.h caml/mlvalues.h caml/osdeps.h caml/memory.h \ - caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h caml/signals.h caml/stacks.h caml/sys.h \ - caml/version.h caml/callback.h caml/startup_aux.h -unix_np.$(O): unix.c caml/config.h caml/m.h caml/s.h caml/fail.h caml/misc.h \ - caml/config.h caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \ - caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ - caml/osdeps.h caml/memory.h caml/signals.h caml/sys.h caml/io.h \ - caml/alloc.h -weak_np.$(O): weak.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \ - caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \ - caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ - caml/address_class.h caml/mlvalues.h caml/weak.h caml/minor_gc.h \ - caml/signals.h -win32_np.$(O): win32.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \ - caml/mlvalues.h caml/address_class.h caml/fail.h caml/io.h caml/memory.h \ - caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/address_class.h caml/misc.h caml/osdeps.h caml/memory.h \ - caml/signals.h caml/sys.h caml/config.h afl_npic.$(O): afl.c caml/config.h caml/m.h caml/s.h caml/misc.h caml/config.h \ caml/mlvalues.h caml/misc.h caml/osdeps.h caml/memory.h caml/gc.h \ caml/mlvalues.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ diff --git a/runtime/Makefile b/runtime/Makefile index 9dabe5b2..7c94d621 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -78,10 +78,6 @@ BYTECODE_STATIC_LIBRARIES += libcamlruni.$(A) NATIVE_STATIC_LIBRARIES += libasmruni.$(A) endif -ifeq "$(PROFILING)" "true" -NATIVE_STATIC_LIBRARIES += libasmrunp.$(A) -endif - ifeq "$(UNIX_OR_WIN32)" "unix" ifeq "$(SUPPORTS_SHARED_LIBRARIES)" "true" BYTECODE_STATIC_LIBRARIES += libcamlrun_pic.$(A) @@ -110,9 +106,6 @@ libasmrund_OBJECTS := $(NATIVE_C_SOURCES:.c=_nd.$(O)) $(ASM_OBJECTS) libasmruni_OBJECTS := $(NATIVE_C_SOURCES:.c=_ni.$(O)) $(ASM_OBJECTS) -libasmrunp_OBJECTS := $(NATIVE_C_SOURCES:.c=_np.$(O)) \ - $(ASM_OBJECTS:.$(O)=_libasmrunp.$(O)) - libasmrunpic_OBJECTS := $(NATIVE_C_SOURCES:.c=_npic.$(O)) \ $(ASM_OBJECTS:.$(O)=_libasmrunpic.$(O)) @@ -159,15 +152,10 @@ OC_DEBUG_CPPFLAGS=-DDEBUG OC_INSTR_CPPFLAGS=-DCAML_INSTR ifeq "$(TOOLCHAIN)" "msvc" -OC_PROF_CFLAGS= -OC_PROF_CPPFLAGS=-DPROFILING ASMFLAGS= ifeq ($(WITH_SPACETIME),true) ASMFLAGS=/DWITH_SPACETIME endif -else -OC_PROF_CFLAGS=-pg -OC_PROF_CPPFLAGS=-DPROFILING endif ASPPFLAGS = -DSYS_$(SYSTEM) -I$(ROOTDIR)/runtime @@ -223,7 +211,6 @@ clean: .PHONY: distclean distclean: clean - rm -r *~ # Generated non-object files @@ -318,9 +305,6 @@ libasmrund.$(A): $(libasmrund_OBJECTS) libasmruni.$(A): $(libasmruni_OBJECTS) $(call MKLIB,$@, $^) -libasmrunp.$(A): $(libasmrunp_OBJECTS) - $(call MKLIB,$@, $^) - libasmrun_pic.$(A): $(libasmrunpic_OBJECTS) $(call MKLIB,$@, $^) @@ -341,9 +325,6 @@ libasmrun_shared.$(SO): $(libasmrunpic_OBJECTS) %_ni.$(O): OC_CPPFLAGS += $(OC_NATIVE_CPPFLAGS) $(OC_INSTR_CPPFLAGS) -%_np.$(O): OC_CFLAGS += $(OC_PROF_CFLAGS) -%_np.$(O): OC_CPPFLAGS += $(OC_NATIVE_CPPFLAGS) $(OC_PROF_CPPFLAGS) - %_npic.$(O): OC_CFLAGS += $(SHAREDLIB_CFLAGS) %_npic.$(O): OC_CPPFLAGS += $(OC_NATIVE_CPPFLAGS) @@ -371,9 +352,6 @@ $(foreach object_type, $(object_types), \ echo "try producing $*.o by hand.";\ exit 2; } -%_libasmrunp.o: %.S - $(ASPP) $(ASPPFLAGS) $(ASPPPROFFLAGS) -o $@ $< - %_libasmrunpic.o: %.S $(ASPP) $(ASPPFLAGS) $(SHAREDLIB_CFLAGS) -o $@ $< @@ -409,8 +387,6 @@ depend: *.c caml/opnames.h caml/jumptbl.h caml/version.h sed -e 's/\([^.]*\)\.o/\1_nd.$$(O)/' >> .depend $(CC) -MM $(NATIVE_DEP_CPPFLAGS) $(OC_INSTR_CPPFLAGS) *.c | \ sed -e 's/\([^.]*\)\.o/\1_ni.$$(O)/' >> .depend - $(CC) -MM $(NATIVE_DEP_CPPFLAGS) $(OC_PROF_CPPFLAGS) *.c | \ - sed -e 's/\([^.]*\)\.o/\1_np.$$(O)/' >> .depend $(CC) -MM $(NATIVE_DEP_CPPFLAGS) *.c | \ sed -e 's/\([^.]*\)\.o/\1_npic.$$(O)/' >> .depend endif diff --git a/runtime/alloc.c b/runtime/alloc.c index a3e6fbc2..3112065e 100644 --- a/runtime/alloc.c +++ b/runtime/alloc.c @@ -222,23 +222,49 @@ CAMLprim value caml_alloc_dummy_float (value size) return caml_alloc (wosize, 0); } +CAMLprim value caml_alloc_dummy_infix(value vsize, value voffset) +{ + mlsize_t wosize = Long_val(vsize), offset = Long_val(voffset); + value v = caml_alloc(wosize, Closure_tag); + if (offset > 0) { + v += Bsize_wsize(offset); + Hd_val(v) = Make_header(offset, Infix_tag, Caml_white); + } + return v; +} + CAMLprim value caml_update_dummy(value dummy, value newval) { mlsize_t size, i; tag_t tag; - size = Wosize_val(newval); tag = Tag_val (newval); - CAMLassert (size == Wosize_val(dummy)); - CAMLassert (tag < No_scan_tag || tag == Double_array_tag); - Tag_val(dummy) = tag; if (tag == Double_array_tag){ + CAMLassert (Wosize_val(newval) == Wosize_val(dummy)); + CAMLassert (Tag_val(dummy) != Infix_tag); + Tag_val(dummy) = Double_array_tag; size = Wosize_val (newval) / Double_wosize; - for (i = 0; i < size; i++){ + for (i = 0; i < size; i++) { Store_double_flat_field (dummy, i, Double_flat_field (newval, i)); } - }else{ + } else if (tag == Infix_tag) { + value clos = newval - Infix_offset_hd(Hd_val(newval)); + CAMLassert (Tag_val(clos) == Closure_tag); + CAMLassert (Tag_val(dummy) == Infix_tag); + CAMLassert (Infix_offset_val(dummy) == Infix_offset_val(newval)); + dummy = dummy - Infix_offset_val(dummy); + size = Wosize_val(clos); + CAMLassert (size == Wosize_val(dummy)); + for (i = 0; i < size; i++) { + caml_modify (&Field(dummy, i), Field(clos, i)); + } + } else { + CAMLassert (tag < No_scan_tag); + CAMLassert (Tag_val(dummy) != Infix_tag); + Tag_val(dummy) = tag; + size = Wosize_val(newval); + CAMLassert (size == Wosize_val(dummy)); for (i = 0; i < size; i++){ caml_modify (&Field(dummy, i), Field(newval, i)); } diff --git a/runtime/amd64.S b/runtime/amd64.S index 1a024283..ab54633c 100644 --- a/runtime/amd64.S +++ b/runtime/amd64.S @@ -65,6 +65,13 @@ #endif +#if defined(SYS_linux) || defined(SYS_gnu) +#define ENDFUNCTION(name) \ + .size name, . - name +#else +#define ENDFUNCTION(name) +#endif + #ifdef ASM_CFI_SUPPORTED #define CFI_STARTPROC .cfi_startproc #define CFI_ENDPROC .cfi_endproc @@ -261,11 +268,11 @@ # define PREPARE_FOR_C_CALL subq $32, %rsp; CFI_ADJUST(32) # define CLEANUP_AFTER_C_CALL addq $32, %rsp; CFI_ADJUST(-32) /* Stack probing mustn't be larger than the page size */ -# define STACK_PROBE_SIZE $4096 +# define STACK_PROBE_SIZE 4096 #else # define PREPARE_FOR_C_CALL # define CLEANUP_AFTER_C_CALL -# define STACK_PROBE_SIZE $32768 +# define STACK_PROBE_SIZE 32768 #endif /* Registers holding arguments of C functions. */ @@ -297,9 +304,9 @@ FUNCTION(G(caml_call_gc)) LBL(caml_call_gc): /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ - subq STACK_PROBE_SIZE, %rsp + subq $(STACK_PROBE_SIZE), %rsp; CFI_ADJUST(STACK_PROBE_SIZE); movq %rax, 0(%rsp) - addq STACK_PROBE_SIZE, %rsp + addq $(STACK_PROBE_SIZE), %rsp; CFI_ADJUST(-STACK_PROBE_SIZE); /* Build array of registers, save it into caml_gc_regs */ #ifdef WITH_FRAME_POINTERS ENTER_FUNCTION ; @@ -388,6 +395,7 @@ LBL(caml_call_gc): /* Return to caller */ ret CFI_ENDPROC +ENDFUNCTION(G(caml_call_gc)) FUNCTION(G(caml_alloc1)) CFI_STARTPROC @@ -405,6 +413,7 @@ LBL(100): LEAVE_FUNCTION jmp LBL(caml_alloc1) CFI_ENDPROC +ENDFUNCTION(G(caml_alloc1)) FUNCTION(G(caml_alloc2)) CFI_STARTPROC @@ -422,6 +431,7 @@ LBL(101): LEAVE_FUNCTION jmp LBL(caml_alloc2) CFI_ENDPROC +ENDFUNCTION(G(caml_alloc2)) FUNCTION(G(caml_alloc3)) CFI_STARTPROC @@ -439,6 +449,7 @@ LBL(102): LEAVE_FUNCTION jmp LBL(caml_alloc3) CFI_ENDPROC +ENDFUNCTION(G(caml_alloc3)) FUNCTION(G(caml_allocN)) CFI_STARTPROC @@ -466,6 +477,7 @@ LBL(103): popq %rax; CFI_ADJUST(-8) /* recover desired size */ jmp LBL(caml_allocN) CFI_ENDPROC +ENDFUNCTION(G(caml_allocN)) /* Call a C function from OCaml */ @@ -484,9 +496,9 @@ LBL(caml_c_call): subq $8, %rsp; CFI_ADJUST(8) /* equivalent to pushq %r12 */ /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ - subq STACK_PROBE_SIZE, %rsp + subq $(STACK_PROBE_SIZE), %rsp; CFI_ADJUST(STACK_PROBE_SIZE); movq %rax, 0(%rsp) - addq STACK_PROBE_SIZE, %rsp + addq $(STACK_PROBE_SIZE), %rsp; CFI_ADJUST(-STACK_PROBE_SIZE); /* Make the exception handler and alloc ptr available to the C code */ STORE_VAR(%r15, caml_young_ptr) STORE_VAR(%r14, caml_exception_pointer) @@ -495,6 +507,7 @@ LBL(caml_c_call): reserved the stack space if needed (cf. amd64/proc.ml) */ jmp *%rax CFI_ENDPROC +ENDFUNCTION(G(caml_c_call)) /* Start the OCaml program */ @@ -570,6 +583,7 @@ LBL(108): orq $2, %rax jmp LBL(109) CFI_ENDPROC +ENDFUNCTION(G(caml_start_program)) /* Raise an exception from OCaml */ @@ -601,6 +615,7 @@ LBL(110): popq %r14 ret CFI_ENDPROC +ENDFUNCTION(G(caml_raise_exn)) /* Raise an exception from C */ @@ -633,6 +648,7 @@ LBL(112): LOAD_VAR(caml_young_ptr,%r15) /* Reload alloc ptr */ ret CFI_ENDPROC +ENDFUNCTION(G(caml_raise_exception)) /* Raise a Stack_overflow exception on return from segv_handler() (in runtime/signals_nat.c). On entry, the stack is full, so we @@ -645,6 +661,7 @@ FUNCTION(G(caml_stack_overflow)) movq %r14, %rsp /* cut the stack */ popq %r14 /* recover previous exn handler */ ret /* jump to handler's code */ +ENDFUNCTION(G(caml_stack_overflow)) /* Callback from C to OCaml */ @@ -658,6 +675,7 @@ CFI_STARTPROC movq 0(%rbx), %r12 /* code pointer */ jmp LBL(caml_start_program) CFI_ENDPROC +ENDFUNCTION(G(caml_callback_exn)) FUNCTION(G(caml_callback2_exn)) CFI_STARTPROC @@ -670,6 +688,7 @@ CFI_STARTPROC LEA_VAR(caml_apply2, %r12) /* code pointer */ jmp LBL(caml_start_program) CFI_ENDPROC +ENDFUNCTION(G(caml_callback2_exn)) FUNCTION(G(caml_callback3_exn)) CFI_STARTPROC @@ -683,12 +702,14 @@ CFI_STARTPROC LEA_VAR(caml_apply3, %r12) /* code pointer */ jmp LBL(caml_start_program) CFI_ENDPROC +ENDFUNCTION(G(caml_callback3_exn)) FUNCTION(G(caml_ml_array_bound_error)) CFI_STARTPROC LEA_VAR(caml_array_bound_error, %rax) jmp LBL(caml_c_call) CFI_ENDPROC +ENDFUNCTION(G(caml_ml_array_bound_error)) .globl G(caml_system__code_end) G(caml_system__code_end): diff --git a/runtime/arm.S b/runtime/arm.S index 12bc4a1b..fd43b214 100644 --- a/runtime/arm.S +++ b/runtime/arm.S @@ -99,18 +99,6 @@ alloc_limit .req r11 #define CFI_OFFSET(r,n) #endif -/* Support for profiling with gprof */ - -#if defined(PROFILING) && (defined(SYS_linux_eabihf) \ - || defined(SYS_linux_eabi) \ - || defined(SYS_netbsd)) -#define PROFILE \ - push {lr}; CFI_ADJUST(4); \ - bl __gnu_mcount_nc; CFI_ADJUST(-4) -#else -#define PROFILE -#endif - /* Allocation functions and GC interface */ .globl caml_system__code_begin @@ -120,7 +108,6 @@ caml_system__code_begin: .globl caml_call_gc caml_call_gc: CFI_STARTPROC - PROFILE /* Record return address */ ldr r12, =caml_last_return_address str lr, [r12] @@ -171,7 +158,6 @@ caml_call_gc: .globl caml_alloc1 caml_alloc1: CFI_STARTPROC - PROFILE .Lcaml_alloc1: sub alloc_ptr, alloc_ptr, 8 cmp alloc_ptr, alloc_limit @@ -194,7 +180,6 @@ caml_alloc1: .globl caml_alloc2 caml_alloc2: CFI_STARTPROC - PROFILE .Lcaml_alloc2: sub alloc_ptr, alloc_ptr, 12 cmp alloc_ptr, alloc_limit @@ -218,7 +203,6 @@ caml_alloc2: .type caml_alloc3, %function caml_alloc3: CFI_STARTPROC - PROFILE .Lcaml_alloc3: sub alloc_ptr, alloc_ptr, 16 cmp alloc_ptr, alloc_limit @@ -241,7 +225,6 @@ caml_alloc3: .globl caml_allocN caml_allocN: CFI_STARTPROC - PROFILE .Lcaml_allocN: sub alloc_ptr, alloc_ptr, r7 cmp alloc_ptr, alloc_limit @@ -268,7 +251,6 @@ caml_allocN: .globl caml_c_call caml_c_call: CFI_STARTPROC - PROFILE /* Record lowest stack address and return address */ ldr r5, =caml_last_return_address ldr r6, =caml_bottom_of_stack @@ -300,7 +282,6 @@ caml_c_call: .globl caml_start_program caml_start_program: CFI_STARTPROC - PROFILE ldr r12, =caml_program /* Code shared with caml_callback* */ @@ -401,7 +382,6 @@ caml_start_program: .globl caml_raise_exn caml_raise_exn: CFI_STARTPROC - PROFILE /* Test if backtrace is active */ ldr r1, =caml_backtrace_active ldr r1, [r1] @@ -429,7 +409,6 @@ caml_raise_exn: .globl caml_raise_exception caml_raise_exception: CFI_STARTPROC - PROFILE /* Reload trap ptr, alloc ptr and alloc limit */ ldr trap_ptr, =caml_exception_pointer ldr alloc_ptr, =caml_young_ptr @@ -465,7 +444,6 @@ caml_raise_exception: .globl caml_callback_exn caml_callback_exn: CFI_STARTPROC - PROFILE /* Initial shuffling of arguments (r0 = closure, r1 = first arg) */ mov r12, r0 mov r0, r1 /* r0 = first arg */ @@ -480,7 +458,6 @@ caml_callback_exn: .globl caml_callback2_exn caml_callback2_exn: CFI_STARTPROC - PROFILE /* Initial shuffling of arguments (r0 = closure, r1 = arg1, r2 = arg2) */ mov r12, r0 mov r0, r1 /* r0 = first arg */ @@ -496,7 +473,6 @@ caml_callback2_exn: .globl caml_callback3_exn caml_callback3_exn: CFI_STARTPROC - PROFILE /* Initial shuffling of arguments */ /* (r0 = closure, r1 = arg1, r2 = arg2, r3 = arg3) */ mov r12, r0 @@ -514,7 +490,6 @@ caml_callback3_exn: .globl caml_ml_array_bound_error caml_ml_array_bound_error: CFI_STARTPROC - PROFILE /* Load address of [caml_array_bound_error] in r7 */ ldr r7, =caml_array_bound_error /* Call that function */ diff --git a/runtime/arm64.S b/runtime/arm64.S index bb8e1b5e..f7857263 100644 --- a/runtime/arm64.S +++ b/runtime/arm64.S @@ -43,10 +43,6 @@ #define CFI_OFFSET(r,n) #endif -/* Support for profiling with gprof */ - -#define PROFILE - /* Macros to load and store global variables. Destroy TMP2 */ #if defined(__PIC__) @@ -96,7 +92,6 @@ caml_system__code_begin: .globl caml_call_gc caml_call_gc: CFI_STARTPROC - PROFILE /* Record return address */ STOREGLOBAL(x30, caml_last_return_address) /* Record lowest stack address */ @@ -186,7 +181,6 @@ caml_call_gc: .globl caml_alloc1 caml_alloc1: CFI_STARTPROC - PROFILE 1: sub ALLOC_PTR, ALLOC_PTR, #16 cmp ALLOC_PTR, ALLOC_LIMIT b.lo 2f @@ -219,7 +213,6 @@ caml_alloc1: .globl caml_alloc2 caml_alloc2: CFI_STARTPROC - PROFILE 1: sub ALLOC_PTR, ALLOC_PTR, #24 cmp ALLOC_PTR, ALLOC_LIMIT b.lo 2f @@ -248,7 +241,6 @@ caml_alloc2: .globl caml_alloc3 caml_alloc3: CFI_STARTPROC - PROFILE 1: sub ALLOC_PTR, ALLOC_PTR, #32 cmp ALLOC_PTR, ALLOC_LIMIT b.lo 2f @@ -277,7 +269,6 @@ caml_alloc3: .globl caml_allocN caml_allocN: CFI_STARTPROC - PROFILE 1: sub ALLOC_PTR, ALLOC_PTR, ARG cmp ALLOC_PTR, ALLOC_LIMIT b.lo 2f @@ -309,7 +300,6 @@ caml_allocN: .globl caml_c_call caml_c_call: CFI_STARTPROC - PROFILE /* Preserve return address in callee-save register x19 */ mov x19, x30 CFI_REGISTER(30, 19) @@ -337,7 +327,6 @@ caml_c_call: .globl caml_start_program caml_start_program: CFI_STARTPROC - PROFILE ADDRGLOBAL(ARG, caml_program) /* Code shared with caml_callback* */ @@ -434,7 +423,6 @@ caml_start_program: .globl caml_raise_exn caml_raise_exn: CFI_STARTPROC - PROFILE /* Test if backtrace is active */ LOADGLOBAL32(TMP, caml_backtrace_active) cbnz TMP, 2f @@ -465,7 +453,6 @@ caml_raise_exn: .globl caml_raise_exception caml_raise_exception: CFI_STARTPROC - PROFILE /* Reload trap ptr, alloc ptr and alloc limit */ LOADGLOBAL(TRAP_PTR, caml_exception_pointer) LOADGLOBAL(ALLOC_PTR, caml_young_ptr) @@ -500,7 +487,6 @@ caml_raise_exception: .globl caml_callback_exn caml_callback_exn: CFI_STARTPROC - PROFILE /* Initial shuffling of arguments (x0 = closure, x1 = first arg) */ mov TMP, x0 mov x0, x1 /* x0 = first arg */ @@ -515,7 +501,6 @@ caml_callback_exn: .globl caml_callback2_exn caml_callback2_exn: CFI_STARTPROC - PROFILE /* Initial shuffling of arguments (x0 = closure, x1 = arg1, x2 = arg2) */ mov TMP, x0 mov x0, x1 /* x0 = first arg */ @@ -531,7 +516,6 @@ caml_callback2_exn: .globl caml_callback3_exn caml_callback3_exn: CFI_STARTPROC - PROFILE /* Initial shuffling of arguments */ /* (x0 = closure, x1 = arg1, x2 = arg2, x3 = arg3) */ mov TMP, x0 @@ -549,7 +533,6 @@ caml_callback3_exn: .globl caml_ml_array_bound_error caml_ml_array_bound_error: CFI_STARTPROC - PROFILE /* Load address of [caml_array_bound_error] in ARG */ ADDRGLOBAL(ARG, caml_array_bound_error) /* Call that function */ diff --git a/runtime/backtrace_byt.c b/runtime/backtrace_byt.c index 8ea94eed..b913dacd 100644 --- a/runtime/backtrace_byt.c +++ b/runtime/backtrace_byt.c @@ -241,7 +241,7 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise) return; if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; - /* testing the code region is needed: PR#1554 */ + /* testing the code region is needed: PR#8026 */ if (find_debug_info(pc) != NULL) caml_backtrace_buffer[caml_backtrace_pos++] = pc; diff --git a/runtime/callback.c b/runtime/callback.c index 9c479b30..03a89b30 100644 --- a/runtime/callback.c +++ b/runtime/callback.c @@ -100,7 +100,7 @@ CAMLexport value caml_callbackN_exn(value closure, int narg, value args[]) res = caml_interprete(local_callback_code, sizeof(local_callback_code)); caml_release_bytecode(local_callback_code, sizeof(local_callback_code)); #endif /*LOCAL_CALLBACK_BYTECODE*/ - if (Is_exception_result(res)) caml_extern_sp += narg + 4; /* PR#1228 */ + if (Is_exception_result(res)) caml_extern_sp += narg + 4; /* PR#3419 */ return res; } @@ -225,7 +225,7 @@ CAMLprim value caml_register_named_value(value vname, value val) for (nv = named_value_table[h]; nv != NULL; nv = nv->next) { if (strcmp(name, nv->name) == 0) { - nv->val = val; + caml_modify_generational_global_root(&nv->val, val); return Val_unit; } } @@ -235,11 +235,11 @@ CAMLprim value caml_register_named_value(value vname, value val) nv->val = val; nv->next = named_value_table[h]; named_value_table[h] = nv; - caml_register_global_root(&nv->val); + caml_register_generational_global_root(&nv->val); return Val_unit; } -CAMLexport value * caml_named_value(char const *name) +CAMLexport const value * caml_named_value(char const *name) { struct named_value * nv; for (nv = named_value_table[hash_value_name(name)]; diff --git a/runtime/caml/callback.h b/runtime/caml/callback.h index 93208b7a..82fab82e 100644 --- a/runtime/caml/callback.h +++ b/runtime/caml/callback.h @@ -43,8 +43,8 @@ CAMLextern value caml_callbackN_exn (value closure, int narg, value args[]); #define Is_exception_result(v) (((v) & 3) == 2) #define Extract_exception(v) ((v) & ~3) -CAMLextern value * caml_named_value (char const * name); -typedef void (*caml_named_action) (value*, char *); +CAMLextern const value * caml_named_value (char const * name); +typedef void (*caml_named_action) (const value*, char *); CAMLextern void caml_iterate_named_values(caml_named_action f); CAMLextern void caml_main (char_os ** argv); diff --git a/runtime/caml/config.h b/runtime/caml/config.h index 584d2682..4d5b99db 100644 --- a/runtime/caml/config.h +++ b/runtime/caml/config.h @@ -39,11 +39,6 @@ #include "s.h" -#if defined(_MSC_VER) && _MSC_VER < 1300 -#define LACKS_SANE_NAN -#define LACKS_VSCPRINTF -#endif - #ifdef BOOTSTRAPPING_FLEXLINK #undef SUPPORT_DYNAMIC_LINKING #endif diff --git a/runtime/caml/custom.h b/runtime/caml/custom.h index 4e70edb1..56a9a604 100644 --- a/runtime/caml/custom.h +++ b/runtime/caml/custom.h @@ -28,7 +28,7 @@ struct custom_fixed_length { }; struct custom_operations { - char *identifier; + char const *identifier; void (*finalize)(value v); int (*compare)(value v1, value v2); intnat (*hash)(value v); diff --git a/runtime/caml/exec.h b/runtime/caml/exec.h index 07c5310d..9aa65371 100644 --- a/runtime/caml/exec.h +++ b/runtime/caml/exec.h @@ -60,7 +60,7 @@ struct exec_trailer { /* Magic number for this release */ -#define EXEC_MAGIC "Caml1999X025" +#define EXEC_MAGIC "Caml1999X026" #endif /* CAML_INTERNALS */ diff --git a/runtime/caml/int64_emul.h b/runtime/caml/int64_emul.h deleted file mode 100644 index c1cddcc0..00000000 --- a/runtime/caml/int64_emul.h +++ /dev/null @@ -1,293 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -/* Software emulation of 64-bit integer arithmetic, for C compilers - that do not support it. */ - -#ifndef CAML_INT64_EMUL_H -#define CAML_INT64_EMUL_H - -#ifdef CAML_INTERNALS - -#include - -#ifdef ARCH_BIG_ENDIAN -#define I64_literal(hi,lo) { hi, lo } -#else -#define I64_literal(hi,lo) { lo, hi } -#endif - -#define I64_split(x,hi,lo) (hi = (x).h, lo = (x).l) - -/* Unsigned comparison */ -static int I64_ucompare(uint64_t x, uint64_t y) -{ - if (x.h > y.h) return 1; - if (x.h < y.h) return -1; - if (x.l > y.l) return 1; - if (x.l < y.l) return -1; - return 0; -} - -#define I64_ult(x, y) (I64_ucompare(x, y) < 0) - -/* Signed comparison */ -static int I64_compare(int64_t x, int64_t y) -{ - if ((int32_t)x.h > (int32_t)y.h) return 1; - if ((int32_t)x.h < (int32_t)y.h) return -1; - if (x.l > y.l) return 1; - if (x.l < y.l) return -1; - return 0; -} - -/* Negation */ -static int64_t I64_neg(int64_t x) -{ - int64_t res; - res.l = -x.l; - res.h = ~x.h; - if (res.l == 0) res.h++; - return res; -} - -/* Addition */ -static int64_t I64_add(int64_t x, int64_t y) -{ - int64_t res; - res.l = x.l + y.l; - res.h = x.h + y.h; - if (res.l < x.l) res.h++; - return res; -} - -/* Subtraction */ -static int64_t I64_sub(int64_t x, int64_t y) -{ - int64_t res; - res.l = x.l - y.l; - res.h = x.h - y.h; - if (x.l < y.l) res.h--; - return res; -} - -/* Multiplication */ -static int64_t I64_mul(int64_t x, int64_t y) -{ - int64_t res; - uint32_t prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF); - uint32_t prod10 = (x.l >> 16) * (y.l & 0xFFFF); - uint32_t prod01 = (x.l & 0xFFFF) * (y.l >> 16); - uint32_t prod11 = (x.l >> 16) * (y.l >> 16); - res.l = prod00; - res.h = prod11 + (prod01 >> 16) + (prod10 >> 16); - prod01 = prod01 << 16; res.l += prod01; if (res.l < prod01) res.h++; - prod10 = prod10 << 16; res.l += prod10; if (res.l < prod10) res.h++; - res.h += x.l * y.h + x.h * y.l; - return res; -} - -#define I64_is_zero(x) (((x).l | (x).h) == 0) -#define I64_is_negative(x) ((int32_t) (x).h < 0) -#define I64_is_min_int(x) ((x).l == 0 && (x).h == 0x80000000U) -#define I64_is_minus_one(x) (((x).l & (x).h) == 0xFFFFFFFFU) - -/* Bitwise operations */ -static int64_t I64_and(int64_t x, int64_t y) -{ - int64_t res; - res.l = x.l & y.l; - res.h = x.h & y.h; - return res; -} - -static int64_t I64_or(int64_t x, int64_t y) -{ - int64_t res; - res.l = x.l | y.l; - res.h = x.h | y.h; - return res; -} - -static int64_t I64_xor(int64_t x, int64_t y) -{ - int64_t res; - res.l = x.l ^ y.l; - res.h = x.h ^ y.h; - return res; -} - -/* Shifts */ -static int64_t I64_lsl(int64_t x, int s) -{ - int64_t res; - s = s & 63; - if (s == 0) return x; - if (s < 32) { - res.l = x.l << s; - res.h = (x.h << s) | (x.l >> (32 - s)); - } else { - res.l = 0; - res.h = x.l << (s - 32); - } - return res; -} - -static int64_t I64_lsr(int64_t x, int s) -{ - int64_t res; - s = s & 63; - if (s == 0) return x; - if (s < 32) { - res.l = (x.l >> s) | (x.h << (32 - s)); - res.h = x.h >> s; - } else { - res.l = x.h >> (s - 32); - res.h = 0; - } - return res; -} - -static int64_t I64_asr(int64_t x, int s) -{ - int64_t res; - s = s & 63; - if (s == 0) return x; - if (s < 32) { - res.l = (x.l >> s) | (x.h << (32 - s)); - res.h = (int32_t) x.h >> s; - } else { - res.l = (int32_t) x.h >> (s - 32); - res.h = (int32_t) x.h >> 31; - } - return res; -} - -/* Division and modulus */ - -#define I64_SHL1(x) x.h = (x.h << 1) | (x.l >> 31); x.l <<= 1 -#define I64_SHR1(x) x.l = (x.l >> 1) | (x.h << 31); x.h >>= 1 - -static void I64_udivmod(uint64_t modulus, uint64_t divisor, - uint64_t * quo, uint64_t * mod) -{ - int64_t quotient, mask; - int cmp; - - quotient.h = 0; quotient.l = 0; - mask.h = 0; mask.l = 1; - while ((int32_t) divisor.h >= 0) { - cmp = I64_ucompare(divisor, modulus); - I64_SHL1(divisor); - I64_SHL1(mask); - if (cmp >= 0) break; - } - while (mask.l | mask.h) { - if (I64_ucompare(modulus, divisor) >= 0) { - quotient.h |= mask.h; quotient.l |= mask.l; - modulus = I64_sub(modulus, divisor); - } - I64_SHR1(mask); - I64_SHR1(divisor); - } - *quo = quotient; - *mod = modulus; -} - -static int64_t I64_div(int64_t x, int64_t y) -{ - int64_t q, r; - int32_t sign; - - sign = x.h ^ y.h; - if ((int32_t) x.h < 0) x = I64_neg(x); - if ((int32_t) y.h < 0) y = I64_neg(y); - I64_udivmod(x, y, &q, &r); - if (sign < 0) q = I64_neg(q); - return q; -} - -static int64_t I64_mod(int64_t x, int64_t y) -{ - int64_t q, r; - int32_t sign; - - sign = x.h; - if ((int32_t) x.h < 0) x = I64_neg(x); - if ((int32_t) y.h < 0) y = I64_neg(y); - I64_udivmod(x, y, &q, &r); - if (sign < 0) r = I64_neg(r); - return r; -} - -/* Coercions */ - -static int64_t I64_of_int32(int32_t x) -{ - int64_t res; - res.l = x; - res.h = x >> 31; - return res; -} - -#define I64_to_int32(x) ((int32_t) (x).l) - -/* Note: we assume sizeof(intnat) = 4 here, which is true otherwise - autoconfiguration would have selected native 64-bit integers */ -#define I64_of_intnat I64_of_int32 -#define I64_to_intnat I64_to_int32 - -static double I64_to_double(int64_t x) -{ - double res; - int32_t sign = x.h; - if (sign < 0) x = I64_neg(x); - res = ldexp((double) x.h, 32) + x.l; - if (sign < 0) res = -res; - return res; -} - -static int64_t I64_of_double(double f) -{ - int64_t res; - double frac, integ; - int neg; - - neg = (f < 0); - f = fabs(f); - frac = modf(ldexp(f, -32), &integ); - res.h = (uint32_t) integ; - res.l = (uint32_t) ldexp(frac, 32); - if (neg) res = I64_neg(res); - return res; -} - -static int64_t I64_bswap(int64_t x) -{ - int64_t res; - res.h = (((x.l & 0x000000FF) << 24) | - ((x.l & 0x0000FF00) << 8) | - ((x.l & 0x00FF0000) >> 8) | - ((x.l & 0xFF000000) >> 24)); - res.l = (((x.h & 0x000000FF) << 24) | - ((x.h & 0x0000FF00) << 8) | - ((x.h & 0x00FF0000) >> 8) | - ((x.h & 0xFF000000) >> 24)); - return res; -} - -#endif /* CAML_INTERNALS */ - -#endif /* CAML_INT64_EMUL_H */ diff --git a/runtime/caml/int64_format.h b/runtime/caml/int64_format.h deleted file mode 100644 index 40250ed9..00000000 --- a/runtime/caml/int64_format.h +++ /dev/null @@ -1,111 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -/* printf-like formatting of 64-bit integers, in case the C library - printf() function does not support them. */ - -#ifndef CAML_INT64_FORMAT_H -#define CAML_INT64_FORMAT_H - -#ifdef CAML_INTERNALS - -static void I64_format(char * buffer, char * fmt, int64_t x) -{ - static char conv_lower[] = "0123456789abcdef"; - static char conv_upper[] = "0123456789ABCDEF"; - char rawbuffer[24]; - char justify, signstyle, filler, alternate, signedconv; - int base, width, sign, i, rawlen; - char * cvtbl; - char * p, * r; - int64_t wbase, digit; - - /* Parsing of format */ - justify = '+'; - signstyle = '-'; - filler = ' '; - alternate = 0; - base = 0; - signedconv = 0; - width = 0; - cvtbl = conv_lower; - for (p = fmt; *p != 0; p++) { - switch (*p) { - case '-': - justify = '-'; break; - case '+': case ' ': - signstyle = *p; break; - case '0': - filler = '0'; break; - case '#': - alternate = 1; break; - case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': - width = atoi(p); - while (p[1] >= '0' && p[1] <= '9') p++; - break; - case 'd': case 'i': - signedconv = 1; /* fallthrough */ - case 'u': - base = 10; break; - case 'x': - base = 16; break; - case 'X': - base = 16; cvtbl = conv_upper; break; - case 'o': - base = 8; break; - } - } - if (base == 0) { buffer[0] = 0; return; } - /* Do the conversion */ - sign = 1; - if (signedconv && I64_is_negative(x)) { sign = -1; x = I64_neg(x); } - r = rawbuffer + sizeof(rawbuffer); - wbase = I64_of_int32(base); - do { - I64_udivmod(x, wbase, &x, &digit); - *--r = cvtbl[I64_to_int32(digit)]; - } while (! I64_is_zero(x)); - rawlen = rawbuffer + sizeof(rawbuffer) - r; - /* Adjust rawlen to reflect additional chars (sign, etc) */ - if (signedconv && (sign < 0 || signstyle != '-')) rawlen++; - if (alternate) { - if (base == 8) rawlen += 1; - if (base == 16) rawlen += 2; - } - /* Do the formatting */ - p = buffer; - if (justify == '+' && filler == ' ') { - for (i = rawlen; i < width; i++) *p++ = ' '; - } - if (signedconv) { - if (sign < 0) *p++ = '-'; - else if (signstyle != '-') *p++ = signstyle; - } - if (alternate && base == 8) *p++ = '0'; - if (alternate && base == 16) { *p++ = '0'; *p++ = 'x'; } - if (justify == '+' && filler == '0') { - for (i = rawlen; i < width; i++) *p++ = '0'; - } - while (r < rawbuffer + sizeof(rawbuffer)) *p++ = *r++; - if (justify == '-') { - for (i = rawlen; i < width; i++) *p++ = ' '; - } - *p = 0; -} - -#endif /* CAML_INTERNALS */ - -#endif /* CAML_INT64_FORMAT_H */ diff --git a/runtime/caml/int64_native.h b/runtime/caml/int64_native.h deleted file mode 100644 index 7df66511..00000000 --- a/runtime/caml/int64_native.h +++ /dev/null @@ -1,67 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -/* Wrapper macros around native 64-bit integer arithmetic, - so that it has the same interface as the software emulation - provided in int64_emul.h */ - -#ifndef CAML_INT64_NATIVE_H -#define CAML_INT64_NATIVE_H - -#ifdef CAML_INTERNALS - -#define I64_literal(hi,lo) ((int64_t)(hi) << 32 | (lo)) -#define I64_split(x,hi,lo) (hi = (uint32_t)((x)>>32), lo = (uint32_t)(x)) -#define I64_compare(x,y) (((x) > (y)) - ((x) < (y))) -#define I64_ult(x,y) ((uint64_t)(x) < (uint64_t)(y)) -#define I64_neg(x) (-(x)) -#define I64_add(x,y) ((x) + (y)) -#define I64_sub(x,y) ((x) - (y)) -#define I64_mul(x,y) ((x) * (y)) -#define I64_is_zero(x) ((x) == 0) -#define I64_is_negative(x) ((x) < 0) -#define I64_is_min_int(x) ((x) == ((int64_t)1 << 63)) -#define I64_is_minus_one(x) ((x) == -1) - -#define I64_div(x,y) ((x) / (y)) -#define I64_mod(x,y) ((x) % (y)) -#define I64_udivmod(x,y,quo,rem) \ - (*(rem) = (uint64_t)(x) % (uint64_t)(y), \ - *(quo) = (uint64_t)(x) / (uint64_t)(y)) -#define I64_and(x,y) ((x) & (y)) -#define I64_or(x,y) ((x) | (y)) -#define I64_xor(x,y) ((x) ^ (y)) -#define I64_lsl(x,y) ((x) << (y)) -#define I64_asr(x,y) ((x) >> (y)) -#define I64_lsr(x,y) ((uint64_t)(x) >> (y)) -#define I64_to_intnat(x) ((intnat) (x)) -#define I64_of_intnat(x) ((intnat) (x)) -#define I64_to_int32(x) ((int32_t) (x)) -#define I64_of_int32(x) ((int64_t) (x)) -#define I64_to_double(x) ((double)(x)) -#define I64_of_double(x) ((int64_t)(x)) - -#define I64_bswap(x) ((((x) & 0x00000000000000FFULL) << 56) | \ - (((x) & 0x000000000000FF00ULL) << 40) | \ - (((x) & 0x0000000000FF0000ULL) << 24) | \ - (((x) & 0x00000000FF000000ULL) << 8) | \ - (((x) & 0x000000FF00000000ULL) >> 8) | \ - (((x) & 0x0000FF0000000000ULL) >> 24) | \ - (((x) & 0x00FF000000000000ULL) >> 40) | \ - (((x) & 0xFF00000000000000ULL) >> 56)) - -#endif /* CAML_INTERNALS */ - -#endif /* CAML_INT64_NATIVE_H */ diff --git a/runtime/caml/misc.h b/runtime/caml/misc.h index 6aa98516..4466d292 100644 --- a/runtime/caml/misc.h +++ b/runtime/caml/misc.h @@ -183,7 +183,9 @@ extern int caml_umul_overflow(uintnat a, uintnat b, uintnat * res); #ifdef _WIN32 -#define _T(x) L ## x +#ifdef CAML_INTERNALS +#define T(x) L ## x +#endif #define access_os _waccess #define open_os _wopen @@ -213,7 +215,9 @@ extern int caml_umul_overflow(uintnat a, uintnat b, uintnat * res); #else /* _WIN32 */ -#define _T(x) x +#ifdef CAML_INTERNALS +#define T(x) x +#endif #define access_os access #define open_os open diff --git a/runtime/caml/s.h.in b/runtime/caml/s.h.in index 70bd891f..2e7db516 100644 --- a/runtime/caml/s.h.in +++ b/runtime/caml/s.h.in @@ -37,10 +37,6 @@ undefined if signal handlers have the System V semantics: the signal resets the behavior to default. */ -#undef HAS_SIGSETMASK - -/* Define HAS_SIGSETMASK if you have sigsetmask(), as in BSD. */ - #undef SUPPORT_DYNAMIC_LINKING /* Define SUPPORT_DYNAMIC_LINKING if dynamic loading of C stub code @@ -110,21 +106,12 @@ /* Define HAS_GETCWD if the library provides the getcwd() function. */ -#undef HAS_GETPRIORITY - -/* Define HAS_GETPRIORITY if the library provides getpriority() and - setpriority(). Otherwise, we'll use nice(). */ - #undef HAS_UTIME #undef HAS_UTIMES /* Define HAS_UTIME if you have /usr/include/utime.h and the library provides utime(). Define HAS_UTIMES if the library provides utimes(). */ -#undef HAS_DUP2 - -/* Define HAS_DUP2 if you have dup2(). */ - #undef HAS_FCHMOD /* Define HAS_FCHMOD if you have fchmod() and fchown(). */ @@ -173,12 +160,6 @@ /* Define HAS_TERMIOS if you have /usr/include/termios.h and it is Posix-compliant. */ -#undef HAS_ASYNC_IO - -/* Define HAS_ASYNC_IO if BSD-style asynchronous I/O are supported - (the process can request to be sent a SIGIO signal when a descriptor - is ready for reading). */ - #undef HAS_SETITIMER /* Define HAS_SETITIMER if you have setitimer(). */ diff --git a/runtime/compare.c b/runtime/compare.c index 5de2e0e8..fd7ed763 100644 --- a/runtime/compare.c +++ b/runtime/compare.c @@ -23,10 +23,6 @@ #include "caml/misc.h" #include "caml/mlvalues.h" -#if defined(LACKS_SANE_NAN) && !defined(isnan) -#define isnan _isnan -#endif - /* Structural comparison on trees. */ struct compare_item { value * v1, * v2; mlsize_t count; }; @@ -208,19 +204,8 @@ static intnat do_compare_val(struct compare_stack* stk, case Double_tag: { double d1 = Double_val(v1); double d2 = Double_val(v2); -#ifdef LACKS_SANE_NAN - if (isnan(d2)) { - if (! total) return UNORDERED; - if (isnan(d1)) break; - return GREATER; - } else if (isnan(d1)) { - if (! total) return UNORDERED; - return LESS; - } -#endif if (d1 < d2) return LESS; if (d1 > d2) return GREATER; -#ifndef LACKS_SANE_NAN if (d1 != d2) { if (! total) return UNORDERED; /* One or both of d1 and d2 is NaN. Order according to the @@ -229,7 +214,6 @@ static intnat do_compare_val(struct compare_stack* stk, if (d2 == d2) return LESS; /* d2 is not NaN, d1 is NaN */ /* d1 and d2 are both NaN, thus equal: continue comparison */ } -#endif break; } case Double_array_tag: { @@ -240,26 +224,14 @@ static intnat do_compare_val(struct compare_stack* stk, for (i = 0; i < sz1; i++) { double d1 = Double_flat_field(v1, i); double d2 = Double_flat_field(v2, i); - #ifdef LACKS_SANE_NAN - if (isnan(d2)) { - if (! total) return UNORDERED; - if (isnan(d1)) break; - return GREATER; - } else if (isnan(d1)) { - if (! total) return UNORDERED; - return LESS; - } - #endif if (d1 < d2) return LESS; if (d1 > d2) return GREATER; - #ifndef LACKS_SANE_NAN if (d1 != d2) { if (! total) return UNORDERED; /* See comment for Double_tag case */ if (d1 == d1) return GREATER; if (d2 == d2) return LESS; } - #endif } break; } diff --git a/runtime/debugger.c b/runtime/debugger.c index a7c20278..f77cf1eb 100644 --- a/runtime/debugger.c +++ b/runtime/debugger.c @@ -180,7 +180,7 @@ void caml_debugger_init(void) Store_field(marshal_flags, 0, Val_int(1)); /* Marshal.Closures */ Store_field(marshal_flags, 1, Val_emptylist); - a = caml_secure_getenv(_T("CAML_DEBUG_SOCKET")); + a = caml_secure_getenv(T("CAML_DEBUG_SOCKET")); address = a ? caml_stat_strdup_of_os(a) : NULL; if (address == NULL) return; if (dbg_addr != NULL) caml_stat_free(dbg_addr); diff --git a/runtime/dynlink.c b/runtime/dynlink.c index cf728b0e..2d61f53c 100644 --- a/runtime/dynlink.c +++ b/runtime/dynlink.c @@ -73,7 +73,7 @@ static c_primitive lookup_primitive(char * name) /* Parse the OCAML_STDLIB_DIR/ld.conf file and add the directories listed there to the search path */ -#define LD_CONF_NAME _T("ld.conf") +#define LD_CONF_NAME T("ld.conf") static char_os * parse_ld_conf(void) { @@ -86,10 +86,10 @@ static char_os * parse_ld_conf(void) #endif int ldconf, nread; - stdlib = caml_secure_getenv(_T("OCAMLLIB")); - if (stdlib == NULL) stdlib = caml_secure_getenv(_T("CAMLLIB")); + stdlib = caml_secure_getenv(T("OCAMLLIB")); + if (stdlib == NULL) stdlib = caml_secure_getenv(T("CAMLLIB")); if (stdlib == NULL) stdlib = OCAML_STDLIB_DIR; - ldconfname = caml_stat_strconcat_os(3, stdlib, _T("/"), LD_CONF_NAME); + ldconfname = caml_stat_strconcat_os(3, stdlib, T("/"), LD_CONF_NAME); if (stat_os(ldconfname, &st) == -1) { caml_stat_free(ldconfname); return NULL; @@ -109,7 +109,7 @@ static char_os * parse_ld_conf(void) caml_stat_free(config); q = wconfig; for (p = wconfig; *p != 0; p++) { - if (*p == _T('\n')) { + if (*p == '\n') { *p = 0; caml_ext_table_add(&caml_shared_libs_path, q); q = p + 1; @@ -165,7 +165,7 @@ void caml_build_primitive_table(char_os * lib_path, - directories specified in the executable - directories specified in the file /ld.conf */ tofree1 = caml_decompose_path(&caml_shared_libs_path, - caml_secure_getenv(_T("CAML_LD_LIBRARY_PATH"))); + caml_secure_getenv(T("CAML_LD_LIBRARY_PATH"))); if (lib_path != NULL) for (p = lib_path; *p != 0; p += strlen_os(p) + 1) caml_ext_table_add(&caml_shared_libs_path, p); diff --git a/runtime/extern.c b/runtime/extern.c index 248b61a6..ac434210 100644 --- a/runtime/extern.c +++ b/runtime/extern.c @@ -537,7 +537,7 @@ static void extern_rec(value v) case Custom_tag: { uintnat sz_32, sz_64; char * size_header; - char * ident = Custom_ops_val(v)->identifier; + char const * ident = Custom_ops_val(v)->identifier; void (*serialize)(value v, uintnat * bsize_32, uintnat * bsize_64) = Custom_ops_val(v)->serialize; @@ -734,7 +734,7 @@ CAMLprim value caml_output_value_to_bytes(value v, value flags) memcpy(&Byte(res, ofs), header, header_len); ofs += header_len; while (blk != NULL) { - int n = blk->end - blk->data; + intnat n = blk->end - blk->data; memcpy(&Byte(res, ofs), blk->data, n); ofs += n; nextblk = blk->next; @@ -800,7 +800,7 @@ CAMLexport void caml_output_value_to_malloc(value v, value flags, memcpy(res, header, header_len); res += header_len; for (blk = extern_output_first; blk != NULL; blk = blk->next) { - int n = blk->end - blk->data; + intnat n = blk->end - blk->data; memcpy(res, blk->data, n); res += n; } diff --git a/runtime/fail_nat.c b/runtime/fail_nat.c index ec5bfebc..e1f687d3 100644 --- a/runtime/fail_nat.c +++ b/runtime/fail_nat.c @@ -169,7 +169,7 @@ void caml_raise_sys_blocked_io(void) do a GC before the exception is raised (lack of stack descriptors for the ccall to [caml_array_bound_error]). */ -static value * caml_array_bound_error_exn = NULL; +static const value * caml_array_bound_error_exn = NULL; void caml_array_bound_error(void) { diff --git a/runtime/floats.c b/runtime/floats.c index 33bf14e8..aba01a99 100644 --- a/runtime/floats.c +++ b/runtime/floats.c @@ -281,7 +281,7 @@ CAMLprim value caml_hexstring_of_float(value arg, value vprec, value vstyle) return res; } -static int caml_float_of_hex(const char * s, double * res) +static int caml_float_of_hex(const char * s, const char * end, double * res) { int64_t m = 0; /* the mantissa - top 60 bits at most */ int n_bits = 0; /* total number of bits read */ @@ -293,11 +293,9 @@ static int caml_float_of_hex(const char * s, double * res) char * p; /* for converting the exponent */ double f; - while (*s != 0) { + while (s < end) { char c = *s++; switch (c) { - case '_': - break; case '.': if (dec_point >= 0) return -1; /* multiple decimal points */ dec_point = n_bits; @@ -306,7 +304,7 @@ static int caml_float_of_hex(const char * s, double * res) long e; if (*s == 0) return -1; /* nothing after exponent mark */ e = strtol(s, &p, 10); - if (*p != 0) return -1; /* ill-formed exponent */ + if (p != end) return -1; /* ill-formed exponent */ /* Handle exponents larger than int by returning 0/infinity directly. Mind that INT_MIN/INT_MAX are included in the test so as to capture the overflow case of strtol on Win64 -- long and int have the same @@ -381,17 +379,7 @@ CAMLprim value caml_float_of_string(value vs) int sign; double d; - /* Check for hexadecimal FP constant */ - src = String_val(vs); - sign = 1; - if (*src == '-') { sign = -1; src++; } - else if (*src == '+') { src++; }; - if (src[0] == '0' && (src[1] == 'x' || src[1] == 'X')) { - if (caml_float_of_hex(src + 2, &d) == -1) - caml_failwith("float_of_string"); - return caml_copy_double(sign < 0 ? -d : d); - } - /* Remove '_' characters before calling strtod () */ + /* Remove '_' characters before conversion */ len = caml_string_length(vs); buf = len < sizeof(parse_buffer) ? parse_buffer : caml_stat_alloc(len + 1); src = String_val(vs); @@ -402,15 +390,26 @@ CAMLprim value caml_float_of_string(value vs) } *dst = 0; if (dst == buf) goto error; + /* Check for hexadecimal FP constant */ + src = buf; + sign = 1; + if (*src == '-') { sign = -1; src++; } + else if (*src == '+') { src++; }; + if (src[0] == '0' && (src[1] == 'x' || src[1] == 'X')) { + /* Convert using our hexadecimal FP parser */ + if (caml_float_of_hex(src + 2, dst, &d) == -1) goto error; + if (sign < 0) d = -d; + } else { + /* Convert using strtod */ #if defined(HAS_STRTOD_L) && defined(HAS_LOCALE) - d = strtod_l((const char *) buf, &end, caml_locale); + d = strtod_l((const char *) buf, &end, caml_locale); #else - USE_LOCALE; - /* Convert using strtod */ - d = strtod((const char *) buf, &end); - RESTORE_LOCALE; + USE_LOCALE; + d = strtod((const char *) buf, &end); + RESTORE_LOCALE; #endif /* HAS_STRTOD_L */ - if (end != dst) goto error; + if (end != dst) goto error; + } if (buf != parse_buffer) caml_stat_free(buf); return caml_copy_double(d); error: @@ -966,33 +965,6 @@ CAMLprim value caml_signbit_float(value f) return caml_signbit(Double_val(f)); } -#ifdef LACKS_SANE_NAN - -CAMLprim value caml_neq_float(value vf, value vg) -{ - double f = Double_val(vf); - double g = Double_val(vg); - return Val_bool(isnan(f) || isnan(g) || f != g); -} - -#define DEFINE_NAN_CMP(op) (value vf, value vg) \ -{ \ - double f = Double_val(vf); \ - double g = Double_val(vg); \ - return Val_bool(!isnan(f) && !isnan(g) && f op g); \ -} - -intnat caml_float_compare_unboxed(double f, double g) -{ - /* Insane => nan == everything && nan < everything && nan > everything */ - if (isnan(f) && isnan(g)) return 0; - if (!isnan(g) && f < g) return -1; - if (f != g) return 1; - return 0; -} - -#else - CAMLprim value caml_neq_float(value f, value g) { return Val_bool(Double_val(f) != Double_val(g)); @@ -1008,12 +980,14 @@ intnat caml_float_compare_unboxed(double f, double g) /* If one or both of f and g is NaN, order according to the convention NaN = NaN and NaN < x for all other floats x. */ /* This branchless implementation is from GPR#164. - Note that [f == f] if and only if f is not NaN. */ - return (f > g) - (f < g) + (f == f) - (g == g); + Note that [f == f] if and only if f is not NaN. + We expand each subresult of the expression to + avoid sign-extension on 64bit. GPR#2250. */ + intnat res = + (intnat)(f > g) - (intnat)(f < g) + (intnat)(f == f) - (intnat)(g == g); + return res; } -#endif - CAMLprim value caml_eq_float DEFINE_NAN_CMP(==) CAMLprim value caml_le_float DEFINE_NAN_CMP(<=) CAMLprim value caml_lt_float DEFINE_NAN_CMP(<) diff --git a/runtime/globroots.c b/runtime/globroots.c index f689723c..54fc8b8f 100644 --- a/runtime/globroots.c +++ b/runtime/globroots.c @@ -183,6 +183,16 @@ struct global_root_list caml_global_roots_young = { NULL, { NULL, }, 0 }; struct global_root_list caml_global_roots_old = { NULL, { NULL, }, 0 }; /* generational roots pointing to major heap */ +/* The invariant of the generational roots is the following: + - If the global root contains a pointer to the minor heap, then the root is + in [caml_global_roots_young]; + - If the global root contains a pointer to the major heap, then the root is + in [caml_global_roots_old] or in [caml_global_roots_young]; + - Otherwise (the root contains a pointer outside of the heap or an integer), + then neither [caml_global_roots_young] nor [caml_global_roots_old] contain + it. + */ + /* Register a global C root of the mutable kind */ CAMLexport void caml_register_global_root(value *r) @@ -198,17 +208,34 @@ CAMLexport void caml_remove_global_root(value *r) caml_delete_global_root(&caml_global_roots, r); } +enum gc_root_class { + YOUNG, + OLD, + UNTRACKED +}; + +static enum gc_root_class classify_gc_root(value v) +{ + if(!Is_block(v)) return UNTRACKED; + if(Is_young(v)) return YOUNG; + if(Is_in_heap(v)) return OLD; + return UNTRACKED; +} + /* Register a global C root of the generational kind */ CAMLexport void caml_register_generational_global_root(value *r) { - value v = *r; CAMLassert (((intnat) r & 3) == 0); /* compact.c demands this (for now) */ - if (Is_block(v)) { - if (Is_young(v)) + + switch(classify_gc_root(*r)) { + case YOUNG: caml_insert_global_root(&caml_global_roots_young, r); - else if (Is_in_heap(v)) + break; + case OLD: caml_insert_global_root(&caml_global_roots_old, r); + break; + case UNTRACKED: break; } } @@ -216,12 +243,15 @@ CAMLexport void caml_register_generational_global_root(value *r) CAMLexport void caml_remove_generational_global_root(value *r) { - value v = *r; - if (Is_block(v)) { - if (Is_in_heap_or_young(v)) - caml_delete_global_root(&caml_global_roots_young, r); - if (Is_in_heap(v)) + switch(classify_gc_root(*r)) { + case OLD: caml_delete_global_root(&caml_global_roots_old, r); + /* Fallthrough: the root can be in the young list while actually + being in the major heap. */ + case YOUNG: + caml_delete_global_root(&caml_global_roots_young, r); + break; + case UNTRACKED: break; } } @@ -229,39 +259,31 @@ CAMLexport void caml_remove_generational_global_root(value *r) CAMLexport void caml_modify_generational_global_root(value *r, value newval) { - value oldval = *r; - - /* It is OK to have a root in roots_young that suddenly points to - the old generation -- the next minor GC will take care of that. - What needs corrective action is a root in roots_old that suddenly - points to the young generation. */ - if (Is_block(newval) && Is_young(newval) && - Is_block(oldval) && Is_in_heap(oldval)) { - caml_delete_global_root(&caml_global_roots_old, r); - caml_insert_global_root(&caml_global_roots_young, r); - } - /* PR#4704 */ - else if (!Is_block(oldval) && Is_block(newval)) { - /* The previous value in the root was unboxed but now it is boxed. - The root won't appear in any of the root lists thus far (by virtue - of the operation of [caml_register_generational_global_root]), so we - need to make sure it gets in, or else it will never be scanned. */ - if (Is_young(newval)) - caml_insert_global_root(&caml_global_roots_young, r); - else if (Is_in_heap(newval)) - caml_insert_global_root(&caml_global_roots_old, r); + enum gc_root_class c; + /* See PRs #4704, #607 and #8656 */ + switch(classify_gc_root(newval)) { + case YOUNG: + c = classify_gc_root(*r); + if(c == OLD) + caml_delete_global_root(&caml_global_roots_old, r); + if(c != YOUNG) + caml_insert_global_root(&caml_global_roots_young, r); + break; + + case OLD: + /* If the old class is YOUNG, then we do not need to do + anything: It is OK to have a root in roots_young that + suddenly points to the old generation -- the next minor GC + will take care of that. */ + if(classify_gc_root(*r) == UNTRACKED) + caml_insert_global_root(&caml_global_roots_old, r); + break; + + case UNTRACKED: + caml_remove_generational_global_root(r); + break; } - else if (Is_block(oldval) && !Is_block(newval)) { - /* The previous value in the root was boxed but now it is unboxed, so - the root should be removed. If [oldval] is young, this will happen - anyway at the next minor collection, but it is safer to delete it - here. */ - if (Is_in_heap_or_young(oldval)) - caml_delete_global_root(&caml_global_roots_young, r); - if (Is_in_heap(oldval)) - caml_delete_global_root(&caml_global_roots_old, r); - } - /* end PR#4704 */ + *r = newval; } diff --git a/runtime/i386.S b/runtime/i386.S index aa6a9137..a3f05877 100644 --- a/runtime/i386.S +++ b/runtime/i386.S @@ -49,6 +49,14 @@ .align FUNCTION_ALIGN; \ G(name): +#if defined(SYS_linux_elf) || defined(SYS_bsd_elf) || defined(SYS_gnu) +#define ENDFUNCTION(name) \ + .type name,@function; \ + .size name, . - name +#else +#define ENDFUNCTION(name) +#endif + #ifdef ASM_CFI_SUPPORTED #define CFI_STARTPROC .cfi_startproc #define CFI_ENDPROC .cfi_endproc @@ -59,62 +67,8 @@ #define CFI_ADJUST(n) #endif -#if defined(PROFILING) -#if defined(SYS_linux_elf) || defined(SYS_gnu) -#define PROFILE_CAML \ - pushl %ebp; CFI_ADJUST(4); \ - movl %esp, %ebp; \ - pushl %eax; CFI_ADJUST(4); \ - pushl %ecx; CFI_ADJUST(4); \ - pushl %edx; CFI_ADJUST(4); \ - call mcount; \ - popl %edx; CFI_ADJUST(-4); \ - popl %ecx; CFI_ADJUST(-4); \ - popl %eax; CFI_ADJUST(-4); \ - popl %ebp; CFI_ADJUST(-4) -#define PROFILE_C \ - pushl %ebp; CFI_ADJUST(4); \ - movl %esp, %ebp; \ - call mcount; \ - popl %ebp; CFI_ADJUST(-4) -#elif defined(SYS_bsd_elf) -#define PROFILE_CAML \ - pushl %ebp; CFI_ADJUST(4); \ - movl %esp, %ebp; \ - pushl %eax; CFI_ADJUST(4); \ - pushl %ecx; CFI_ADJUST(4); \ - pushl %edx; CFI_ADJUST(4); \ - call .mcount; \ - popl %edx; CFI_ADJUST(-4); \ - popl %ecx; CFI_ADJUST(-4); \ - popl %eax; CFI_ADJUST(-4); \ - popl %ebp; CFI_ADJUST(-4) -#define PROFILE_C \ - pushl %ebp; CFI_ADJUST(4); \ - movl %esp, %ebp; \ - call .mcount; \ - popl %ebp; CFI_ADJUST(-4) -#elif defined(SYS_macosx) -#define PROFILE_CAML \ - pushl %ebp; CFI_ADJUST(4); \ - movl %esp, %ebp; \ - pushl %eax; CFI_ADJUST(4); \ - pushl %ecx; CFI_ADJUST(4); \ - pushl %edx; CFI_ADJUST(4); \ - call Lmcount$stub; \ - popl %edx; CFI_ADJUST(-4); \ - popl %ecx; CFI_ADJUST(-4); \ - popl %eax; CFI_ADJUST(-4); \ - popl %ebp; CFI_ADJUST(-4) -#define PROFILE_C \ - pushl %ebp; CFI_ADJUST(4); \ - movl %esp, %ebp; \ - call Lmcount$stub; \ - popl %ebp; CFI_ADJUST(-4) -#endif -#else -#define PROFILE_CAML -#define PROFILE_C +#if !defined(SYS_mingw) && !defined(SYS_cygwin) +#define STACK_PROBE_SIZE 16384 #endif /* PR#6038: GCC and Clang seem to require 16-byte alignment nowadays, @@ -130,7 +84,6 @@ G(caml_system__code_begin): FUNCTION(caml_call_gc) CFI_STARTPROC - PROFILE_CAML /* Record lowest stack address and return address */ movl 0(%esp), %eax movl %eax, G(caml_last_return_address) @@ -140,9 +93,9 @@ LBL(105): #if !defined(SYS_mingw) && !defined(SYS_cygwin) /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ - subl $16384, %esp + subl $(STACK_PROBE_SIZE), %esp; CFI_ADJUST(STACK_PROBE_SIZE); movl %eax, 0(%esp) - addl $16384, %esp + addl $(STACK_PROBE_SIZE), %esp; CFI_ADJUST(-STACK_PROBE_SIZE); #endif /* Build array of registers, save it into caml_gc_regs */ pushl %ebp; CFI_ADJUST(4) @@ -167,10 +120,10 @@ LBL(105): /* Return to caller */ ret CFI_ENDPROC + ENDFUNCTION(caml_call_gc) FUNCTION(caml_alloc1) CFI_STARTPROC - PROFILE_CAML movl G(caml_young_ptr), %eax subl $8, %eax movl %eax, G(caml_young_ptr) @@ -187,10 +140,10 @@ LBL(100): UNDO_ALIGN_STACK(12) jmp G(caml_alloc1) CFI_ENDPROC + ENDFUNCTION(caml_alloc1) FUNCTION(caml_alloc2) CFI_STARTPROC - PROFILE_CAML movl G(caml_young_ptr), %eax subl $12, %eax movl %eax, G(caml_young_ptr) @@ -207,10 +160,10 @@ LBL(101): UNDO_ALIGN_STACK(12) jmp G(caml_alloc2) CFI_ENDPROC + ENDFUNCTION(caml_alloc2) FUNCTION(caml_alloc3) CFI_STARTPROC - PROFILE_CAML movl G(caml_young_ptr), %eax subl $16, %eax movl %eax, G(caml_young_ptr) @@ -227,10 +180,10 @@ LBL(102): UNDO_ALIGN_STACK(12) jmp G(caml_alloc3) CFI_ENDPROC + ENDFUNCTION(caml_alloc3) FUNCTION(caml_allocN) CFI_STARTPROC - PROFILE_CAML subl G(caml_young_ptr), %eax /* eax = size - caml_young_ptr */ negl %eax /* eax = caml_young_ptr - size */ cmpl G(caml_young_limit), %eax @@ -252,12 +205,12 @@ LBL(103): popl %eax; CFI_ADJUST(-4) /* recover desired size */ jmp G(caml_allocN) CFI_ENDPROC + ENDFUNCTION(caml_allocN) /* Call a C function from OCaml */ FUNCTION(caml_c_call) CFI_STARTPROC - PROFILE_CAML /* Record lowest stack address and return address */ movl (%esp), %edx movl %edx, G(caml_last_return_address) @@ -266,19 +219,19 @@ FUNCTION(caml_c_call) #if !defined(SYS_mingw) && !defined(SYS_cygwin) /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ - subl $16384, %esp + subl $(STACK_PROBE_SIZE), %esp; CFI_ADJUST(STACK_PROBE_SIZE); movl %eax, 0(%esp) - addl $16384, %esp + addl $(STACK_PROBE_SIZE), %esp; CFI_ADJUST(-STACK_PROBE_SIZE); #endif /* Call the function (address in %eax) */ jmp *%eax CFI_ENDPROC + ENDFUNCTION(caml_c_call) /* Start the OCaml program */ FUNCTION(caml_start_program) CFI_STARTPROC - PROFILE_C /* Save callee-save registers */ pushl %ebx; CFI_ADJUST(4) pushl %esi; CFI_ADJUST(4) @@ -322,6 +275,7 @@ LBL(108): orl $2, %eax jmp LBL(109) CFI_ENDPROC + ENDFUNCTION(caml_start_program) /* Raise an exception from OCaml */ @@ -350,12 +304,12 @@ LBL(110): UNDO_ALIGN_STACK(8) ret CFI_ENDPROC + ENDFUNCTION(caml_raise_exn) /* Raise an exception from C */ FUNCTION(caml_raise_exception) CFI_STARTPROC - PROFILE_C testl $1, G(caml_backtrace_active) jne LBL(112) movl 4(%esp), %eax @@ -377,12 +331,12 @@ LBL(112): UNDO_ALIGN_STACK(8) ret CFI_ENDPROC + ENDFUNCTION(caml_raise_exception) /* Callback from C to OCaml */ FUNCTION(caml_callback_exn) CFI_STARTPROC - PROFILE_C /* Save callee-save registers */ pushl %ebx; CFI_ADJUST(4) pushl %esi; CFI_ADJUST(4) @@ -394,10 +348,10 @@ FUNCTION(caml_callback_exn) movl 0(%ebx), %esi /* code pointer */ jmp LBL(106) CFI_ENDPROC + ENDFUNCTION(caml_callback_exn) FUNCTION(caml_callback2_exn) CFI_STARTPROC - PROFILE_C /* Save callee-save registers */ pushl %ebx; CFI_ADJUST(4) pushl %esi; CFI_ADJUST(4) @@ -410,10 +364,10 @@ FUNCTION(caml_callback2_exn) movl $ G(caml_apply2), %esi /* code pointer */ jmp LBL(106) CFI_ENDPROC + ENDFUNCTION(caml_callback2_exn) FUNCTION(caml_callback3_exn) CFI_STARTPROC - PROFILE_C /* Save callee-save registers */ pushl %ebx; CFI_ADJUST(4) pushl %esi; CFI_ADJUST(4) @@ -427,6 +381,7 @@ FUNCTION(caml_callback3_exn) movl $ G(caml_apply3), %esi /* code pointer */ jmp LBL(106) CFI_ENDPROC + ENDFUNCTION(caml_callback3_exn) FUNCTION(caml_ml_array_bound_error) CFI_STARTPROC @@ -449,6 +404,7 @@ FUNCTION(caml_ml_array_bound_error) /* Branch to [caml_array_bound_error] (never returns) */ call G(caml_array_bound_error) CFI_ENDPROC + ENDFUNCTION(caml_ml_array_bound_error) .globl G(caml_system__code_end) G(caml_system__code_end): @@ -474,14 +430,6 @@ G(caml_extra_params): .zero 64 #endif -#if defined(PROFILING) && defined(SYS_macosx) - .section __IMPORT,__jump_table,symbol_stubs,self_modifying_code+pure_instructions,5 -Lmcount$stub: - .indirect_symbol mcount - hlt ; hlt ; hlt ; hlt ; hlt - .subsections_via_symbols -#endif - #if defined(SYS_linux_elf) /* Mark stack as non-executable, PR#4564 */ .section .note.GNU-stack,"",%progbits diff --git a/runtime/intern.c b/runtime/intern.c index 9932d80b..6e2dcc79 100644 --- a/runtime/intern.c +++ b/runtime/intern.c @@ -505,7 +505,7 @@ static void intern_rec(value *dest) if (codeptr != NULL) { v = (value) codeptr; } else { - value * function_placeholder = + const value * function_placeholder = caml_named_value ("Debugger.function_placeholder"); if (function_placeholder != NULL) { v = *function_placeholder; diff --git a/runtime/ints.c b/runtime/ints.c index df6c65a4..c9584e4a 100644 --- a/runtime/ints.c +++ b/runtime/ints.c @@ -25,6 +25,11 @@ #include "caml/misc.h" #include "caml/mlvalues.h" +/* Comparison resulting in -1,0,1, with type intnat, + without extra integer width conversion (GPR#2250). */ +#define COMPARE_INT(v1, v2) \ + (intnat)(v1 > v2) - (intnat)(v1 < v2) + static const char * parse_sign_and_base(const char * p, /*out*/ int * base, /*out*/ int * signedness, @@ -126,8 +131,7 @@ CAMLprim value caml_bswap16(value v) CAMLprim value caml_int_compare(value v1, value v2) { - int res = (v1 > v2) - (v1 < v2); - return Val_int(res); + return Val_long(COMPARE_INT(v1, v2)); } CAMLprim value caml_int_of_string(value s) @@ -314,7 +318,7 @@ CAMLprim value caml_int32_to_float(value v) intnat caml_int32_compare_unboxed(int32_t i1, int32_t i2) { - return (i1 > i2) - (i1 < i2); + return COMPARE_INT(i1, i2); } CAMLprim value caml_int32_compare(value v1, value v2) @@ -562,7 +566,7 @@ CAMLprim value caml_int64_to_nativeint(value v) intnat caml_int64_compare_unboxed(int64_t i1, int64_t i2) { - return (i1 > i2) - (i1 < i2); + return COMPARE_INT(i1, i2); } CAMLprim value caml_int64_compare(value v1, value v2) @@ -824,7 +828,7 @@ CAMLprim value caml_nativeint_to_int32(value v) intnat caml_nativeint_compare_unboxed(intnat i1, intnat i2) { - return (i1 > i2) - (i1 < i2); + return COMPARE_INT(i1, i2); } CAMLprim value caml_nativeint_compare(value v1, value v2) diff --git a/runtime/obj.c b/runtime/obj.c index 4567b8ae..a2644866 100644 --- a/runtime/obj.c +++ b/runtime/obj.c @@ -72,6 +72,13 @@ CAMLprim value caml_obj_set_tag (value arg, value new_tag) return Val_unit; } +CAMLprim value caml_obj_make_forward (value blk, value fwd) +{ + caml_modify(&Field(blk, 0), fwd); + Tag_val (blk) = Forward_tag; + return Val_unit; +} + /* [size] is a value encoding a number of blocks */ CAMLprim value caml_obj_block(value tag, value size) { @@ -90,16 +97,16 @@ CAMLprim value caml_obj_block(value tag, value size) } /* Spacetime profiling assumes that this function is only called from OCaml. */ -CAMLprim value caml_obj_dup(value arg) +CAMLprim value caml_obj_with_tag(value new_tag_v, value arg) { - CAMLparam1 (arg); + CAMLparam2 (new_tag_v, arg); CAMLlocal1 (res); mlsize_t sz, i; tag_t tg; sz = Wosize_val(arg); - if (sz == 0) CAMLreturn (arg); - tg = Tag_val(arg); + tg = (tag_t)Long_val(new_tag_v); + if (sz == 0) CAMLreturn (Atom(tg)); if (tg >= No_scan_tag) { res = caml_alloc(sz, tg); memcpy(Bp_val(res), Bp_val(arg), sz * sizeof(value)); @@ -115,6 +122,12 @@ CAMLprim value caml_obj_dup(value arg) CAMLreturn (res); } +/* Spacetime profiling assumes that this function is only called from OCaml. */ +CAMLprim value caml_obj_dup(value arg) +{ + return caml_obj_with_tag(Val_long(Tag_val(arg)), arg); +} + /* Shorten the given block to the given size and return void. Raise Invalid_argument if the given size is less than or equal to 0 or greater than the current size. @@ -140,13 +153,13 @@ CAMLprim value caml_obj_truncate (value v, value newsize) mlsize_t wosize = Wosize_hd (hd); mlsize_t i; - if (tag == Double_array_tag) new_wosize *= Double_wosize; /* PR#156 */ + if (tag == Double_array_tag) new_wosize *= Double_wosize; /* PR#2520 */ if (new_wosize <= 0 || new_wosize > wosize){ caml_invalid_argument ("Obj.truncate"); } if (new_wosize == wosize) return Val_unit; - /* PR#61: since we're about to lose our references to the elements + /* PR#2400: since we're about to lose our references to the elements beyond new_wosize in v, erase them explicitly so that the GC can darken them as appropriate. */ if (tag < No_scan_tag) { diff --git a/runtime/printexc.c b/runtime/printexc.c index 83176500..3220a21d 100644 --- a/runtime/printexc.c +++ b/runtime/printexc.c @@ -110,7 +110,7 @@ CAMLexport char * caml_format_exception(value exn) static void default_fatal_uncaught_exception(value exn) { char * msg; - value * at_exit; + const value * at_exit; int saved_backtrace_active, saved_backtrace_pos; /* Build a string representation of the exception */ @@ -136,7 +136,7 @@ int caml_abort_on_uncaught_exn = 0; /* see afl.c */ void caml_fatal_uncaught_exception(value exn) { - value *handle_uncaught_exception; + const value *handle_uncaught_exception; handle_uncaught_exception = caml_named_value("Printexc.handle_uncaught_exception"); diff --git a/runtime/signals_osdep.h b/runtime/signals_osdep.h index d9bc8b18..417768f0 100644 --- a/runtime/signals_osdep.h +++ b/runtime/signals_osdep.h @@ -102,6 +102,26 @@ #define CONTEXT_YOUNG_PTR (context->uc_mcontext.regs[27]) #define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.fault_address) +/****************** ARM64, FreeBSD */ + +#elif defined(TARGET_arm64) && defined(SYS_freebsd) + + #include + + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, ucontext_t * context) + + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ + sigact.sa_flags = SA_SIGINFO + + typedef unsigned long context_reg; + #define CONTEXT_PC (context->uc_mcontext.mc_gpregs.gp_elr) + #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.mc_gpregs.gp_x[26]) + #define CONTEXT_YOUNG_PTR (context->uc_mcontext.mc_gpregs.gp_x[27]) + #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) + + /****************** AMD64, Solaris x86 */ #elif defined(TARGET_amd64) && defined (SYS_solaris) diff --git a/runtime/spacetime_nat.c b/runtime/spacetime_nat.c index b479f3e2..cb3d9b79 100644 --- a/runtime/spacetime_nat.c +++ b/runtime/spacetime_nat.c @@ -176,9 +176,9 @@ static void open_snapshot_channel(void) #else pid = getpid(); #endif - snprintf_os(filename, filename_len, _T("%s/spacetime-%d"), + snprintf_os(filename, filename_len, T("%s/spacetime-%d"), automatic_snapshot_dir, pid); - filename[filename_len-1] = _T('\0'); + filename[filename_len-1] = '\0'; fd = open_os(filename, O_WRONLY | O_CREAT | O_TRUNC | O_BINARY, 0666); if (fd == -1) { automatic_snapshots = 0; @@ -225,10 +225,10 @@ void caml_spacetime_initialize(void) caml_spacetime_static_shape_tables = &caml_spacetime_shapes; - ap_interval = caml_secure_getenv (_T("OCAML_SPACETIME_INTERVAL")); + ap_interval = caml_secure_getenv (T("OCAML_SPACETIME_INTERVAL")); if (ap_interval != NULL) { unsigned int interval = 0; - sscanf_os(ap_interval, _T("%u"), &interval); + sscanf_os(ap_interval, T("%u"), &interval); if (interval != 0) { double time; char_os cwd[4096]; @@ -236,7 +236,7 @@ void caml_spacetime_initialize(void) int dir_ok = 1; user_specified_automatic_snapshot_dir = - caml_secure_getenv(_T("OCAML_SPACETIME_SNAPSHOT_DIR")); + caml_secure_getenv(T("OCAML_SPACETIME_SNAPSHOT_DIR")); if (user_specified_automatic_snapshot_dir == NULL) { #if defined(HAS_GETCWD) diff --git a/runtime/startup_aux.c b/runtime/startup_aux.c index 9ab22e2a..a187d91a 100644 --- a/runtime/startup_aux.c +++ b/runtime/startup_aux.c @@ -69,50 +69,50 @@ int caml_cleanup_on_exit = 0; static void scanmult (char_os *opt, uintnat *var) { - char_os mult = _T(' '); + char_os mult = ' '; unsigned int val = 1; - sscanf_os (opt, _T("=%u%c"), &val, &mult); - sscanf_os (opt, _T("=0x%x%c"), &val, &mult); + sscanf_os (opt, T("=%u%c"), &val, &mult); + sscanf_os (opt, T("=0x%x%c"), &val, &mult); switch (mult) { - case _T('k'): *var = (uintnat) val * 1024; break; - case _T('M'): *var = (uintnat) val * (1024 * 1024); break; - case _T('G'): *var = (uintnat) val * (1024 * 1024 * 1024); break; + case 'k': *var = (uintnat) val * 1024; break; + case 'M': *var = (uintnat) val * (1024 * 1024); break; + case 'G': *var = (uintnat) val * (1024 * 1024 * 1024); break; default: *var = (uintnat) val; break; } } void caml_parse_ocamlrunparam(void) { - char_os *opt = caml_secure_getenv (_T("OCAMLRUNPARAM")); + char_os *opt = caml_secure_getenv (T("OCAMLRUNPARAM")); uintnat p; - if (opt == NULL) opt = caml_secure_getenv (_T("CAMLRUNPARAM")); + if (opt == NULL) opt = caml_secure_getenv (T("CAMLRUNPARAM")); if (opt != NULL){ - while (*opt != _T('\0')){ + while (*opt != '\0'){ switch (*opt++){ - case _T('a'): scanmult (opt, &p); caml_set_allocation_policy (p); break; - case _T('b'): scanmult (opt, &p); caml_record_backtrace(Val_bool (p)); + case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break; + case 'b': scanmult (opt, &p); caml_record_backtrace(Val_bool (p)); break; - case _T('c'): scanmult (opt, &p); caml_cleanup_on_exit = (p != 0); break; - case _T('h'): scanmult (opt, &caml_init_heap_wsz); break; - case _T('H'): scanmult (opt, &caml_use_huge_pages); break; - case _T('i'): scanmult (opt, &caml_init_heap_chunk_sz); break; - case _T('l'): scanmult (opt, &caml_init_max_stack_wsz); break; - case _T('M'): scanmult (opt, &caml_init_custom_major_ratio); break; - case _T('m'): scanmult (opt, &caml_init_custom_minor_ratio); break; - case _T('n'): scanmult (opt, &caml_init_custom_minor_max_bsz); break; - case _T('o'): scanmult (opt, &caml_init_percent_free); break; - case _T('O'): scanmult (opt, &caml_init_max_percent_free); break; - case _T('p'): scanmult (opt, &p); caml_parser_trace = (p != 0); break; - case _T('R'): break; /* see stdlib/hashtbl.mli */ - case _T('s'): scanmult (opt, &caml_init_minor_heap_wsz); break; - case _T('t'): scanmult (opt, &caml_trace_level); break; - case _T('v'): scanmult (opt, &caml_verb_gc); break; - case _T('w'): scanmult (opt, &caml_init_major_window); break; - case _T('W'): scanmult (opt, &caml_runtime_warnings); break; + case 'c': scanmult (opt, &p); caml_cleanup_on_exit = (p != 0); break; + case 'h': scanmult (opt, &caml_init_heap_wsz); break; + case 'H': scanmult (opt, &caml_use_huge_pages); break; + case 'i': scanmult (opt, &caml_init_heap_chunk_sz); break; + case 'l': scanmult (opt, &caml_init_max_stack_wsz); break; + case 'M': scanmult (opt, &caml_init_custom_major_ratio); break; + case 'm': scanmult (opt, &caml_init_custom_minor_ratio); break; + case 'n': scanmult (opt, &caml_init_custom_minor_max_bsz); break; + case 'o': scanmult (opt, &caml_init_percent_free); break; + case 'O': scanmult (opt, &caml_init_max_percent_free); break; + case 'p': scanmult (opt, &p); caml_parser_trace = (p != 0); break; + case 'R': break; /* see stdlib/hashtbl.mli */ + case 's': scanmult (opt, &caml_init_minor_heap_wsz); break; + case 't': scanmult (opt, &caml_trace_level); break; + case 'v': scanmult (opt, &caml_verb_gc); break; + case 'w': scanmult (opt, &caml_init_major_window); break; + case 'W': scanmult (opt, &caml_runtime_warnings); break; } - while (*opt != _T('\0')){ + while (*opt != '\0'){ if (*opt++ == ',') break; } } @@ -147,7 +147,7 @@ int caml_startup_aux(int pooling) static void call_registered_value(char* name) { - value *f = caml_named_value(name); + const value *f = caml_named_value(name); if (f != NULL) caml_callback_exn(*f, Val_unit); } diff --git a/runtime/startup_byt.c b/runtime/startup_byt.c index 1f648956..a996788b 100644 --- a/runtime/startup_byt.c +++ b/runtime/startup_byt.c @@ -260,40 +260,40 @@ static int parse_command_line(char_os **argv) { int i, j; - for(i = 1; argv[i] != NULL && argv[i][0] == _T('-'); i++) { + for(i = 1; argv[i] != NULL && argv[i][0] == '-'; i++) { switch(argv[i][1]) { - case _T('t'): + case 't': ++ caml_trace_level; /* ignored unless DEBUG mode */ break; - case _T('v'): - if (!strcmp_os (argv[i], _T("-version"))){ + case 'v': + if (!strcmp_os (argv[i], T("-version"))){ printf ("%s\n", "The OCaml runtime, version " OCAML_VERSION_STRING); exit (0); - }else if (!strcmp_os (argv[i], _T("-vnum"))){ + }else if (!strcmp_os (argv[i], T("-vnum"))){ printf ("%s\n", OCAML_VERSION_STRING); exit (0); }else{ caml_verb_gc = 0x001+0x004+0x008+0x010+0x020; } break; - case _T('p'): + case 'p': for (j = 0; caml_names_of_builtin_cprim[j] != NULL; j++) printf("%s\n", caml_names_of_builtin_cprim[j]); exit(0); break; - case _T('b'): + case 'b': caml_record_backtrace(Val_true); break; - case _T('I'): + case 'I': if (argv[i + 1] != NULL) { caml_ext_table_add(&caml_shared_libs_path, argv[i + 1]); i++; } break; - case _T('m'): + case 'm': print_magic = 1; break; - case _T('M'): + case 'M': printf ( "%s\n", EXEC_MAGIC); exit(0); break; @@ -440,7 +440,7 @@ CAMLexport void caml_main(char_os **argv) caml_sys_init(exe_name, argv + pos); #ifdef _WIN32 /* Start a thread to handle signals */ - if (caml_secure_getenv(_T("CAMLSIGPIPE"))) + if (caml_secure_getenv(T("CAMLSIGPIPE"))) _beginthread(caml_signal_thread, 4096, NULL); #endif /* Execute the program */ @@ -488,7 +488,7 @@ CAMLexport value caml_startup_code_exn( caml_install_invalid_parameter_handler(); #endif caml_init_custom_operations(); - cds_file = caml_secure_getenv(_T("CAML_DEBUG_FILE")); + cds_file = caml_secure_getenv(T("CAML_DEBUG_FILE")); if (cds_file != NULL) { caml_cds_file = caml_stat_strdup_os(cds_file); } diff --git a/runtime/startup_nat.c b/runtime/startup_nat.c index 43b85e31..b4e6bc47 100644 --- a/runtime/startup_nat.c +++ b/runtime/startup_nat.c @@ -146,7 +146,7 @@ value caml_startup_common(char_os **argv, int pooling) caml_init_backtrace(); caml_debugger_init (); /* force debugger.o stub to be linked */ exe_name = argv[0]; - if (exe_name == NULL) exe_name = _T(""); + if (exe_name == NULL) exe_name = T(""); proc_self_exe = caml_executable_name(); if (proc_self_exe != NULL) exe_name = proc_self_exe; diff --git a/runtime/sys.c b/runtime/sys.c index c019ee9f..226d596c 100644 --- a/runtime/sys.c +++ b/runtime/sys.c @@ -196,7 +196,7 @@ CAMLprim value caml_sys_open(value path, value vflags, value vperm) p = caml_stat_strdup_to_os(String_val(path)); flags |= caml_convert_flag_list(vflags, sys_open_flags); perm = Int_val(vperm); - /* open on a named FIFO can block (PR#1533) */ + /* open on a named FIFO can block (PR#8005) */ caml_enter_blocking_section(); fd = open_os(p, flags, perm); /* fcntl on a fd can block (PR#5069)*/ @@ -371,22 +371,35 @@ CAMLprim value caml_sys_getenv(value var) } char_os * caml_exe_name; -char_os ** caml_main_argv; +static value main_argv; CAMLprim value caml_sys_get_argv(value unit) { CAMLparam0 (); /* unit is unused */ - CAMLlocal3 (exe_name, argv, res); + CAMLlocal2 (exe_name, res); exe_name = caml_copy_string_of_os(caml_exe_name); - argv = - caml_alloc_array((void *)caml_copy_string_of_os, - (char const **) caml_main_argv); res = caml_alloc_small(2, 0); Field(res, 0) = exe_name; - Field(res, 1) = argv; + Field(res, 1) = main_argv; CAMLreturn(res); } +CAMLprim value caml_sys_argv(value unit) +{ + return main_argv; +} + +CAMLprim value caml_sys_modify_argv(value new_argv) +{ + caml_modify_generational_global_root(&main_argv, new_argv); + return Val_unit; +} + +CAMLprim value caml_sys_executable_name(value unit) +{ + return caml_copy_string_of_os(caml_exe_name); +} + void caml_sys_init(char_os * exe_name, char_os **argv) { #ifdef _WIN32 @@ -398,7 +411,9 @@ void caml_sys_init(char_os * exe_name, char_os **argv) #endif #endif caml_exe_name = exe_name; - caml_main_argv = argv; + main_argv = caml_alloc_array((void *)caml_copy_string_of_os, + (char const **) argv); + caml_register_generational_global_root(&main_argv); } #ifdef _WIN32 diff --git a/runtime/win32.c b/runtime/win32.c index f6ae5a0a..de4757d0 100644 --- a/runtime/win32.c +++ b/runtime/win32.c @@ -451,7 +451,7 @@ void caml_signal_thread(void * lpParam) HANDLE h; /* Get an hexa-code raw handle through the environment */ h = (HANDLE) (uintptr_t) - wcstol(caml_secure_getenv(_T("CAMLSIGPIPE")), &endptr, 16); + wcstol(caml_secure_getenv(T("CAMLSIGPIPE")), &endptr, 16); while (1) { DWORD numread; BOOL ret; @@ -676,26 +676,6 @@ wchar_t * caml_executable_name(void) /* snprintf emulation */ -#ifdef LACKS_VSCPRINTF -/* No _vscprintf until Visual Studio .NET 2002 and sadly no version number - in the CRT headers until Visual Studio 2005 so forced to predicate this - on the compiler version instead */ -int _vscprintf(const char * format, va_list args) -{ - int n; - int sz = 5; - char* buf = (char*)malloc(sz); - n = _vsnprintf(buf, sz, format, args); - while (n < 0 || n > sz) { - sz += 512; - buf = (char*)realloc(buf, sz); - n = _vsnprintf(buf, sz, format, args); - } - free(buf); - return n; -} -#endif - #if defined(_WIN32) && !defined(_UCRT) int caml_snprintf(char * buf, size_t size, const char * format, ...) { diff --git a/stdlib/.depend b/stdlib/.depend index 8929413f..7c6f3494 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -132,11 +132,13 @@ camlinternalLazy.cmx : \ camlinternalLazy.cmi camlinternalLazy.cmi : camlinternalMod.cmo : \ + stdlib__sys.cmi \ stdlib__obj.cmi \ camlinternalOO.cmi \ stdlib__array.cmi \ camlinternalMod.cmi camlinternalMod.cmx : \ + stdlib__sys.cmx \ stdlib__obj.cmx \ camlinternalOO.cmx \ stdlib__array.cmx \ @@ -679,577 +681,3 @@ stdlib.cmx : \ stdlib.cmi stdlib.cmi : \ camlinternalFormatBasics.cmi -stdlib__arg.cmo : \ - stdlib__sys.cmi \ - stdlib__string.cmi \ - stdlib__printf.cmi \ - stdlib__list.cmi \ - stdlib__buffer.cmi \ - stdlib__array.cmi \ - stdlib__arg.cmi -stdlib__arg.p.cmx : \ - stdlib__sys.cmx \ - stdlib__string.cmx \ - stdlib__printf.cmx \ - stdlib__list.cmx \ - stdlib__buffer.cmx \ - stdlib__array.cmx \ - stdlib__arg.cmi -stdlib__array.cmo : \ - stdlib__seq.cmi \ - stdlib__array.cmi -stdlib__array.p.cmx : \ - stdlib__seq.cmx \ - stdlib__array.cmi -stdlib__arrayLabels.cmo : \ - stdlib__array.cmi \ - stdlib__arrayLabels.cmi -stdlib__arrayLabels.p.cmx : \ - stdlib__array.cmx \ - stdlib__arrayLabels.cmi -stdlib__bigarray.cmo : \ - stdlib__sys.cmi \ - stdlib__complex.cmi \ - stdlib__array.cmi \ - stdlib__bigarray.cmi -stdlib__bigarray.p.cmx : \ - stdlib__sys.cmx \ - stdlib__complex.cmx \ - stdlib__array.cmx \ - stdlib__bigarray.cmi -stdlib__bool.cmo : \ - stdlib.cmi \ - stdlib__bool.cmi -stdlib__bool.p.cmx : \ - stdlib.cmx \ - stdlib__bool.cmi -stdlib__buffer.cmo : \ - stdlib__uchar.cmi \ - stdlib__sys.cmi \ - stdlib__string.cmi \ - stdlib__seq.cmi \ - stdlib__char.cmi \ - stdlib__bytes.cmi \ - stdlib__buffer.cmi -stdlib__buffer.p.cmx : \ - stdlib__uchar.cmx \ - stdlib__sys.cmx \ - stdlib__string.cmx \ - stdlib__seq.cmx \ - stdlib__char.cmx \ - stdlib__bytes.cmx \ - stdlib__buffer.cmi -stdlib__bytes.cmo : \ - stdlib__sys.cmi \ - stdlib.cmi \ - stdlib__seq.cmi \ - stdlib__char.cmi \ - stdlib__bytes.cmi -stdlib__bytes.p.cmx : \ - stdlib__sys.cmx \ - stdlib.cmx \ - stdlib__seq.cmx \ - stdlib__char.cmx \ - stdlib__bytes.cmi -stdlib__bytesLabels.cmo : \ - stdlib__bytes.cmi \ - stdlib__bytesLabels.cmi -stdlib__bytesLabels.p.cmx : \ - stdlib__bytes.cmx \ - stdlib__bytesLabels.cmi -stdlib__callback.cmo : \ - stdlib__obj.cmi \ - stdlib__callback.cmi -stdlib__callback.p.cmx : \ - stdlib__obj.cmx \ - stdlib__callback.cmi -camlinternalFormat.cmo : \ - stdlib__sys.cmi \ - stdlib__string.cmi \ - stdlib__int.cmi \ - stdlib__char.cmi \ - camlinternalFormatBasics.cmi \ - stdlib__bytes.cmi \ - stdlib__buffer.cmi \ - camlinternalFormat.cmi -camlinternalFormat.p.cmx : \ - stdlib__sys.cmx \ - stdlib__string.cmx \ - stdlib__int.cmx \ - stdlib__char.cmx \ - camlinternalFormatBasics.cmx \ - stdlib__bytes.cmx \ - stdlib__buffer.cmx \ - camlinternalFormat.cmi -camlinternalFormatBasics.cmo : \ - camlinternalFormatBasics.cmi -camlinternalFormatBasics.p.cmx : \ - camlinternalFormatBasics.cmi -camlinternalLazy.cmo : \ - stdlib__obj.cmi \ - camlinternalLazy.cmi -camlinternalLazy.p.cmx : \ - stdlib__obj.cmx \ - camlinternalLazy.cmi -camlinternalMod.cmo : \ - stdlib__obj.cmi \ - camlinternalOO.cmi \ - stdlib__array.cmi \ - camlinternalMod.cmi -camlinternalMod.p.cmx : \ - stdlib__obj.cmx \ - camlinternalOO.cmx \ - stdlib__array.cmx \ - camlinternalMod.cmi -camlinternalOO.cmo : \ - stdlib__sys.cmi \ - stdlib__string.cmi \ - stdlib__obj.cmi \ - stdlib__map.cmi \ - stdlib__list.cmi \ - stdlib__char.cmi \ - stdlib__array.cmi \ - camlinternalOO.cmi -camlinternalOO.p.cmx : \ - stdlib__sys.cmx \ - stdlib__string.cmx \ - stdlib__obj.cmx \ - stdlib__map.cmx \ - stdlib__list.cmx \ - stdlib__char.cmx \ - stdlib__array.cmx \ - camlinternalOO.cmi -stdlib__char.cmo : \ - stdlib__char.cmi -stdlib__char.p.cmx : \ - stdlib__char.cmi -stdlib__complex.cmo : \ - stdlib__complex.cmi -stdlib__complex.p.cmx : \ - stdlib__complex.cmi -stdlib__digest.cmo : \ - stdlib__string.cmi \ - stdlib__char.cmi \ - stdlib__bytes.cmi \ - stdlib__digest.cmi -stdlib__digest.p.cmx : \ - stdlib__string.cmx \ - stdlib__char.cmx \ - stdlib__bytes.cmx \ - stdlib__digest.cmi -stdlib__ephemeron.cmo : \ - stdlib__sys.cmi \ - stdlib__seq.cmi \ - stdlib__random.cmi \ - stdlib__obj.cmi \ - stdlib__lazy.cmi \ - stdlib__hashtbl.cmi \ - stdlib__array.cmi \ - stdlib__ephemeron.cmi -stdlib__ephemeron.p.cmx : \ - stdlib__sys.cmx \ - stdlib__seq.cmx \ - stdlib__random.cmx \ - stdlib__obj.cmx \ - stdlib__lazy.cmx \ - stdlib__hashtbl.cmx \ - stdlib__array.cmx \ - stdlib__ephemeron.cmi -stdlib__filename.cmo : \ - stdlib__sys.cmi \ - stdlib__string.cmi \ - stdlib__random.cmi \ - stdlib__printf.cmi \ - stdlib__lazy.cmi \ - stdlib__buffer.cmi \ - stdlib__filename.cmi -stdlib__filename.p.cmx : \ - stdlib__sys.cmx \ - stdlib__string.cmx \ - stdlib__random.cmx \ - stdlib__printf.cmx \ - stdlib__lazy.cmx \ - stdlib__buffer.cmx \ - stdlib__filename.cmi -stdlib__float.cmo : \ - stdlib.cmi \ - stdlib__seq.cmi \ - stdlib__list.cmi \ - stdlib__array.cmi \ - stdlib__float.cmi -stdlib__float.p.cmx : \ - stdlib.cmx \ - stdlib__seq.cmx \ - stdlib__list.cmx \ - stdlib__array.cmx \ - stdlib__float.cmi -stdlib__format.cmo : \ - stdlib__string.cmi \ - stdlib.cmi \ - stdlib__stack.cmi \ - stdlib__queue.cmi \ - stdlib__list.cmi \ - stdlib__int.cmi \ - camlinternalFormatBasics.cmi \ - camlinternalFormat.cmi \ - stdlib__buffer.cmi \ - stdlib__format.cmi -stdlib__format.p.cmx : \ - stdlib__string.cmx \ - stdlib.cmx \ - stdlib__stack.cmx \ - stdlib__queue.cmx \ - stdlib__list.cmx \ - stdlib__int.cmx \ - camlinternalFormatBasics.cmx \ - camlinternalFormat.cmx \ - stdlib__buffer.cmx \ - stdlib__format.cmi -stdlib__fun.cmo : \ - stdlib__printexc.cmi \ - stdlib__fun.cmi -stdlib__fun.p.cmx : \ - stdlib__printexc.cmx \ - stdlib__fun.cmi -stdlib__gc.cmo : \ - stdlib__sys.cmi \ - stdlib__string.cmi \ - stdlib__printf.cmi \ - stdlib__gc.cmi -stdlib__gc.p.cmx : \ - stdlib__sys.cmx \ - stdlib__string.cmx \ - stdlib__printf.cmx \ - stdlib__gc.cmi -stdlib__genlex.cmo : \ - stdlib__string.cmi \ - stdlib__stream.cmi \ - stdlib__list.cmi \ - stdlib__hashtbl.cmi \ - stdlib__char.cmi \ - stdlib__bytes.cmi \ - stdlib__genlex.cmi -stdlib__genlex.p.cmx : \ - stdlib__string.cmx \ - stdlib__stream.cmx \ - stdlib__list.cmx \ - stdlib__hashtbl.cmx \ - stdlib__char.cmx \ - stdlib__bytes.cmx \ - stdlib__genlex.cmi -stdlib__hashtbl.cmo : \ - stdlib__sys.cmi \ - stdlib__string.cmi \ - stdlib__seq.cmi \ - stdlib__random.cmi \ - stdlib__obj.cmi \ - stdlib__lazy.cmi \ - stdlib__array.cmi \ - stdlib__hashtbl.cmi -stdlib__hashtbl.p.cmx : \ - stdlib__sys.cmx \ - stdlib__string.cmx \ - stdlib__seq.cmx \ - stdlib__random.cmx \ - stdlib__obj.cmx \ - stdlib__lazy.cmx \ - stdlib__array.cmx \ - stdlib__hashtbl.cmi -stdlib__int.cmo : \ - stdlib.cmi \ - stdlib__int.cmi -stdlib__int.p.cmx : \ - stdlib.cmx \ - stdlib__int.cmi -stdlib__int32.cmo : \ - stdlib__sys.cmi \ - stdlib.cmi \ - stdlib__int32.cmi -stdlib__int32.p.cmx : \ - stdlib__sys.cmx \ - stdlib.cmx \ - stdlib__int32.cmi -stdlib__int64.cmo : \ - stdlib.cmi \ - stdlib__int64.cmi -stdlib__int64.p.cmx : \ - stdlib.cmx \ - stdlib__int64.cmi -stdlib__lazy.cmo : \ - stdlib__obj.cmi \ - camlinternalLazy.cmi \ - stdlib__lazy.cmi -stdlib__lazy.p.cmx : \ - stdlib__obj.cmx \ - camlinternalLazy.cmx \ - stdlib__lazy.cmi -stdlib__lexing.cmo : \ - stdlib__sys.cmi \ - stdlib__string.cmi \ - stdlib__bytes.cmi \ - stdlib__array.cmi \ - stdlib__lexing.cmi -stdlib__lexing.p.cmx : \ - stdlib__sys.cmx \ - stdlib__string.cmx \ - stdlib__bytes.cmx \ - stdlib__array.cmx \ - stdlib__lexing.cmi -stdlib__list.cmo : \ - stdlib__sys.cmi \ - stdlib__seq.cmi \ - stdlib__list.cmi -stdlib__list.p.cmx : \ - stdlib__sys.cmx \ - stdlib__seq.cmx \ - stdlib__list.cmi -stdlib__listLabels.cmo : \ - stdlib__list.cmi \ - stdlib__listLabels.cmi -stdlib__listLabels.p.cmx : \ - stdlib__list.cmx \ - stdlib__listLabels.cmi -stdlib__map.cmo : \ - stdlib__seq.cmi \ - stdlib__map.cmi -stdlib__map.p.cmx : \ - stdlib__seq.cmx \ - stdlib__map.cmi -stdlib__marshal.cmo : \ - stdlib__bytes.cmi \ - stdlib__marshal.cmi -stdlib__marshal.p.cmx : \ - stdlib__bytes.cmx \ - stdlib__marshal.cmi -stdlib__moreLabels.cmo : \ - stdlib__set.cmi \ - stdlib__map.cmi \ - stdlib__hashtbl.cmi \ - stdlib__moreLabels.cmi -stdlib__moreLabels.p.cmx : \ - stdlib__set.cmx \ - stdlib__map.cmx \ - stdlib__hashtbl.cmx \ - stdlib__moreLabels.cmi -stdlib__nativeint.cmo : \ - stdlib__sys.cmi \ - stdlib.cmi \ - stdlib__nativeint.cmi -stdlib__nativeint.p.cmx : \ - stdlib__sys.cmx \ - stdlib.cmx \ - stdlib__nativeint.cmi -stdlib__obj.cmo : \ - stdlib__sys.cmi \ - stdlib__marshal.cmi \ - stdlib__int32.cmi \ - stdlib__obj.cmi -stdlib__obj.p.cmx : \ - stdlib__sys.cmx \ - stdlib__marshal.cmx \ - stdlib__int32.cmx \ - stdlib__obj.cmi -stdlib__oo.cmo : \ - camlinternalOO.cmi \ - stdlib__oo.cmi -stdlib__oo.p.cmx : \ - camlinternalOO.cmx \ - stdlib__oo.cmi -stdlib__option.cmo : \ - stdlib__seq.cmi \ - stdlib__option.cmi -stdlib__option.p.cmx : \ - stdlib__seq.cmx \ - stdlib__option.cmi -stdlib__parsing.cmo : \ - stdlib__obj.cmi \ - stdlib__lexing.cmi \ - stdlib__array.cmi \ - stdlib__parsing.cmi -stdlib__parsing.p.cmx : \ - stdlib__obj.cmx \ - stdlib__lexing.cmx \ - stdlib__array.cmx \ - stdlib__parsing.cmi -stdlib__pervasives.cmo : \ - camlinternalFormatBasics.cmi -stdlib__pervasives.p.cmx : \ - camlinternalFormatBasics.cmx -stdlib__printexc.cmo : \ - stdlib.cmi \ - stdlib__printf.cmi \ - stdlib__obj.cmi \ - stdlib__buffer.cmi \ - stdlib__array.cmi \ - stdlib__printexc.cmi -stdlib__printexc.p.cmx : \ - stdlib.cmx \ - stdlib__printf.cmx \ - stdlib__obj.cmx \ - stdlib__buffer.cmx \ - stdlib__array.cmx \ - stdlib__printexc.cmi -stdlib__printf.cmo : \ - camlinternalFormatBasics.cmi \ - camlinternalFormat.cmi \ - stdlib__buffer.cmi \ - stdlib__printf.cmi -stdlib__printf.p.cmx : \ - camlinternalFormatBasics.cmx \ - camlinternalFormat.cmx \ - stdlib__buffer.cmx \ - stdlib__printf.cmi -stdlib__queue.cmo : \ - stdlib__seq.cmi \ - stdlib__queue.cmi -stdlib__queue.p.cmx : \ - stdlib__seq.cmx \ - stdlib__queue.cmi -stdlib__random.cmo : \ - stdlib__string.cmi \ - stdlib.cmi \ - stdlib__nativeint.cmi \ - stdlib__int64.cmi \ - stdlib__int32.cmi \ - stdlib__int.cmi \ - stdlib__digest.cmi \ - stdlib__char.cmi \ - stdlib__array.cmi \ - stdlib__random.cmi -stdlib__random.p.cmx : \ - stdlib__string.cmx \ - stdlib.cmx \ - stdlib__nativeint.cmx \ - stdlib__int64.cmx \ - stdlib__int32.cmx \ - stdlib__int.cmx \ - stdlib__digest.cmx \ - stdlib__char.cmx \ - stdlib__array.cmx \ - stdlib__random.cmi -stdlib__result.cmo : \ - stdlib__seq.cmi \ - stdlib__result.cmi -stdlib__result.p.cmx : \ - stdlib__seq.cmx \ - stdlib__result.cmi -stdlib__scanf.cmo : \ - stdlib__string.cmi \ - stdlib.cmi \ - stdlib__printf.cmi \ - stdlib__list.cmi \ - camlinternalFormatBasics.cmi \ - camlinternalFormat.cmi \ - stdlib__bytes.cmi \ - stdlib__buffer.cmi \ - stdlib__scanf.cmi -stdlib__scanf.p.cmx : \ - stdlib__string.cmx \ - stdlib.cmx \ - stdlib__printf.cmx \ - stdlib__list.cmx \ - camlinternalFormatBasics.cmx \ - camlinternalFormat.cmx \ - stdlib__bytes.cmx \ - stdlib__buffer.cmx \ - stdlib__scanf.cmi -stdlib__seq.cmo : \ - stdlib__seq.cmi -stdlib__seq.p.cmx : \ - stdlib__seq.cmi -stdlib__set.cmo : \ - stdlib__seq.cmi \ - stdlib__list.cmi \ - stdlib__set.cmi -stdlib__set.p.cmx : \ - stdlib__seq.cmx \ - stdlib__list.cmx \ - stdlib__set.cmi -stdlib__spacetime.cmo : \ - stdlib__gc.cmi \ - stdlib__spacetime.cmi -stdlib__spacetime.p.cmx : \ - stdlib__gc.cmx \ - stdlib__spacetime.cmi -stdlib__stack.cmo : \ - stdlib__seq.cmi \ - stdlib__list.cmi \ - stdlib__stack.cmi -stdlib__stack.p.cmx : \ - stdlib__seq.cmx \ - stdlib__list.cmx \ - stdlib__stack.cmi -stdlib__stdLabels.cmo : \ - stdlib__stringLabels.cmi \ - stdlib__listLabels.cmi \ - stdlib__bytesLabels.cmi \ - stdlib__arrayLabels.cmi \ - stdlib__stdLabels.cmi -stdlib__stdLabels.p.cmx : \ - stdlib__stringLabels.cmx \ - stdlib__listLabels.cmx \ - stdlib__bytesLabels.cmx \ - stdlib__arrayLabels.cmx \ - stdlib__stdLabels.cmi -std_exit.cmo : -std_exit.cmx : -stdlib__stream.cmo : \ - stdlib__string.cmi \ - stdlib__list.cmi \ - stdlib__lazy.cmi \ - stdlib__bytes.cmi \ - stdlib__stream.cmi -stdlib__stream.p.cmx : \ - stdlib__string.cmx \ - stdlib__list.cmx \ - stdlib__lazy.cmx \ - stdlib__bytes.cmx \ - stdlib__stream.cmi -stdlib__string.cmo : \ - stdlib.cmi \ - stdlib__bytes.cmi \ - stdlib__string.cmi -stdlib__string.p.cmx : \ - stdlib.cmx \ - stdlib__bytes.cmx \ - stdlib__string.cmi -stdlib__stringLabels.cmo : \ - stdlib__string.cmi \ - stdlib__stringLabels.cmi -stdlib__stringLabels.p.cmx : \ - stdlib__string.cmx \ - stdlib__stringLabels.cmi -stdlib__sys.cmo : \ - stdlib__sys.cmi -stdlib__sys.p.cmx : \ - stdlib__sys.cmi -stdlib__uchar.cmo : \ - stdlib.cmi \ - stdlib__char.cmi \ - stdlib__uchar.cmi -stdlib__uchar.p.cmx : \ - stdlib.cmx \ - stdlib__char.cmx \ - stdlib__uchar.cmi -stdlib__unit.cmo : \ - stdlib__unit.cmi -stdlib__unit.p.cmx : \ - stdlib__unit.cmi -stdlib__weak.cmo : \ - stdlib__sys.cmi \ - stdlib__obj.cmi \ - stdlib__hashtbl.cmi \ - stdlib__array.cmi \ - stdlib__weak.cmi -stdlib__weak.p.cmx : \ - stdlib__sys.cmx \ - stdlib__obj.cmx \ - stdlib__hashtbl.cmx \ - stdlib__array.cmx \ - stdlib__weak.cmi -stdlib.cmo : \ - camlinternalFormatBasics.cmi \ - stdlib.cmi -stdlib.p.cmx : \ - camlinternalFormatBasics.cmx \ - stdlib.cmi diff --git a/stdlib/Compflags b/stdlib/Compflags index 0f3138cd..8aa24398 100755 --- a/stdlib/Compflags +++ b/stdlib/Compflags @@ -15,21 +15,21 @@ #************************************************************************** case $1 in - stdlib.cm[iox]|stdlib.p.cmx) + stdlib.cm[iox]) echo ' -nopervasives -no-alias-deps -w -49' \ ' -pp "$AWK -f expand_module_aliases.awk"';; - camlinternalOO.cmx|camlinternalOO.p.cmx) echo ' -inline 0 -afl-inst-ratio 0';; - camlinternalLazy.cmx|camlinternalLazy.p.cmx) echo ' -afl-inst-ratio 0';; + camlinternalOO.cmx) echo ' -inline 0 -afl-inst-ratio 0';; + camlinternalLazy.cmx) echo ' -afl-inst-ratio 0';; # never instrument camlinternalOO or camlinternalLazy (PR#7725) - stdlib__buffer.cmx|stdlib__buffer.p.cmx) echo ' -inline 3';; + stdlib__buffer.cmx) echo ' -inline 3';; # make sure add_char is inlined (PR#5872) stdlib__buffer.cm[io]) echo ' -w A';; camlinternalFormat.cm[io]) echo ' -w Ae';; camlinternalFormatBasics*.cm[iox]) echo ' -nopervasives';; stdlib__printf.cm[io]|stdlib__format.cm[io]|stdlib__scanf.cm[io]) echo ' -w Ae';; - stdlib__scanf.cmx|stdlib__scanf.p.cmx) echo ' -inline 9';; - *Labels.cm[ox]|*Labels.p.cmx) echo ' -nolabels -no-alias-deps';; - stdlib__float.cm[ox]|stdlib__float.p.cmx) echo ' -nolabels -no-alias-deps';; + stdlib__scanf.cmx) echo ' -inline 9';; + *Labels.cm[ox]) echo ' -nolabels -no-alias-deps';; + stdlib__float.cm[ox]) echo ' -nolabels -no-alias-deps';; *) echo ' ';; esac diff --git a/stdlib/Makefile b/stdlib/Makefile index 67dc8bc4..97135b5a 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -18,7 +18,6 @@ ROOTDIR = .. include $(ROOTDIR)/Makefile.config include $(ROOTDIR)/Makefile.common -CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun TARGET_BINDIR ?= $(BINDIR) COMPILER=$(ROOTDIR)/ocamlc @@ -33,7 +32,7 @@ OPTCOMPFLAGS= endif OPTCOMPILER=$(ROOTDIR)/ocamlopt CAMLOPT=$(CAMLRUN) $(OPTCOMPILER) -CAMLDEP=$(CAMLRUN) $(ROOTDIR)/boot/ocamlc -depend +CAMLDEP=$(BOOT_OCAMLC) -depend DEPFLAGS=-slash OC_CPPFLAGS += -I$(ROOTDIR)/runtime @@ -75,23 +74,10 @@ ifeq "$(RUNTIMEI)" "true" all: camlheaderi target_camlheaderi endif -ifeq "$(PROFILING)" "true" -PROFILINGTARGET = prof -else -PROFILINGTARGET = noprof -endif - .PHONY: allopt opt.opt # allopt and opt.opt are synonyms -allopt: stdlib.cmxa std_exit.cmx allopt-$(PROFILINGTARGET) +allopt: stdlib.cmxa std_exit.cmx opt.opt: allopt -.PHONY: allopt-noprof -allopt-noprof: - -.PHONY: allopt-prof -allopt-prof: stdlib.p.cmxa std_exit.p.cmx - rm -f std_exit.p.cmi - LEGACY_OBJS=$(patsubst stdlib__%,"$(INSTALL_LIBDIR)/%", \ $(filter stdlib__%,$(OBJS))) .PHONY: install @@ -115,16 +101,16 @@ endif ifeq "$(RUNTIMED)" "true" install:: - $(INSTALL_DATA) target_camlheaderd "$(INSTALL_LIBDIR)" + $(INSTALL_DATA) target_camlheaderd "$(INSTALL_LIBDIR)/camlheaderd" endif ifeq "$(RUNTIMEI)" "true" install:: - $(INSTALL_DATA) target_camlheaderi "$(INSTALL_LIBDIR)" + $(INSTALL_DATA) target_camlheaderi "$(INSTALL_LIBDIR)/camlheaderi" endif .PHONY: installopt -installopt: installopt-default installopt-$(PROFILINGTARGET) +installopt: installopt-default .PHONY: installopt-default installopt-default: @@ -133,94 +119,78 @@ installopt-default: "$(INSTALL_LIBDIR)" cd "$(INSTALL_LIBDIR)"; $(RANLIB) stdlib.$(A) -.PHONY: installopt-noprof -installopt-noprof: - -.PHONY: installopt-prof -installopt-prof: - $(INSTALL_DATA) \ - stdlib.p.cmxa stdlib.p.$(A) std_exit.p.cmx std_exit.p.$(O) \ - "$(INSTALL_LIBDIR)" - cd "$(INSTALL_LIBDIR)"; $(RANLIB) stdlib.p.$(A) - ifeq "$(UNIX_OR_WIN32)" "unix" -HEADERPROGRAM = header.c +HEADERPROGRAM = header +HEADER_PATH = $(BINDIR)/ +HEADER_TARGET_PATH = $(TARGET_BINDIR)/ else # Windows -HEADERPROGRAM = headernt.c +HEADERPROGRAM = headernt +HEADER_PATH = +HEADER_TARGET_PATH = endif +TARGETHEADERPROGRAM = target_$(HEADERPROGRAM) + CAMLHEADERS =\ camlheader target_camlheader camlheader_ur \ camlheaderd target_camlheaderd \ camlheaderi target_camlheaderi +# The % in pattern rules must always match something, hence the slightly strange +# patterns and $(subst ...) since `camlheader%:` wouldn't match `camlheader` ifeq "$(HASHBANGSCRIPTS)" "true" -$(CAMLHEADERS): $(ROOTDIR)/Makefile.config - for suff in '' d i; do \ - echo '#!$(BINDIR)/ocamlrun'$$suff > camlheader$$suff && \ - echo '#!$(TARGET_BINDIR)/ocamlrun'$$suff >target_camlheader$$suff; \ - done && \ - echo '#!' | tr -d '\012' > camlheader_ur; -else # Hashbang scripts not supported - -$(CAMLHEADERS): $(HEADERPROGRAM) $(ROOTDIR)/Makefile.config +camlhead%: $(ROOTDIR)/Makefile.config Makefile + echo '#!$(BINDIR)/ocamlrun$(subst er,,$*)' > $@ -ifeq "$(UNIX_OR_WIN32)" "unix" -$(CAMLHEADERS): - for suff in '' d i; do \ - $(CC) $(OC_CFLAGS) $(OC_CPPFLAGS) $(OC_LDFLAGS) \ - -DRUNTIME_NAME='"$(BINDIR)/ocamlrun'$$suff'"' \ - header.c $(OUTPUTEXE)tmpheader$(EXE) && \ - strip tmpheader$(EXE) && \ - mv tmpheader$(EXE) camlheader$$suff && \ - $(CC) $(OC_CFLAGS) $(OC_CPPFLAGS) $(OC_LDFLAGS) \ - -DRUNTIME_NAME='"$(TARGET_BINDIR)/ocamlrun'$$suff'"' \ - header.c $(OUTPUTEXE)tmpheader$(EXE) && \ - strip tmpheader$(EXE) && \ - mv tmpheader$(EXE) target_camlheader$$suff; \ - done && \ - cp camlheader camlheader_ur +target_%: $(ROOTDIR)/Makefile.config Makefile + echo '#!$(TARGET_BINDIR)/ocamlrun$(subst camlheader,,$*)' > $@ -else # Windows +camlheader_ur: Makefile + echo '#!' | tr -d '\012' > $@ -# TODO: see whether there is a way to further merge the rules below -# with those above +else # Hashbang scripts not supported -camlheader: headernt.c - $(CC) -c $(OC_CFLAGS) $(OC_CPPFLAGS) \ - -DRUNTIME_NAME='"ocamlrun"' $(OUTPUTOBJ)headernt.$(O) $< - $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS) - rm -f camlheader.exe - mv tmpheader.exe camlheader +$(CAMLHEADERS): $(HEADERPROGRAM).c $(ROOTDIR)/Makefile.config Makefile -target_camlheader: camlheader - cp camlheader target_camlheader +# $@.exe is deleted to ensure no Cygwin .exe mangling takes place +camlhead%: tmphead%.exe + rm -f $@.exe + mv $< $@ -camlheader_ur: camlheader - cp camlheader camlheader_ur +# Again, pattern weirdness here means that the dot is always present so that +# tmpheader.exe matches. +tmpheader%exe: $(HEADERPROGRAM)%$(O) + $(call MKEXE_BOOT,$@,$^ $(EXTRALIBS)) +# FIXME This is wrong - mingw could invoke strip; MSVC equivalent? +ifneq "$(UNIX_OR_WIN32)" "win32" + strip $@ +endif -camlheaderd: headernt.c +$(HEADERPROGRAM)%$(O): $(HEADERPROGRAM).c $(CC) -c $(OC_CFLAGS) $(OC_CPPFLAGS) \ - -DRUNTIME_NAME='"ocamlrund"' $(OUTPUTOBJ)headerntd.$(O) $< - $(MKEXE) -o tmpheaderd.exe headerntd.$(O) $(EXTRALIBS) - mv tmpheaderd.exe camlheaderd + -DRUNTIME_NAME='"$(HEADER_PATH)ocamlrun$(subst .,,$*)"' \ + $(OUTPUTOBJ)$@ $^ -target_camlheaderd: camlheaderd - cp camlheaderd target_camlheaderd - -camlheaderi: headernt.c - $(CC) -c $(OC_CFLAGS) $(OC_CPPFLAGS) \ - -DRUNTIME_NAME='"ocamlruni"' $(OUTPUTOBJ)headernti.$(O) $< - $(MKEXE) -o tmpheaderi.exe headernti.$(O) $(EXTRALIBS) - mv tmpheaderi.exe camlheaderi +camlheader_ur: camlheader + cp camlheader $@ -target_camlheaderi: camlheaderi - cp camlheaderi target_camlheaderi +ifeq "$(UNIX_OR_WIN32)" "unix" +tmptargetcamlheader%exe: $(TARGETHEADERPROGRAM)%$(O) + $(call MKEXE_BOOT,$@,$^ $(EXTRALIBS)) + strip $@ -# TODO: do not call flexlink to build tmpheader.exe (we don't need -# the export table) +$(TARGETHEADERPROGRAM)%$(O): $(HEADERPROGRAM).c + $(CC) -c $(OC_CFLAGS) $(OC_CPPFLAGS) \ + -DRUNTIME_NAME='"$(HEADER_TARGET_PATH)ocamlrun$(subst .,,$*)"' \ + $(OUTPUTOBJ)$@ $^ -endif # ifeq "$(UNIX_OR_WIN32)" "unix" +target_%: tmptarget%.exe + rm -f $@.exe + mv $< $@ +else +target_%: % + cp $< $@ +endif endif # ifeq "$(HASHBANGSCRIPTS)" "true" @@ -230,9 +200,6 @@ stdlib.cma: $(OBJS) stdlib.cmxa: $(OBJS:.cmo=.cmx) $(CAMLOPT) -a -o $@ $^ -stdlib.p.cmxa: $(OBJS:.cmo=.p.cmx) - $(CAMLOPT) -a -o $@ $^ - sys.ml: $(ROOTDIR)/VERSION sys.mlp sed -e "s|%%VERSION%%|`sed -e 1q $< | tr -d '\r'`|" sys.mlp > $@ @@ -243,7 +210,7 @@ clean:: clean:: rm -f $(CAMLHEADERS) -.SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx +.SUFFIXES: .mli .ml .cmi .cmo .cmx export AWK @@ -266,33 +233,21 @@ stdlib__%.cmx: %.ml $(CAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) $(shell ./Compflags $@) \ -o $@ -c $< -%.p.cmx: %.ml - $(CAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) $(shell ./Compflags $@) \ - -p -c -o $@ $< - -stdlib__%.p.cmx: %.ml - $(CAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) $(shell ./Compflags $@) \ - -p -c -o $@ $< - # Dependencies on the compiler -COMPILER_DEPS=$(filter-out -use-prims, $(COMPILER)) +COMPILER_DEPS=$(filter-out -use-prims $(CAMLRUN), $(CAMLC)) $(OBJS) std_exit.cmo: $(COMPILER_DEPS) $(OBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER_DEPS) $(OBJS:.cmo=.cmx) std_exit.cmx: $(OPTCOMPILER) -$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: $(OPTCOMPILER) # Dependencies on Stdlib (not tracked by ocamlc -depend) $(OTHERS) std_exit.cmo: stdlib.cmi $(OTHERS:.cmo=.cmi) std_exit.cmi: stdlib.cmi $(OBJS:.cmo=.cmx) std_exit.cmx: stdlib.cmi -$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: stdlib.cmi $(OTHERS:.cmo=.cmx) std_exit.cmx: stdlib.cmx -$(OTHERS:.cmo=.p.cmx) std_exit.p.cmx: stdlib.cmx clean:: rm -f *.cm* *.$(O) *.$(A) *.odoc - rm -f *~ rm -f camlheader* include .depend @@ -300,20 +255,12 @@ include .depend EMPTY := SPACE := $(EMPTY) $(EMPTY) -# Note that .p.cmx targets do not depend (for compilation) upon other -# .p.cmx files. When the compiler imports another compilation unit, -# it looks for the .cmx file (not .p.cmx). .PHONY: depend depend: $(CAMLDEP) $(DEPFLAGS) $(filter-out stdlib.%,$(wildcard *.mli *.ml)) \ > .depend.tmp $(CAMLDEP) $(DEPFLAGS) -pp "$(AWK) -f remove_module_aliases.awk" \ stdlib.ml stdlib.mli >> .depend.tmp - $(CAMLDEP) $(DEPFLAGS) $(filter-out stdlib.%,$(wildcard *.ml)) \ - | sed -e 's/\.cmx : /.p.cmx : /g' >>.depend.tmp - $(CAMLDEP) $(DEPFLAGS) -pp "$(AWK) -f remove_module_aliases.awk" \ - stdlib.ml \ - | sed -e 's/\.cmx : /.p.cmx : /g' >> .depend.tmp sed -Ee \ 's#(^| )(${subst ${SPACE},|,${UNPREFIXED_OBJS}})[.]#\1stdlib__\2.#g' \ .depend.tmp > .depend diff --git a/stdlib/buffer.ml b/stdlib/buffer.ml index e8d83c1c..db218264 100644 --- a/stdlib/buffer.ml +++ b/stdlib/buffer.ml @@ -20,6 +20,13 @@ type t = mutable position : int; mutable length : int; initial_buffer : bytes} +(* Invariants: all parts of the code preserve the invariants that: + - [0 <= b.position <= b.length] + - [b.length = Bytes.length b.buffer] + + Note in particular that [b.position = b.length] is legal, + it means that the buffer is full and will have to be extended + before any further addition. *) let create n = let n = if n < 1 then 1 else n in @@ -55,15 +62,25 @@ let length b = b.position let clear b = b.position <- 0 let reset b = - b.position <- 0; b.buffer <- b.initial_buffer; + b.position <- 0; + b.buffer <- b.initial_buffer; b.length <- Bytes.length b.buffer +(* [resize b more] ensures that [b.position + more <= b.length] holds + by dynamically extending [b.buffer] if necessary -- and thus + increasing [b.length]. + + In particular, after [resize b more] is called, a direct access of + size [more] at [b.position] will always be in-bounds, so that + (unsafe_{get,set}) may be used for performance. +*) let resize b more = - let len = b.length in - let new_len = ref len in - while b.position + more > !new_len do new_len := 2 * !new_len done; + let old_pos = b.position in + let old_len = b.length in + let new_len = ref old_len in + while old_pos + more > !new_len do new_len := 2 * !new_len done; if !new_len > Sys.max_string_length then begin - if b.position + more <= Sys.max_string_length + if old_pos + more <= Sys.max_string_length then new_len := Sys.max_string_length else failwith "Buffer.add: cannot grow buffer" end; @@ -72,7 +89,44 @@ let resize b more = this tricky function that is slow anyway. *) Bytes.blit b.buffer 0 new_buffer 0 b.position; b.buffer <- new_buffer; - b.length <- !new_len + b.length <- !new_len; + assert (b.position + more <= b.length); + assert (old_pos + more <= b.length); + () + (* Note: there are various situations (preemptive threads, signals and + gc finalizers) where OCaml code may be run asynchronously; in + particular, there may be a race with another user of [b], changing + its mutable fields in the middle of the [resize] call. The Buffer + module does not provide any correctness guarantee if that happens, + but we must still ensure that the datastructure invariants hold for + memory-safety -- as we plan to use [unsafe_{get,set}]. + + There are two potential allocation points in this function, + [ref] and [Bytes.create], but all reads and writes to the fields + of [b] happen before both of them or after both of them. + + We therefore assume that [b.position] may change at these allocations, + and check that the [b.position + more <= b.length] postcondition + holds for both values of [b.position], before or after the function + is called. More precisely, the following invariants must hold if the + function returns correctly, in addition to the usual buffer invariants: + - [old(b.position) + more <= new(b.length)] + - [new(b.position) + more <= new(b.length)] + - [old(b.length) <= new(b.length)] + + Note: [b.position + more <= old(b.length)] does *not* + hold in general, as it is precisely the case where you need + to call [resize] to increase [b.length]. + + Note: [assert] above does not mean that we know the conditions + always hold, but that the function may return correctly + only if they hold. + + Note: the other functions in this module does not need + to be checked with this level of scrutiny, given that they + read/write the buffer immediately after checking that + [b.position + more <= b.length] hold or calling [resize]. + *) let add_char b c = let pos = b.position in @@ -163,7 +217,7 @@ let add_substring b s offset len = then invalid_arg "Buffer.add_substring/add_subbytes"; let new_position = b.position + len in if new_position > b.length then resize b len; - Bytes.blit_string s offset b.buffer b.position len; + Bytes.unsafe_blit_string s offset b.buffer b.position len; b.position <- new_position let add_subbytes b s offset len = @@ -173,7 +227,7 @@ let add_string b s = let len = String.length s in let new_position = b.position + len in if new_position > b.length then resize b len; - Bytes.blit_string s 0 b.buffer b.position len; + Bytes.unsafe_blit_string s 0 b.buffer b.position len; b.position <- new_position let add_bytes b s = add_string b (Bytes.unsafe_to_string s) @@ -181,20 +235,43 @@ let add_bytes b s = add_string b (Bytes.unsafe_to_string s) let add_buffer b bs = add_subbytes b bs.buffer 0 bs.position -(* read up to [len] bytes from [ic] into [b]. *) -let rec add_channel_rec b ic len = - if len > 0 then ( - let n = input ic b.buffer b.position len in - b.position <- b.position + n; - if n = 0 then raise End_of_file - else add_channel_rec b ic (len-n) (* n <= len *) - ) +(* this (private) function could move into the standard library *) +let really_input_up_to ic buf ofs len = + let rec loop ic buf ~already_read ~ofs ~to_read = + if to_read = 0 then already_read + else begin + let r = input ic buf ofs to_read in + if r = 0 then already_read + else begin + let already_read = already_read + r in + let ofs = ofs + r in + let to_read = to_read - r in + loop ic buf ~already_read ~ofs ~to_read + end + end + in loop ic buf ~already_read:0 ~ofs ~to_read:len + + +let unsafe_add_channel_up_to b ic len = + if b.position + len > b.length then resize b len; + let n = really_input_up_to ic b.buffer b.position len in + (* The assertion below may fail in weird scenario where + threaded/finalizer code, run asynchronously during the + [really_input_up_to] call, races on the buffer; we don't ensure + correctness in this case, but need to preserve the invariants for + memory-safety (see discussion of [resize]). *) + assert (b.position + n <= b.length); + b.position <- b.position + n; + n let add_channel b ic len = if len < 0 || len > Sys.max_string_length then (* PR#5004 *) invalid_arg "Buffer.add_channel"; - if b.position + len > b.length then resize b len; - add_channel_rec b ic len + let n = unsafe_add_channel_up_to b ic len in + (* It is intentional that a consumer catching End_of_file + will see the data written (see #6719, #7136). *) + if n < len then raise End_of_file; + () let output_buffer oc b = output oc b.buffer 0 b.position @@ -277,18 +354,20 @@ let truncate b len = let to_seq b = let rec aux i () = + (* Note that b.position is not a constant and cannot be lifted out of aux *) if i >= b.position then Seq.Nil else - let x = Bytes.get b.buffer i in + let x = Bytes.unsafe_get b.buffer i in Seq.Cons (x, aux (i+1)) in aux 0 let to_seqi b = let rec aux i () = + (* Note that b.position is not a constant and cannot be lifted out of aux *) if i >= b.position then Seq.Nil else - let x = Bytes.get b.buffer i in + let x = Bytes.unsafe_get b.buffer i in Seq.Cons ((i,x), aux (i+1)) in aux 0 diff --git a/stdlib/bytes.mli b/stdlib/bytes.mli index d449f82d..1016c685 100644 --- a/stdlib/bytes.mli +++ b/stdlib/bytes.mli @@ -669,5 +669,8 @@ external unsafe_set : bytes -> int -> char -> unit = "%bytes_unsafe_set" external unsafe_blit : bytes -> int -> bytes -> int -> int -> unit = "caml_blit_bytes" [@@noalloc] +external unsafe_blit_string : + string -> int -> bytes -> int -> int -> unit + = "caml_blit_string" [@@noalloc] external unsafe_fill : bytes -> int -> int -> char -> unit = "caml_fill_bytes" [@@noalloc] diff --git a/stdlib/bytesLabels.mli b/stdlib/bytesLabels.mli index 2cc700a5..baa7d1fb 100644 --- a/stdlib/bytesLabels.mli +++ b/stdlib/bytesLabels.mli @@ -513,6 +513,9 @@ external unsafe_set : bytes -> int -> char -> unit = "%bytes_unsafe_set" external unsafe_blit : src:bytes -> src_pos:int -> dst:bytes -> dst_pos:int -> len:int -> unit = "caml_blit_bytes" [@@noalloc] +external unsafe_blit_string : + src:string -> src_pos:int -> dst:bytes -> dst_pos:int -> len:int -> unit + = "caml_blit_string" [@@noalloc] external unsafe_fill : bytes -> pos:int -> len:int -> char -> unit = "caml_fill_bytes" [@@noalloc] val unsafe_to_string : bytes -> string diff --git a/stdlib/camlinternalFormat.ml b/stdlib/camlinternalFormat.ml index 7c36e22a..b10fba81 100644 --- a/stdlib/camlinternalFormat.ml +++ b/stdlib/camlinternalFormat.ml @@ -95,7 +95,8 @@ fun ign fmt -> match ign with (Int64 (iconv, pad_of_pad_opt pad_opt, No_precision, fmt)) | Ignored_float (pad_opt, prec_opt) -> Param_format_EBB - (Float (Float_f, pad_of_pad_opt pad_opt, prec_of_prec_opt prec_opt, fmt)) + (Float ((Float_flag_, Float_f), + pad_of_pad_opt pad_opt, prec_of_prec_opt prec_opt, fmt)) | Ignored_bool pad_opt -> Param_format_EBB (Bool (pad_of_pad_opt pad_opt, fmt)) | Ignored_format_arg (pad_opt, fmtty) -> @@ -216,10 +217,14 @@ type precision_ebb = Precision_EBB : ('a, 'b) precision -> precision_ebb (* Constants *) (* Default precision for float printing. *) -let default_float_precision = -6 +let default_float_precision fconv = + match snd fconv with + | Float_f | Float_e | Float_E | Float_g | Float_G | Float_h | Float_H -> -6 (* For %h and %H formats, a negative precision means "as many digits as necessary". For the other FP formats, we take the absolute value of the precision, hence 6 digits by default. *) + | Float_F -> 12 + (* Default precision for OCaml float printing (%F). *) (******************************************************************************) (* Externals *) @@ -286,11 +291,12 @@ let char_of_iconv iconv = match iconv with | Int_Co -> 'o' | Int_u | Int_Cu -> 'u' (* Convert a float conversion to char. *) -let char_of_fconv fconv = match fconv with - | Float_f | Float_pf | Float_sf -> 'f' | Float_e | Float_pe | Float_se -> 'e' - | Float_E | Float_pE | Float_sE -> 'E' | Float_g | Float_pg | Float_sg -> 'g' - | Float_G | Float_pG | Float_sG -> 'G' | Float_F -> 'F' - | Float_h | Float_ph | Float_sh -> 'h' | Float_H | Float_pH | Float_sH -> 'H' +(* `cF' will be 'F' for displaying format and 'g' to call libc printf *) +let char_of_fconv ?(cF='F') fconv = match snd fconv with + | Float_f -> 'f' | Float_e -> 'e' + | Float_E -> 'E' | Float_g -> 'g' + | Float_G -> 'G' | Float_F -> cF + | Float_h -> 'h' | Float_H -> 'H' (* Convert a scanning counter to char. *) @@ -433,16 +439,10 @@ let bprint_altint_fmt buf ign_flag iconv pad prec c = (***) (* Print the optional '+' associated to a float conversion. *) -let bprint_fconv_flag buf fconv = match fconv with - | Float_pf | Float_pe | Float_pE - | Float_pg | Float_pG | Float_ph | Float_pH -> - buffer_add_char buf '+' - | Float_sf | Float_se | Float_sE - | Float_sg | Float_sG | Float_sh | Float_sH -> - buffer_add_char buf ' ' - | Float_f | Float_e | Float_E - | Float_g | Float_G | Float_F | Float_h | Float_H -> - () +let bprint_fconv_flag buf fconv = match fst fconv with + | Float_flag_p -> buffer_add_char buf '+' + | Float_flag_s -> buffer_add_char buf ' ' + | Float_flag_ -> () (* Print a complete float format in a buffer (ex: "%+*.3f"). *) let bprint_float_fmt buf ign_flag fconv pad prec = @@ -1406,11 +1406,10 @@ let format_of_iconvn = function | Int_o -> "%no" | Int_Co -> "%#no" | Int_u | Int_Cu -> "%nu" -(* Generate the format_float first argument form a float_conv. *) +(* Generate the format_float first argument from a float_conv. *) let format_of_fconv fconv prec = - if fconv = Float_F then "%.12g" else let prec = abs prec in - let symb = char_of_fconv fconv in + let symb = char_of_fconv ~cF:'g' fconv in let buf = buffer_create 16 in buffer_add_char buf '%'; bprint_fconv_flag buf fconv; @@ -1457,21 +1456,21 @@ let convert_int64 iconv n = (* Convert a float to string. *) (* Fix special case of "OCaml float format". *) let convert_float fconv prec x = - match fconv with - | Float_h | Float_ph | Float_sh | Float_H | Float_pH | Float_sH -> + match snd fconv with + | Float_h | Float_H -> let sign = - match fconv with - | Float_ph | Float_pH -> '+' - | Float_sh | Float_sH -> ' ' + match fst fconv with + | Float_flag_p -> '+' + | Float_flag_s -> ' ' | _ -> '-' in let str = hexstring_of_float x prec sign in - begin match fconv with - | Float_H | Float_pH | Float_sH -> String.uppercase_ascii str + begin match snd fconv with + | Float_H -> String.uppercase_ascii str | _ -> str end | _ -> let str = format_float (format_of_fconv fconv prec) x in - if fconv <> Float_F then str else + if snd fconv <> Float_F then str else let len = String.length str in let rec is_valid i = if i = len then false else @@ -1733,7 +1732,7 @@ and make_float_padding_precision : type x y a b c d e f . fun k acc fmt pad prec fconv -> match pad, prec with | No_padding, No_precision -> fun x -> - let str = convert_float fconv default_float_precision x in + let str = convert_float fconv (default_float_precision fconv) x in make_printf k (Acc_data_string (acc, str)) fmt | No_padding, Lit_precision p -> fun x -> @@ -1745,7 +1744,7 @@ and make_float_padding_precision : type x y a b c d e f . make_printf k (Acc_data_string (acc, str)) fmt | Lit_padding (padty, w), No_precision -> fun x -> - let str = convert_float fconv default_float_precision x in + let str = convert_float fconv (default_float_precision fconv) x in let str' = fix_padding padty w str in make_printf k (Acc_data_string (acc, str')) fmt | Lit_padding (padty, w), Lit_precision p -> @@ -1758,7 +1757,7 @@ and make_float_padding_precision : type x y a b c d e f . make_printf k (Acc_data_string (acc, str)) fmt | Arg_padding padty, No_precision -> fun w x -> - let str = convert_float fconv default_float_precision x in + let str = convert_float fconv (default_float_precision fconv) x in let str' = fix_padding padty w str in make_printf k (Acc_data_string (acc, str')) fmt | Arg_padding padty, Lit_precision p -> @@ -2940,39 +2939,27 @@ let fmt_ebb_of_string ?legacy_behavior str = else incompatible_flag pct_ind str_ind symb "'+'" | false, _, false, _ -> assert false - (* Convert (plus, symb) to its associated float_conv. *) + (* Convert (plus, space, symb) to its associated float_conv. *) and compute_float_conv pct_ind str_ind plus space symb = - match plus, space, symb with - | false, false, 'f' -> Float_f | false, false, 'e' -> Float_e - | false, true, 'f' -> Float_sf | false, true, 'e' -> Float_se - | true, false, 'f' -> Float_pf | true, false, 'e' -> Float_pe - | false, false, 'E' -> Float_E | false, false, 'g' -> Float_g - | false, true, 'E' -> Float_sE | false, true, 'g' -> Float_sg - | true, false, 'E' -> Float_pE | true, false, 'g' -> Float_pg - | false, false, 'G' -> Float_G - | false, true, 'G' -> Float_sG - | true, false, 'G' -> Float_pG - | false, false, 'h' -> Float_h - | false, true, 'h' -> Float_sh - | true, false, 'h' -> Float_ph - | false, false, 'H' -> Float_H - | false, true, 'H' -> Float_sH - | true, false, 'H' -> Float_pH - | false, false, 'F' -> Float_F - | true, true, _ -> - if legacy_behavior then - (* plus and space: legacy implementation prefers plus *) - compute_float_conv pct_ind str_ind plus false symb - else incompatible_flag pct_ind str_ind ' ' "'+'" - | false, true, _ -> - if legacy_behavior then (* ignore *) - compute_float_conv pct_ind str_ind plus false symb - else incompatible_flag pct_ind str_ind symb "' '" - | true, false, _ -> - if legacy_behavior then (* ignore *) - compute_float_conv pct_ind str_ind false space symb - else incompatible_flag pct_ind str_ind symb "'+'" - | false, false, _ -> assert false + let flag = match plus, space with + | false, false -> Float_flag_ + | false, true -> Float_flag_s + | true, false -> Float_flag_p + | true, true -> + (* plus and space: legacy implementation prefers plus *) + if legacy_behavior then Float_flag_p + else incompatible_flag pct_ind str_ind ' ' "'+'" in + let kind = match symb with + | 'f' -> Float_f + | 'e' -> Float_e + | 'E' -> Float_E + | 'g' -> Float_g + | 'G' -> Float_G + | 'h' -> Float_h + | 'H' -> Float_H + | 'F' -> Float_F + | _ -> assert false in + flag, kind (* Raise [Failure] with a friendly error message about incompatible options.*) and incompatible_flag : type a . int -> int -> char -> string -> a = diff --git a/stdlib/camlinternalFormatBasics.ml b/stdlib/camlinternalFormatBasics.ml index 03e973ce..c7fe17e6 100644 --- a/stdlib/camlinternalFormatBasics.ml +++ b/stdlib/camlinternalFormatBasics.ml @@ -32,15 +32,20 @@ type int_conv = | Int_Cd | Int_Ci | Int_Cu (* %#d | %#i | %#u *) (* Float conversion. *) -type float_conv = - | Float_f | Float_pf | Float_sf (* %f | %+f | % f *) - | Float_e | Float_pe | Float_se (* %e | %+e | % e *) - | Float_E | Float_pE | Float_sE (* %E | %+E | % E *) - | Float_g | Float_pg | Float_sg (* %g | %+g | % g *) - | Float_G | Float_pG | Float_sG (* %G | %+G | % G *) - | Float_F (* %F *) - | Float_h | Float_ph | Float_sh (* %h | %+h | % h *) - | Float_H | Float_pH | Float_sH (* %H | %+H | % H *) +type float_flag_conv = + | Float_flag_ (* %[feEgGFhH] *) + | Float_flag_p (* %+[feEgGFhH] *) + | Float_flag_s (* % [feEgGFhH] *) +type float_kind_conv = + | Float_f (* %f | %+f | % f *) + | Float_e (* %e | %+e | % e *) + | Float_E (* %E | %+E | % E *) + | Float_g (* %g | %+g | % g *) + | Float_G (* %G | %+G | % G *) + | Float_F (* %F | %+F | % F *) + | Float_h (* %h | %+h | % h *) + | Float_H (* %H | %+H | % H *) +type float_conv = float_flag_conv * float_kind_conv (***) @@ -386,7 +391,7 @@ and ('a, 'b, 'c, 'd, 'e, 'f) fmt = int_conv * ('x, 'y) padding * ('y, int64 -> 'a) precision * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> ('x, 'b, 'c, 'd, 'e, 'f) fmt - | Float : (* %[feEgGF] *) + | Float : (* %[feEgGFhH] *) float_conv * ('x, 'y) padding * ('y, float -> 'a) precision * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> ('x, 'b, 'c, 'd, 'e, 'f) fmt diff --git a/stdlib/camlinternalFormatBasics.mli b/stdlib/camlinternalFormatBasics.mli index 4b7f4389..952f67a5 100644 --- a/stdlib/camlinternalFormatBasics.mli +++ b/stdlib/camlinternalFormatBasics.mli @@ -22,11 +22,12 @@ type int_conv = | Int_x | Int_Cx | Int_X | Int_CX | Int_o | Int_Co | Int_u | Int_Cd | Int_Ci | Int_Cu -type float_conv = - | Float_f | Float_pf | Float_sf | Float_e | Float_pe | Float_se - | Float_E | Float_pE | Float_sE | Float_g | Float_pg | Float_sg - | Float_G | Float_pG | Float_sG | Float_F - | Float_h | Float_ph | Float_sh | Float_H | Float_pH | Float_sH +type float_flag_conv = + | Float_flag_ | Float_flag_p | Float_flag_s +type float_kind_conv = + | Float_f | Float_e | Float_E | Float_g | Float_G + | Float_F | Float_h | Float_H +type float_conv = float_flag_conv * float_kind_conv type char_set = string @@ -197,7 +198,7 @@ and ('a, 'b, 'c, 'd, 'e, 'f) fmt = int_conv * ('x, 'y) padding * ('y, int64 -> 'a) precision * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> ('x, 'b, 'c, 'd, 'e, 'f) fmt -| Float : (* %[feEgGF] *) +| Float : (* %[feEgGFhH] *) float_conv * ('x, 'y) padding * ('y, float -> 'a) precision * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> ('x, 'b, 'c, 'd, 'e, 'f) fmt diff --git a/stdlib/camlinternalLazy.ml b/stdlib/camlinternalLazy.ml index bc727b73..8226ffda 100644 --- a/stdlib/camlinternalLazy.ml +++ b/stdlib/camlinternalLazy.ml @@ -21,15 +21,15 @@ exception Undefined let raise_undefined = Obj.repr (fun () -> raise Undefined) +external make_forward : Obj.t -> Obj.t -> unit = "caml_obj_make_forward" + (* Assume [blk] is a block with tag lazy *) let force_lazy_block (blk : 'arg lazy_t) = let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in Obj.set_field (Obj.repr blk) 0 raise_undefined; try let result = closure () in - (* do set_field BEFORE set_tag *) - Obj.set_field (Obj.repr blk) 0 (Obj.repr result); - Obj.set_tag (Obj.repr blk) Obj.forward_tag; + make_forward (Obj.repr blk) (Obj.repr result); result with e -> Obj.set_field (Obj.repr blk) 0 (Obj.repr (fun () -> raise e)); @@ -41,9 +41,7 @@ let force_val_lazy_block (blk : 'arg lazy_t) = let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in Obj.set_field (Obj.repr blk) 0 raise_undefined; let result = closure () in - (* do set_field BEFORE set_tag *) - Obj.set_field (Obj.repr blk) 0 (Obj.repr result); - Obj.set_tag (Obj.repr blk) (Obj.forward_tag); + make_forward (Obj.repr blk) (Obj.repr result); result diff --git a/stdlib/camlinternalMod.ml b/stdlib/camlinternalMod.ml index 5ccf9289..c56d22ef 100644 --- a/stdlib/camlinternalMod.ml +++ b/stdlib/camlinternalMod.ml @@ -13,6 +13,8 @@ (* *) (**************************************************************************) +external make_forward : Obj.t -> Obj.t -> unit = "caml_obj_make_forward" + type shape = | Function | Lazy @@ -49,19 +51,22 @@ let rec init_mod loc shape = let rec update_mod shape o n = match shape with | Function -> - if Obj.tag n = Obj.closure_tag && Obj.size n <= Obj.size o - then begin overwrite o n; Obj.truncate o (Obj.size n) (* PR#4008 *) end + (* The optimisation below is invalid on bytecode since + the RESTART instruction checks the length of closures. + See PR#4008 *) + if Sys.backend_type = Sys.Native + && Obj.tag n = Obj.closure_tag + && Obj.size n <= Obj.size o + then begin overwrite o n end else overwrite o (Obj.repr (fun x -> (Obj.obj n : _ -> _) x)) | Lazy -> if Obj.tag n = Obj.lazy_tag then Obj.set_field o 0 (Obj.field n 0) else if Obj.tag n = Obj.forward_tag then begin (* PR#4316 *) - Obj.set_tag o Obj.forward_tag; - Obj.set_field o 0 (Obj.field n 0) + make_forward o (Obj.field n 0) end else begin (* forwarding pointer was shortcut by GC *) - Obj.set_tag o Obj.forward_tag; - Obj.set_field o 0 n + make_forward o n end | Class -> assert (Obj.tag n = 0 && Obj.size n = 4); diff --git a/stdlib/obj.ml b/stdlib/obj.ml index b2269a95..32049d72 100644 --- a/stdlib/obj.ml +++ b/stdlib/obj.ml @@ -38,6 +38,7 @@ external new_block : int -> int -> t = "caml_obj_block" external dup : t -> t = "caml_obj_dup" external truncate : t -> int -> unit = "caml_obj_truncate" external add_offset : t -> Int32.t -> t = "caml_obj_add_offset" +external with_tag : int -> t -> t = "caml_obj_with_tag" let marshal (obj : t) = Marshal.to_bytes obj [] diff --git a/stdlib/obj.mli b/stdlib/obj.mli index bac04d56..818f315f 100644 --- a/stdlib/obj.mli +++ b/stdlib/obj.mli @@ -55,6 +55,7 @@ external field : t -> int -> t = "%obj_field" *) external set_field : t -> int -> t -> unit = "%obj_set_field" external set_tag : t -> int -> unit = "caml_obj_set_tag" + [@@ocaml.deprecated "Use with_tag instead."] val [@inline always] double_field : t -> int -> float (* @since 3.11.2 *) val [@inline always] set_double_field : t -> int -> float -> unit @@ -62,8 +63,11 @@ val [@inline always] set_double_field : t -> int -> float -> unit external new_block : int -> int -> t = "caml_obj_block" external dup : t -> t = "caml_obj_dup" external truncate : t -> int -> unit = "caml_obj_truncate" + [@@ocaml.deprecated] external add_offset : t -> Int32.t -> t = "caml_obj_add_offset" (* @since 3.12.0 *) +external with_tag : int -> t -> t = "caml_obj_with_tag" + (* @since 4.09.0 *) val first_non_constant_constructor_tag : int val last_non_constant_constructor_tag : int diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml index 28f4fe06..13d9ebee 100644 --- a/stdlib/printexc.ml +++ b/stdlib/printexc.ml @@ -43,32 +43,38 @@ let fields x = | 2 -> sprintf "(%s)" (field x 1) | _ -> sprintf "(%s%s)" (field x 1) (other_fields x 2) -let to_string x = +let use_printers x = let rec conv = function | hd :: tl -> - (match try hd x with _ -> None with - | Some s -> s - | None -> conv tl) - | [] -> - match x with - | Out_of_memory -> "Out of memory" - | Stack_overflow -> "Stack overflow" - | Match_failure(file, line, char) -> - sprintf locfmt file line char (char+5) "Pattern matching failed" - | Assert_failure(file, line, char) -> - sprintf locfmt file line char (char+6) "Assertion failed" - | Undefined_recursive_module(file, line, char) -> - sprintf locfmt file line char (char+6) "Undefined recursive module" - | _ -> - let x = Obj.repr x in - if Obj.tag x <> 0 then - (Obj.magic (Obj.field x 0) : string) - else - let constructor = - (Obj.magic (Obj.field (Obj.field x 0) 0) : string) in - constructor ^ (fields x) in + (match hd x with + | None | exception _ -> conv tl + | Some s -> Some s) + | [] -> None in conv !printers +let to_string_default = function + | Out_of_memory -> "Out of memory" + | Stack_overflow -> "Stack overflow" + | Match_failure(file, line, char) -> + sprintf locfmt file line char (char+5) "Pattern matching failed" + | Assert_failure(file, line, char) -> + sprintf locfmt file line char (char+6) "Assertion failed" + | Undefined_recursive_module(file, line, char) -> + sprintf locfmt file line char (char+6) "Undefined recursive module" + | x -> + let x = Obj.repr x in + if Obj.tag x <> 0 then + (Obj.magic (Obj.field x 0) : string) + else + let constructor = + (Obj.magic (Obj.field (Obj.field x 0) 0) : string) in + constructor ^ (fields x) + +let to_string e = + match use_printers e with + | Some s -> s + | None -> to_string_default e + let print fct arg = try fct arg diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli index da22a523..c215ad76 100644 --- a/stdlib/printexc.mli +++ b/stdlib/printexc.mli @@ -22,6 +22,12 @@ val to_string: exn -> string (** [Printexc.to_string e] returns a string representation of the exception [e]. *) +val to_string_default: exn -> string +(** [Printexc.to_string_default e] returns a string representation of the + exception [e], ignoring all registered exception printers. + @since 4.09 +*) + val print: ('a -> 'b) -> 'a -> 'b (** [Printexc.print fn x] applies [fn] to [x] and returns the result. If the evaluation of [fn x] raises any exception, the @@ -95,6 +101,12 @@ val register_printer: (exn -> string option) -> unit @since 3.11.2 *) +val use_printers: exn -> string option +(** [Printexc.use_printers e] returns [None] if there are no registered + printers and [Some s] with else as the resulting string otherwise. + @since 4.09 +*) + (** {1 Raw backtraces} *) type raw_backtrace diff --git a/stdlib/printf.mli b/stdlib/printf.mli index a80aa045..44571830 100644 --- a/stdlib/printf.mli +++ b/stdlib/printf.mli @@ -61,7 +61,7 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a and the decimal-point character is removed if there is no fractional part remaining. - [h] or [H]: convert a floating-point argument to hexadecimal notation, - in the style [0xh.hhhh e+-dd] (hexadecimal mantissa, exponent in + in the style [0xh.hhhh p+-dd] (hexadecimal mantissa, exponent in decimal and denotes a power of 2). - [B]: convert a boolean argument to the string [true] or [false] - [b]: convert a boolean argument (deprecated; do not use in new @@ -110,8 +110,9 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a The optional [precision] is a dot [.] followed by an integer indicating how many digits follow the decimal point in the [%f], - [%e], and [%E] conversions. For instance, [%.4f] prints a [float] with - 4 fractional digits. + [%e], [%E], [%h], and [%H] conversions or the maximum number of + significant digits to appear for the [%F], [%g] and [%G] conversions. + For instance, [%.4f] prints a [float] with 4 fractional digits. The integer in a [width] or [precision] can also be specified as [*], in which case an extra integer argument is taken to specify diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml index b4d62a81..b72c1e6d 100644 --- a/stdlib/scanf.ml +++ b/stdlib/scanf.ml @@ -1348,14 +1348,12 @@ fun ib fmt readers -> match fmt with let c = integer_conversion_of_char (char_of_iconv iconv) in let scan width _ ib = scan_int_conversion c width ib in pad_prec_scanf ib rest readers pad prec scan (token_int64 c) - | Float (Float_F, pad, prec, rest) -> + | Float ((_, Float_F), pad, prec, rest) -> pad_prec_scanf ib rest readers pad prec scan_caml_float token_float - | Float ((Float_f | Float_pf | Float_sf | Float_e | Float_pe | Float_se - | Float_E | Float_pE | Float_sE | Float_g | Float_pg | Float_sg - | Float_G | Float_pG | Float_sG), pad, prec, rest) -> - pad_prec_scanf ib rest readers pad prec scan_float token_float - | Float ((Float_h | Float_ph | Float_sh | Float_H | Float_pH | Float_sH), + | Float ((_, (Float_f | Float_e | Float_E | Float_g | Float_G)), pad, prec, rest) -> + pad_prec_scanf ib rest readers pad prec scan_float token_float + | Float ((_, (Float_h | Float_H)), pad, prec, rest) -> pad_prec_scanf ib rest readers pad prec scan_hex_float token_float | Bool (pad, rest) -> let scan _ _ ib = scan_bool ib in diff --git a/stdlib/sys.mli b/stdlib/sys.mli index 370449ec..87fd0622 100644 --- a/stdlib/sys.mli +++ b/stdlib/sys.mli @@ -20,7 +20,7 @@ an error. *) -val argv : string array +external argv : string array = "%sys_argv" (** The command line arguments given to the process. The first element is the command name used to invoke the program. The following elements are the command-line arguments diff --git a/stdlib/sys.mlp b/stdlib/sys.mlp index 5d997e8a..2da2b778 100644 --- a/stdlib/sys.mlp +++ b/stdlib/sys.mlp @@ -25,7 +25,8 @@ type backend_type = (* System interface *) external get_config: unit -> string * int * bool = "caml_sys_get_config" -external get_argv: unit -> string * string array = "caml_sys_get_argv" +external get_executable_name : unit -> string = "caml_sys_executable_name" +external argv : string array = "%sys_argv" external big_endian : unit -> bool = "%big_endian" external word_size : unit -> int = "%word_size" external int_size : unit -> int = "%int_size" @@ -35,7 +36,7 @@ external win32 : unit -> bool = "%ostype_win32" external cygwin : unit -> bool = "%ostype_cygwin" external get_backend_type : unit -> backend_type = "%backend_type" -let (executable_name, argv) = get_argv() +let executable_name = get_executable_name() let (os_type, _, _) = get_config() let backend_type = get_backend_type () let big_endian = big_endian () diff --git a/stdlib/weak.ml b/stdlib/weak.ml index 5368ff80..1746574f 100644 --- a/stdlib/weak.ml +++ b/stdlib/weak.ml @@ -200,8 +200,10 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct t.table.(t.rover) <- emptybucket; t.hashes.(t.rover) <- [| |]; end else begin - Obj.truncate (Obj.repr bucket) (prev_len + additional_values); - Obj.truncate (Obj.repr hbucket) prev_len; + let newbucket = weak_create prev_len in + blit bucket 0 newbucket 0 prev_len; + t.table.(t.rover) <- newbucket; + t.hashes.(t.rover) <- Array.sub hbucket 0 prev_len end; if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1; end; diff --git a/testsuite/interactive/lib-graph-2/Makefile b/testsuite/interactive/lib-graph-2/Makefile deleted file mode 100644 index c87f2d0a..00000000 --- a/testsuite/interactive/lib-graph-2/Makefile +++ /dev/null @@ -1,23 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Clerc, SED, INRIA Rocquencourt * -#* * -#* Copyright 2010 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -BASEDIR=../.. -#MODULES= -MAIN_MODULE=graph_test -#ADD_COMPFLAGS= -LIBRARIES=graphics - -include $(BASEDIR)/makefiles/Makefile.one -include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/interactive/lib-graph-2/graph_test.ml b/testsuite/interactive/lib-graph-2/graph_test.ml deleted file mode 100644 index 00d776f4..00000000 --- a/testsuite/interactive/lib-graph-2/graph_test.ml +++ /dev/null @@ -1,290 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Weis, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* graph_test.ml : tests various drawing and filling primitives of the - Graphics library. *) - -(* To run this example just load this file into a suitable toplevel. - Alternatively execute - ocamlc graphics.cma graph_test.ml *) - -open Graphics;; - -auto_synchronize false;; -display_mode false;; -remember_mode true;; - -let sz = 450;; - -open_graph (Printf.sprintf " %ix%i" sz sz);; - -(* To be defined for older versions of OCaml - Lineto, moveto and draw_rect. - -let rlineto x y = - let xc, yc = current_point () in - lineto (x + xc) (y + yc);; - -let rmoveto x y = - let xc, yc = current_point () in - moveto (x + xc) (y + yc);; - -let draw_rect x y w h = - let x0, y0 = current_point () in - moveto x y; - rlineto w 0; - rlineto 0 h; - rlineto (- w) 0; - rlineto 0 (-h); - moveto x0 y0;; -*) - -(* A set of points. *) - -set_color foreground;; - -let dashes y = - for i = 1 to 100 do - plot y (2 * i); - plot y (3 * i); - plot y (4 * i); - done;; - -dashes 3;; - -set_line_width 20;; -dashes (sz - 20);; - -(* Drawing chars *) - -draw_char 'C'; -draw_char 'a'; -draw_char 'm'; -draw_char 'l';; - -(* More and more red enlarging squares *) -moveto 10 10;; -set_line_width 5;; - -let carre c = - rlineto 0 c; - rlineto c 0; - rlineto 0 (- c); - rlineto (- c) 0;; - -for i = 1 to 10 do - moveto (10 * i) (10 * i); - set_color (rgb (155 + 10 * i) 0 0); - carre (10 * i) -done;; - -(* Blue squares in arithmetic progression *) -moveto 10 210;; -set_color blue;; -set_line_width 1;; - -for i = 1 to 10 do - carre (10 * i) -done;; - -(* Tiny circles filled or not *) -rmoveto 0 120;; -(* Must not change the current point *) -fill_circle 20 190 10;; -set_color green;; -rlineto 0 10;; -rmoveto 50 10;; -let x, y = current_point () in -(* Must not change the current point *) -draw_circle x y 20;; -set_color black;; -rlineto 0 20;; - -(* Cyan rectangles as a kind of graphical representation *) -set_color cyan;; - -let lw = 15;; -set_line_width lw;; -let go_caption l = moveto 210 (130 - lw + l);; -let go_legend () = go_caption (- 3 * lw);; - -go_caption 0;; -fill_rect 210 130 5 10;; -fill_rect 220 130 10 20;; -fill_rect 235 130 15 40;; -fill_rect 255 130 20 80;; -fill_rect 280 130 25 160;; -(* A green rectangle below the graph. *) -set_color green;; -rlineto 50 0;; - -(* A black frame for each of our rectangles *) -set_color black;; -set_line_width (lw / 4);; - -draw_rect 210 130 5 10;; -draw_rect 220 130 10 20;; -draw_rect 235 130 15 40;; -draw_rect 255 130 20 80;; -draw_rect 280 130 25 160;; - -(* A black rectangle after the green one, below the graph. *) -set_line_width lw;; -rlineto 50 0;; - -(* Write a text in yellow on a blue background. *) -(* x = 210, y = 70 *) -go_legend ();; -set_text_size 10;; -set_color (rgb 150 100 250);; -let x,y = current_point () in -fill_rect x (y - 5) (8 * 20) 25;; -set_color yellow;; -go_legend ();; -draw_string "Graphics (OCaml)";; - -(* Pie parts in different colors. *) -let draw_green_string s = set_color green; draw_string s;; -let draw_red_string s = set_color red; draw_string s;; - -moveto 120 210;; -set_color red;; -fill_arc 150 260 25 25 60 300; -draw_green_string "A "; -draw_red_string "red"; -draw_green_string " pie."; - -set_text_size 5; -moveto 180 240; -draw_red_string "A "; draw_green_string "green"; draw_red_string " slice.";; -set_color green; -fill_arc 200 260 25 25 0 60; -set_color black; -set_line_width 2; -draw_arc 200 260 27 27 0 60;; - -(* Should do nothing since this is a line *) -set_color red;; -fill_poly [| (40, 10); (150, 70); (150, 10); (40, 10) |];; -set_color blue;; - -(* Drawing polygones. *) -(* Redefining the draw_poly primitive for the usual library. *) -let draw_poly v = - let l = Array.length v in - if l > 0 then begin - let x0, y0 = current_point () in - let p0 = v.(0) in - let x, y = p0 in moveto x y; - for i = 1 to l - 1 do - let x, y = v.(i) in lineto x y - done; - lineto x y; - moveto x0 y0 - end;; - -draw_poly [| (150, 10); (150, 70); (260, 10); (150, 10) |];; - -(* Filling polygones. *) -(* Two equilateral triangles, one red and one blue, and their inside - filled in black. *) -let equi x y l = - [| (x - l / 2, y); - (x, y + int_of_float (float_of_int l *. (sqrt 3.0 /. 2.0))); - (x + l / 2, y) |];; - -set_color black;; -fill_poly (Array.append (equi 300 20 40) (equi 300 44 (- 40)));; - -set_line_width 1;; -set_color cyan;; -draw_poly (equi 300 20 40);; -set_color red;; -draw_poly (equi 300 44 (- 40));; - -(* Drawing and filling ellipses. *) -let x, y = current_point () in -rlineto 10 10; moveto x y; - -moveto 395 100;; - -let x, y = current_point () in -fill_ellipse x y 25 15;; - -set_color (rgb 0xFF 0x00 0xFF);; -rmoveto 0 (- 50);; - -let x, y = current_point () in -fill_ellipse x y 15 30;; - -rmoveto (- 45) 0;; -let x, y = current_point () in -draw_ellipse x y 25 10;; - -(* Drawing and filling arcs. *) - -let draw_arc_ellipse x y r1 r2 = - set_color green; - draw_arc x y r1 r2 60 120; - set_color black; - draw_arc x y r1 r2 120 420;; - -set_line_width 3;; - -let draw_arc_ellipses x y r1 r2 = - let step = 5 in - for i = 0 to (r1 - step) / (2 * step) do - for j = 0 to (r2 - step) / (2 * step) do - draw_arc_ellipse x y (3 * i * step) (3 * j * step) - done - done;; - -draw_arc_ellipses 20 128 15 50;; - -let fill_arc_ellipse x y r1 r2 c1 c2 = - set_color c1; - fill_arc x y r1 r2 60 120; - set_color c2; - fill_arc x y r1 r2 120 420;; - -let fill_arc_ellipses x y r1 r2 = - let step = 3 in - let c1 = ref black - and c2 = ref yellow in - let exchange r1 r2 = let tmp = !r1 in r1 := !r2; r2 := tmp in - for i = r1 / (2 * step) downto 10 do - for j = r2 / (2 * step) downto 30 do - exchange c1 c2; - fill_arc_ellipse x y (3 * i) (3 * j) !c1 !c2 - done - done;; - -fill_arc_ellipses 400 240 150 200;; - - -synchronize ();; - -(* transparent color drawing *) -set_color transp;; -draw_circle 400 240 50;; -draw_circle 400 240 40;; -draw_circle 400 240 30;; -(* try to go back a normal color *) -set_color red;; -draw_circle 400 240 20;; - -synchronize ();; - -ignore (wait_next_event [Key_pressed]) diff --git a/testsuite/interactive/lib-graph-2/graph_test.reference b/testsuite/interactive/lib-graph-2/graph_test.reference deleted file mode 100644 index e69de29b..00000000 diff --git a/testsuite/interactive/lib-graph-3/Makefile b/testsuite/interactive/lib-graph-3/Makefile deleted file mode 100644 index 7ac0c869..00000000 --- a/testsuite/interactive/lib-graph-3/Makefile +++ /dev/null @@ -1,23 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Clerc, SED, INRIA Rocquencourt * -#* * -#* Copyright 2010 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -BASEDIR=../.. -#MODULES= -MAIN_MODULE=sorts -ADD_COMPFLAGS=-I +threads -LIBRARIES=unix threads graphics - -include $(BASEDIR)/makefiles/Makefile.one -include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/interactive/lib-graph-3/sorts.ml b/testsuite/interactive/lib-graph-3/sorts.ml deleted file mode 100644 index 31a7bf86..00000000 --- a/testsuite/interactive/lib-graph-3/sorts.ml +++ /dev/null @@ -1,243 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Animation of sorting algorithms. *) - -open Graphics - -(* Information on a given sorting process *) - -type graphic_context = - { array: int array; (* Data to sort *) - x0: int; (* X coordinate, lower left corner *) - y0: int; (* Y coordinate, lower left corner *) - width: int; (* Width in pixels *) - height: int; (* Height in pixels *) - nelts: int; (* Number of elements in the array *) - maxval: int; (* Max val in the array + 1 *) - rad: int (* Dimension of the rectangles *) - } - -(* Array assignment and exchange with screen update *) - -let screen_mutex = Mutex.create() - -let draw gc i v = - fill_rect (gc.x0 + (gc.width * i) / gc.nelts) - (gc.y0 + (gc.height * v) / gc.maxval) - gc.rad gc.rad - -let assign gc i v = - Mutex.lock screen_mutex; - set_color background; draw gc i gc.array.(i); - set_color foreground; draw gc i v; - gc.array.(i) <- v; - Mutex.unlock screen_mutex - -let exchange gc i j = - let val_i = gc.array.(i) in - assign gc i gc.array.(j); - assign gc j val_i - -(* Construction of a graphic context *) - -let initialize name array maxval x y w h = - let (_, label_height) = text_size name in - let rad = (w - 2) / (Array.length array) - 1 in - let gc = - { array = Array.copy array; - x0 = x + 1; (* Leave one pixel left for Y axis *) - y0 = y + 1; (* Leave one pixel below for X axis *) - width = w - 2; (* 1 pixel left, 1 pixel right *) - height = h - 1 - label_height - rad; - nelts = Array.length array; - maxval = maxval; - rad = rad } in - moveto (gc.x0 - 1) (gc.y0 + gc.height); - lineto (gc.x0 - 1) (gc.y0 - 1); - lineto (gc.x0 + gc.width) (gc.y0 - 1); - moveto (gc.x0 - 1) (gc.y0 + gc.height); - draw_string name; - for i = 0 to Array.length array - 1 do - draw gc i array.(i) - done; - gc - -(* Main animation function *) - -let display functs nelts maxval = - let a = Array.make nelts 0 in - for i = 0 to nelts - 1 do - a.(i) <- Random.int maxval - done; - let num_finished = ref 0 in - let lock_finished = Mutex.create() in - let cond_finished = Condition.create() in - for i = 0 to Array.length functs - 1 do - let (name, funct, x, y, w, h) = functs.(i) in - let gc = initialize name a maxval x y w h in - Thread.create - (fun () -> - funct gc; - Mutex.lock lock_finished; - incr num_finished; - Mutex.unlock lock_finished; - Condition.signal cond_finished) - () - done; - Mutex.lock lock_finished; - while !num_finished < Array.length functs do - Condition.wait cond_finished lock_finished - done; - Mutex.unlock lock_finished; - read_key() - -(***** - let delay = ref 0 in - try - while true do - let gc = Queue.take q in - begin match gc.action with - Finished -> () - | Pause f -> - gc.action <- f (); - for i = 0 to !delay do () done; - Queue.add gc q - end; - if key_pressed() then begin - match read_key() with - 'q'|'Q' -> - raise Exit - | '0'..'9' as c -> - delay := (Char.code c - 48) * 500 - | _ -> - () - end - done - with Exit -> () - | Queue.Empty -> read_key(); () -*****) - -(* The sorting functions. *) - -(* Bubble sort *) - -let bubble_sort gc = - let ordered = ref false in - while not !ordered do - ordered := true; - for i = 0 to Array.length gc.array - 2 do - if gc.array.(i+1) < gc.array.(i) then begin - exchange gc i (i+1); - ordered := false - end - done - done - -(* Insertion sort *) - -let insertion_sort gc = - for i = 1 to Array.length gc.array - 1 do - let val_i = gc.array.(i) in - let j = ref (i - 1) in - while !j >= 0 && val_i < gc.array.(!j) do - assign gc (!j + 1) gc.array.(!j); - decr j - done; - assign gc (!j + 1) val_i - done - -(* Selection sort *) - -let selection_sort gc = - for i = 0 to Array.length gc.array - 1 do - let min = ref i in - for j = i+1 to Array.length gc.array - 1 do - if gc.array.(j) < gc.array.(!min) then min := j - done; - exchange gc i !min - done - -(* Quick sort *) - -let quick_sort gc = - let rec quick lo hi = - if lo < hi then begin - let i = ref lo in - let j = ref hi in - let pivot = gc.array.(hi) in - while !i < !j do - while !i < hi && gc.array.(!i) <= pivot do incr i done; - while !j > lo && gc.array.(!j) >= pivot do decr j done; - if !i < !j then exchange gc !i !j - done; - exchange gc !i hi; - quick lo (!i-1); - quick (!i+1) hi - end - in quick 0 (Array.length gc.array - 1) - -(* Merge sort *) - -let merge_sort gc = - let rec merge i l1 l2 = - match (l1, l2) with - ([], []) -> - () - | ([], v2::r2) -> - assign gc i v2; merge (i+1) l1 r2 - | (v1::r1, []) -> - assign gc i v1; merge (i+1) r1 l2 - | (v1::r1, v2::r2) -> - if v1 < v2 - then begin assign gc i v1; merge (i+1) r1 l2 end - else begin assign gc i v2; merge (i+1) l1 r2 end in - let rec msort start len = - if len < 2 then () else begin - let m = len / 2 in - msort start m; - msort (start+m) (len-m); - merge start - (Array.to_list (Array.sub gc.array start m)) - (Array.to_list (Array.sub gc.array (start+m) (len-m))) - end in - msort 0 (Array.length gc.array) - -(* Main program *) - -let animate() = - open_graph ""; - moveto 0 0; draw_string "Press a key to start..."; - let seed = ref 0 in - while not (key_pressed()) do incr seed done; - read_key(); - Random.init !seed; - clear_graph(); - let prompt = "0: fastest ... 9: slowest, press 'q' to quit" in - moveto 0 0; draw_string prompt; - let (_, h) = text_size prompt in - let sx = size_x() / 2 and sy = (size_y() - h) / 3 in - display [| "Bubble", bubble_sort, 0, h, sx, sy; - "Insertion", insertion_sort, 0, h+sy, sx, sy; - "Selection", selection_sort, 0, h+2*sy, sx, sy; - "Quicksort", quick_sort, sx, h, sx, sy; - (** "Heapsort", heap_sort, sx, h+sy, sx, sy; **) - "Mergesort", merge_sort, sx, h+2*sy, sx, sy |] - 100 1000; - close_graph() - -let _ = if !Sys.interactive then () else begin animate(); exit 0 end - -;; diff --git a/testsuite/interactive/lib-graph-3/sorts.reference b/testsuite/interactive/lib-graph-3/sorts.reference deleted file mode 100644 index e69de29b..00000000 diff --git a/testsuite/interactive/lib-graph/Makefile b/testsuite/interactive/lib-graph/Makefile deleted file mode 100644 index 64557c70..00000000 --- a/testsuite/interactive/lib-graph/Makefile +++ /dev/null @@ -1,23 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Clerc, SED, INRIA Rocquencourt * -#* * -#* Copyright 2010 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -BASEDIR=../.. -#MODULES= -MAIN_MODULE=graph_example -#ADD_COMPFLAGS= -LIBRARIES=graphics - -include $(BASEDIR)/makefiles/Makefile.one -include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/interactive/lib-graph/graph_example.ml b/testsuite/interactive/lib-graph/graph_example.ml deleted file mode 100644 index 15256676..00000000 --- a/testsuite/interactive/lib-graph/graph_example.ml +++ /dev/null @@ -1,146 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Damien Doligez, projet Para, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* To run this example: - ******************** - 1. Select all the text in this window. - 2. Drag it to the toplevel window. - 3. Watch the colors. - 4. Drag the mouse over the graphics window and click here and there. - 5. Type any key to the graphics window to stop the program. -*) - -open Graphics;; -open_graph " 480x270";; - -let xr = size_x () / 2 - 30 -and yr = size_y () / 2 - 26 -and xg = size_x () / 2 + 30 -and yg = size_y () / 2 - 26 -and xb = size_x () / 2 -and yb = size_y () / 2 + 26 -;; - -let point x y = - let dr = (x-xr)*(x-xr) + (y-yr)*(y-yr) - and dg = (x-xg)*(x-xg) + (y-yg)*(y-yg) - and db = (x-xb)*(x-xb) + (y-yb)*(y-yb) - in - if dr > dg && dr > db then set_color (rgb 255 (255*dg/dr) (255*db/dr)) - else if dg > db then set_color (rgb (255*dr/dg) 255 (255*db/dg)) - else set_color (rgb (255*dr/db) (255*dg/db) 255); - fill_rect x y 2 2; -;; - -for y = (size_y () - 1) / 2 downto 0 do - for x = 0 to (size_x () - 1) / 2 do - point (2*x) (2*y); - done -done -;; - -let n = 0x000000 -and w = 0xFFFFFF -and b = 0xFFCC99 -and y = 0xFFFF00 -and o = 0xCC9966 -and v = 0x00BB00 -and g = 0x888888 -and c = 0xDDDDDD -and t = transp -;; - -let caml = make_image [| - [|t;t;t;t;t;t;t;t;t;t;t;n;n;n;n;n;n;t;t;t;t;t;t;t;t;t;t;t;t;t;t;t;|]; - [|t;t;t;t;t;t;t;t;t;t;n;n;n;n;n;n;n;n;n;t;t;t;t;t;t;t;t;t;t;t;t;t;|]; - [|t;t;t;t;t;t;t;t;n;n;n;n;n;n;n;n;n;n;n;n;t;t;t;t;t;t;t;t;t;t;t;t;|]; - [|n;n;n;n;n;n;t;n;n;n;n;n;b;b;b;b;b;b;b;n;n;t;t;t;t;t;n;n;n;n;n;t;|]; - [|n;o;o;o;o;o;n;n;n;n;b;b;b;b;b;b;b;b;b;b;b;n;n;n;n;n;n;n;n;n;n;t;|]; - [|n;o;o;o;o;o;o;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;t;|]; - [|n;o;o;o;o;o;o;o;n;n;n;g;g;g;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;t;t;|]; - [|n;n;o;o;o;o;o;o;o;n;n;n;c;c;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;t;t;|]; - [|t;n;n;o;o;o;o;o;o;o;n;n;n;c;n;n;n;n;n;n;n;b;b;n;n;n;n;n;n;t;t;t;|]; - [|t;t;n;n;n;o;o;o;o;o;o;n;n;n;n;n;n;n;n;n;b;b;b;b;n;n;n;n;t;t;t;t;|]; - [|t;t;t;t;n;n;o;o;o;o;o;o;n;n;n;n;n;n;n;n;b;b;b;b;b;b;n;n;t;t;t;t;|]; - [|t;t;t;t;t;n;n;o;o;o;o;o;o;n;n;n;n;n;n;o;o;b;b;b;b;b;b;n;n;t;t;t;|]; - [|t;t;t;t;t;n;n;o;o;o;o;o;o;b;b;b;b;b;n;n;o;o;b;b;b;b;b;b;n;n;t;t;|]; - [|t;t;t;t;n;n;n;o;o;o;o;o;b;b;b;b;b;b;b;n;n;o;o;b;b;b;b;b;b;n;n;t;|]; - [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;b;b;b;b;n;n;o;o;b;b;b;b;b;b;n;n;|]; - [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;n;n;b;b;b;n;n;o;o;b;b;b;b;b;n;n;|]; - [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;n;n;b;b;b;b;n;n;o;o;b;o;b;b;n;n;|]; - [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;n;n;b;b;b;b;b;n;n;o;o;o;o;o;n;n;|]; - [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;n;n;b;b;b;b;b;b;n;n;o;o;o;o;n;n;|]; - [|t;t;t;t;n;n;n;o;o;o;o;o;b;b;b;b;n;n;b;b;b;b;b;b;b;n;n;o;o;n;n;n;|]; - [|t;t;t;t;n;n;n;n;o;o;o;o;o;b;b;b;n;n;n;b;b;b;b;b;b;b;n;n;o;n;b;n;|]; - [|t;t;t;t;t;n;n;n;o;o;o;o;o;o;b;b;n;n;n;b;b;b;b;b;b;b;b;n;n;n;b;n;|]; - [|t;t;t;t;t;t;n;n;o;o;o;o;o;o;o;y;v;y;n;b;b;b;b;b;b;b;b;n;n;b;b;n;|]; - [|t;t;t;t;t;t;t;n;o;o;o;o;o;v;y;o;o;n;n;n;b;b;b;b;b;b;b;n;n;b;b;n;|]; - [|t;t;t;t;t;t;t;n;o;o;o;y;v;o;o;o;o;n;n;n;n;b;b;b;b;b;b;n;n;b;b;n;|]; - [|t;t;t;t;t;t;n;n;o;v;y;o;y;o;o;o;o;o;o;n;n;n;b;b;b;b;b;n;n;b;b;n;|]; - [|t;t;t;t;t;t;n;o;y;y;o;o;v;o;o;o;o;o;o;o;n;n;n;b;b;b;n;n;n;b;n;t;|]; - [|t;t;t;t;t;n;n;v;o;v;o;o;o;o;o;o;o;o;o;o;o;n;n;n;b;n;n;n;n;b;n;t;|]; - [|t;t;t;t;t;n;v;o;o;v;o;o;o;o;o;o;o;o;o;o;o;o;n;n;n;n;n;n;n;n;t;t;|]; - [|t;t;t;t;n;n;o;o;o;o;o;o;o;o;o;o;o;o;o;o;o;n;n;n;n;n;n;t;t;t;t;t;|]; - [|t;t;t;t;n;o;o;o;o;o;o;o;o;o;o;o;o;o;o;o;n;n;t;t;t;t;t;t;t;t;t;t;|]; - [|t;t;t;t;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;t;t;t;t;t;t;t;t;t;t;t;|]; -|];; - -(* -let x = ref 0 and y = ref 0;; -let bg = get_image !x !y 32 32;; -while true do - let st = wait_next_event [Mouse_motion; Button_down] in - if not st.button then draw_image bg !x !y; - x := st.mouse_x; - y := st.mouse_y; - blit_image bg !x !y; - draw_image caml !x !y; -done;; -*) -set_color (rgb 0 0 0); -remember_mode false; -try while true do - let st = wait_next_event [Mouse_motion; Button_down; Key_pressed] in - synchronize (); - if st.keypressed then raise Exit; - if st.button then begin - remember_mode true; - draw_image caml st.mouse_x st.mouse_y; - remember_mode false; - end; - let x = st.mouse_x + 16 and y = st.mouse_y + 16 in - - moveto 0 y; - lineto (x - 25) y; - moveto 10000 y; - lineto (x + 25) y; - - moveto x 0; - lineto x (y - 25); - moveto x 10000; - lineto x (y + 25); - - draw_image caml st.mouse_x st.mouse_y; -done with Exit -> () -;; - -(* To run this example: - ******************** - 1. Select all the text in this window. - 2. Drag it to the toplevel window. - 3. Watch the colors. - 4. Drag the mouse over the graphics window and click here and there. - 5. Type any key to the graphics window to stop the program. -*) diff --git a/testsuite/interactive/lib-graph/graph_example.reference b/testsuite/interactive/lib-graph/graph_example.reference deleted file mode 100644 index e69de29b..00000000 diff --git a/testsuite/tests/arch-power/exn_raise.ml b/testsuite/tests/arch-power/exn_raise.ml new file mode 100644 index 00000000..a68eb875 --- /dev/null +++ b/testsuite/tests/arch-power/exn_raise.ml @@ -0,0 +1,19 @@ +(* TEST + * arch_power + ** native + *** ocamlopt.byte + ocamlopt_flags = "-flarge-toc" + **** run +*) + +(* GPR#8506 + + This isn't guaranteed to fail even without the fix from #8506, because + the @ha relocation on the TOC entry for the exception handler's address + might be zero, in which case the linker optimises the code sequence to one + that will not fail. +*) + +let () = + try failwith "foo" + with (Failure _) -> () diff --git a/testsuite/tests/arch-power/exn_raise.reference b/testsuite/tests/arch-power/exn_raise.reference new file mode 100644 index 00000000..e69de29b diff --git a/testsuite/tests/arch-power/ocamltests b/testsuite/tests/arch-power/ocamltests new file mode 100644 index 00000000..03fa29c9 --- /dev/null +++ b/testsuite/tests/arch-power/ocamltests @@ -0,0 +1 @@ +exn_raise.ml diff --git a/testsuite/tests/asmgen/catch-multiple.cmm b/testsuite/tests/asmgen/catch-multiple.cmm new file mode 100644 index 00000000..1510fcea --- /dev/null +++ b/testsuite/tests/asmgen/catch-multiple.cmm @@ -0,0 +1,20 @@ +(* TEST +files = "main.c" +arguments = "-DINT_INT -DFUN=catch_multiple main.c" +* asmgen +*) + +(* +Expected output: +catch_multiple(0) == -1 +catch_multiple(1) == 1 +*) + +(function "catch_multiple" (b:int) + (let x + (catch + (if (== b 0) (exit zero) + (exit other)) + with (zero) -1 + and (other) ( * b b)) + x)) diff --git a/testsuite/tests/asmgen/ocamltests b/testsuite/tests/asmgen/ocamltests index e0edd3ae..06e3fe0a 100644 --- a/testsuite/tests/asmgen/ocamltests +++ b/testsuite/tests/asmgen/ocamltests @@ -2,6 +2,7 @@ arith.cmm catch-rec.cmm catch-try.cmm catch-float.cmm +catch-multiple.cmm catch-try-float.cmm checkbound.cmm even-odd-spill.cmm diff --git a/testsuite/tests/backtrace/backtrace2.byte.reference b/testsuite/tests/backtrace/backtrace2.byte.reference index 36465dc0..296d4328 100644 --- a/testsuite/tests/backtrace/backtrace2.byte.reference +++ b/testsuite/tests/backtrace/backtrace2.byte.reference @@ -46,13 +46,13 @@ Called from file "backtrace2.ml", line 52, characters 43-52 Called from file "backtrace2.ml", line 52, characters 43-52 Called from file "backtrace2.ml", line 52, characters 43-52 Called from file "backtrace2.ml", line 52, characters 43-52 -Called from file "camlinternalLazy.ml", line 29, characters 17-27 +Called from file "camlinternalLazy.ml", line 31, characters 17-27 Re-raised at file "camlinternalLazy.ml", line 36, characters 10-11 Called from file "backtrace2.ml", line 67, characters 11-23 Uncaught exception Not_found Raised at file "hashtbl.ml", line 194, characters 19-28 Called from file "backtrace2.ml", line 55, characters 8-41 Re-raised at file "camlinternalLazy.ml", line 35, characters 62-63 -Called from file "camlinternalLazy.ml", line 29, characters 17-27 +Called from file "camlinternalLazy.ml", line 31, characters 17-27 Re-raised at file "camlinternalLazy.ml", line 36, characters 10-11 Called from file "backtrace2.ml", line 67, characters 11-23 diff --git a/testsuite/tests/backtrace/backtrace2.opt.reference b/testsuite/tests/backtrace/backtrace2.opt.reference index c0b9816b..2c246e2d 100644 --- a/testsuite/tests/backtrace/backtrace2.opt.reference +++ b/testsuite/tests/backtrace/backtrace2.opt.reference @@ -46,13 +46,13 @@ Called from file "backtrace2.ml", line 52, characters 43-52 Called from file "backtrace2.ml", line 52, characters 43-52 Called from file "backtrace2.ml", line 52, characters 43-52 Called from file "backtrace2.ml", line 52, characters 43-52 -Called from file "camlinternalLazy.ml", line 29, characters 17-27 +Called from file "camlinternalLazy.ml", line 31, characters 17-27 Re-raised at file "camlinternalLazy.ml", line 36, characters 4-11 Called from file "backtrace2.ml", line 67, characters 11-23 Uncaught exception Not_found Raised at file "hashtbl.ml", line 194, characters 13-28 Called from file "backtrace2.ml", line 55, characters 8-41 Re-raised at file "camlinternalLazy.ml", line 35, characters 56-63 -Called from file "camlinternalLazy.ml", line 29, characters 17-27 +Called from file "camlinternalLazy.ml", line 31, characters 17-27 Re-raised at file "camlinternalLazy.ml", line 36, characters 4-11 Called from file "backtrace2.ml", line 67, characters 11-23 diff --git a/testsuite/tests/basic-float/float_literals.ml b/testsuite/tests/basic-float/float_literals.ml new file mode 100644 index 00000000..3d1f12ad --- /dev/null +++ b/testsuite/tests/basic-float/float_literals.ml @@ -0,0 +1,285 @@ +(* TEST *) + +open Printf + +(* By making the field "f" mutable, we prevent the creation of structured + constants and force the FP values to be loaded in an FP register, + then stored in memory and passed to the "test" function. *) + +type t = { mutable f : float } + +let test x y = + if Int64.bits_of_float x.f <> y then + printf "Error: bits_of_float %h <> 0x%Lx\n" x.f y +[@@inline never] + +(* The values tested include + - those that are loaded by special x87 instructions on i386: + +0.0, -0.0, +1.0, -1.0 + - those that are loaded by xorpd on amd64: + +0.0; + - those that are loaded by "fmov immediate" on arm64: + see list below +*) +let _ = + test { f = 0.0 } 0L; + test { f = (-0.0) } 0x8000000000000000L; + (* The following are the "fmov immediate" of arm64 *) + (* They include +1.0 and -1.0 *) + test { f = 0x1p-3 } 0x3fc0000000000000L; + test { f = 0x1.1p-3 } 0x3fc1000000000000L; + test { f = 0x1.2p-3 } 0x3fc2000000000000L; + test { f = 0x1.3p-3 } 0x3fc3000000000000L; + test { f = 0x1.4p-3 } 0x3fc4000000000000L; + test { f = 0x1.5p-3 } 0x3fc5000000000000L; + test { f = 0x1.6p-3 } 0x3fc6000000000000L; + test { f = 0x1.7p-3 } 0x3fc7000000000000L; + test { f = 0x1.8p-3 } 0x3fc8000000000000L; + test { f = 0x1.9p-3 } 0x3fc9000000000000L; + test { f = 0x1.ap-3 } 0x3fca000000000000L; + test { f = 0x1.bp-3 } 0x3fcb000000000000L; + test { f = 0x1.cp-3 } 0x3fcc000000000000L; + test { f = 0x1.dp-3 } 0x3fcd000000000000L; + test { f = 0x1.ep-3 } 0x3fce000000000000L; + test { f = 0x1.fp-3 } 0x3fcf000000000000L; + test { f = 0x1p-2 } 0x3fd0000000000000L; + test { f = 0x1.1p-2 } 0x3fd1000000000000L; + test { f = 0x1.2p-2 } 0x3fd2000000000000L; + test { f = 0x1.3p-2 } 0x3fd3000000000000L; + test { f = 0x1.4p-2 } 0x3fd4000000000000L; + test { f = 0x1.5p-2 } 0x3fd5000000000000L; + test { f = 0x1.6p-2 } 0x3fd6000000000000L; + test { f = 0x1.7p-2 } 0x3fd7000000000000L; + test { f = 0x1.8p-2 } 0x3fd8000000000000L; + test { f = 0x1.9p-2 } 0x3fd9000000000000L; + test { f = 0x1.ap-2 } 0x3fda000000000000L; + test { f = 0x1.bp-2 } 0x3fdb000000000000L; + test { f = 0x1.cp-2 } 0x3fdc000000000000L; + test { f = 0x1.dp-2 } 0x3fdd000000000000L; + test { f = 0x1.ep-2 } 0x3fde000000000000L; + test { f = 0x1.fp-2 } 0x3fdf000000000000L; + test { f = 0x1p-1 } 0x3fe0000000000000L; + test { f = 0x1.1p-1 } 0x3fe1000000000000L; + test { f = 0x1.2p-1 } 0x3fe2000000000000L; + test { f = 0x1.3p-1 } 0x3fe3000000000000L; + test { f = 0x1.4p-1 } 0x3fe4000000000000L; + test { f = 0x1.5p-1 } 0x3fe5000000000000L; + test { f = 0x1.6p-1 } 0x3fe6000000000000L; + test { f = 0x1.7p-1 } 0x3fe7000000000000L; + test { f = 0x1.8p-1 } 0x3fe8000000000000L; + test { f = 0x1.9p-1 } 0x3fe9000000000000L; + test { f = 0x1.ap-1 } 0x3fea000000000000L; + test { f = 0x1.bp-1 } 0x3feb000000000000L; + test { f = 0x1.cp-1 } 0x3fec000000000000L; + test { f = 0x1.dp-1 } 0x3fed000000000000L; + test { f = 0x1.ep-1 } 0x3fee000000000000L; + test { f = 0x1.fp-1 } 0x3fef000000000000L; + test { f = 0x1p+0 } 0x3ff0000000000000L; + test { f = 0x1.1p+0 } 0x3ff1000000000000L; + test { f = 0x1.2p+0 } 0x3ff2000000000000L; + test { f = 0x1.3p+0 } 0x3ff3000000000000L; + test { f = 0x1.4p+0 } 0x3ff4000000000000L; + test { f = 0x1.5p+0 } 0x3ff5000000000000L; + test { f = 0x1.6p+0 } 0x3ff6000000000000L; + test { f = 0x1.7p+0 } 0x3ff7000000000000L; + test { f = 0x1.8p+0 } 0x3ff8000000000000L; + test { f = 0x1.9p+0 } 0x3ff9000000000000L; + test { f = 0x1.ap+0 } 0x3ffa000000000000L; + test { f = 0x1.bp+0 } 0x3ffb000000000000L; + test { f = 0x1.cp+0 } 0x3ffc000000000000L; + test { f = 0x1.dp+0 } 0x3ffd000000000000L; + test { f = 0x1.ep+0 } 0x3ffe000000000000L; + test { f = 0x1.fp+0 } 0x3fff000000000000L; + test { f = 0x1p+1 } 0x4000000000000000L; + test { f = 0x1.1p+1 } 0x4001000000000000L; + test { f = 0x1.2p+1 } 0x4002000000000000L; + test { f = 0x1.3p+1 } 0x4003000000000000L; + test { f = 0x1.4p+1 } 0x4004000000000000L; + test { f = 0x1.5p+1 } 0x4005000000000000L; + test { f = 0x1.6p+1 } 0x4006000000000000L; + test { f = 0x1.7p+1 } 0x4007000000000000L; + test { f = 0x1.8p+1 } 0x4008000000000000L; + test { f = 0x1.9p+1 } 0x4009000000000000L; + test { f = 0x1.ap+1 } 0x400a000000000000L; + test { f = 0x1.bp+1 } 0x400b000000000000L; + test { f = 0x1.cp+1 } 0x400c000000000000L; + test { f = 0x1.dp+1 } 0x400d000000000000L; + test { f = 0x1.ep+1 } 0x400e000000000000L; + test { f = 0x1.fp+1 } 0x400f000000000000L; + test { f = 0x1p+2 } 0x4010000000000000L; + test { f = 0x1.1p+2 } 0x4011000000000000L; + test { f = 0x1.2p+2 } 0x4012000000000000L; + test { f = 0x1.3p+2 } 0x4013000000000000L; + test { f = 0x1.4p+2 } 0x4014000000000000L; + test { f = 0x1.5p+2 } 0x4015000000000000L; + test { f = 0x1.6p+2 } 0x4016000000000000L; + test { f = 0x1.7p+2 } 0x4017000000000000L; + test { f = 0x1.8p+2 } 0x4018000000000000L; + test { f = 0x1.9p+2 } 0x4019000000000000L; + test { f = 0x1.ap+2 } 0x401a000000000000L; + test { f = 0x1.bp+2 } 0x401b000000000000L; + test { f = 0x1.cp+2 } 0x401c000000000000L; + test { f = 0x1.dp+2 } 0x401d000000000000L; + test { f = 0x1.ep+2 } 0x401e000000000000L; + test { f = 0x1.fp+2 } 0x401f000000000000L; + test { f = 0x1p+3 } 0x4020000000000000L; + test { f = 0x1.1p+3 } 0x4021000000000000L; + test { f = 0x1.2p+3 } 0x4022000000000000L; + test { f = 0x1.3p+3 } 0x4023000000000000L; + test { f = 0x1.4p+3 } 0x4024000000000000L; + test { f = 0x1.5p+3 } 0x4025000000000000L; + test { f = 0x1.6p+3 } 0x4026000000000000L; + test { f = 0x1.7p+3 } 0x4027000000000000L; + test { f = 0x1.8p+3 } 0x4028000000000000L; + test { f = 0x1.9p+3 } 0x4029000000000000L; + test { f = 0x1.ap+3 } 0x402a000000000000L; + test { f = 0x1.bp+3 } 0x402b000000000000L; + test { f = 0x1.cp+3 } 0x402c000000000000L; + test { f = 0x1.dp+3 } 0x402d000000000000L; + test { f = 0x1.ep+3 } 0x402e000000000000L; + test { f = 0x1.fp+3 } 0x402f000000000000L; + test { f = 0x1p+4 } 0x4030000000000000L; + test { f = 0x1.1p+4 } 0x4031000000000000L; + test { f = 0x1.2p+4 } 0x4032000000000000L; + test { f = 0x1.3p+4 } 0x4033000000000000L; + test { f = 0x1.4p+4 } 0x4034000000000000L; + test { f = 0x1.5p+4 } 0x4035000000000000L; + test { f = 0x1.6p+4 } 0x4036000000000000L; + test { f = 0x1.7p+4 } 0x4037000000000000L; + test { f = 0x1.8p+4 } 0x4038000000000000L; + test { f = 0x1.9p+4 } 0x4039000000000000L; + test { f = 0x1.ap+4 } 0x403a000000000000L; + test { f = 0x1.bp+4 } 0x403b000000000000L; + test { f = 0x1.cp+4 } 0x403c000000000000L; + test { f = 0x1.dp+4 } 0x403d000000000000L; + test { f = 0x1.ep+4 } 0x403e000000000000L; + test { f = 0x1.fp+4 } 0x403f000000000000L; + test { f = (-0x1p-3) } 0xbfc0000000000000L; + test { f = (-0x1.1p-3) } 0xbfc1000000000000L; + test { f = (-0x1.2p-3) } 0xbfc2000000000000L; + test { f = (-0x1.3p-3) } 0xbfc3000000000000L; + test { f = (-0x1.4p-3) } 0xbfc4000000000000L; + test { f = (-0x1.5p-3) } 0xbfc5000000000000L; + test { f = (-0x1.6p-3) } 0xbfc6000000000000L; + test { f = (-0x1.7p-3) } 0xbfc7000000000000L; + test { f = (-0x1.8p-3) } 0xbfc8000000000000L; + test { f = (-0x1.9p-3) } 0xbfc9000000000000L; + test { f = (-0x1.ap-3) } 0xbfca000000000000L; + test { f = (-0x1.bp-3) } 0xbfcb000000000000L; + test { f = (-0x1.cp-3) } 0xbfcc000000000000L; + test { f = (-0x1.dp-3) } 0xbfcd000000000000L; + test { f = (-0x1.ep-3) } 0xbfce000000000000L; + test { f = (-0x1.fp-3) } 0xbfcf000000000000L; + test { f = (-0x1p-2) } 0xbfd0000000000000L; + test { f = (-0x1.1p-2) } 0xbfd1000000000000L; + test { f = (-0x1.2p-2) } 0xbfd2000000000000L; + test { f = (-0x1.3p-2) } 0xbfd3000000000000L; + test { f = (-0x1.4p-2) } 0xbfd4000000000000L; + test { f = (-0x1.5p-2) } 0xbfd5000000000000L; + test { f = (-0x1.6p-2) } 0xbfd6000000000000L; + test { f = (-0x1.7p-2) } 0xbfd7000000000000L; + test { f = (-0x1.8p-2) } 0xbfd8000000000000L; + test { f = (-0x1.9p-2) } 0xbfd9000000000000L; + test { f = (-0x1.ap-2) } 0xbfda000000000000L; + test { f = (-0x1.bp-2) } 0xbfdb000000000000L; + test { f = (-0x1.cp-2) } 0xbfdc000000000000L; + test { f = (-0x1.dp-2) } 0xbfdd000000000000L; + test { f = (-0x1.ep-2) } 0xbfde000000000000L; + test { f = (-0x1.fp-2) } 0xbfdf000000000000L; + test { f = (-0x1p-1) } 0xbfe0000000000000L; + test { f = (-0x1.1p-1) } 0xbfe1000000000000L; + test { f = (-0x1.2p-1) } 0xbfe2000000000000L; + test { f = (-0x1.3p-1) } 0xbfe3000000000000L; + test { f = (-0x1.4p-1) } 0xbfe4000000000000L; + test { f = (-0x1.5p-1) } 0xbfe5000000000000L; + test { f = (-0x1.6p-1) } 0xbfe6000000000000L; + test { f = (-0x1.7p-1) } 0xbfe7000000000000L; + test { f = (-0x1.8p-1) } 0xbfe8000000000000L; + test { f = (-0x1.9p-1) } 0xbfe9000000000000L; + test { f = (-0x1.ap-1) } 0xbfea000000000000L; + test { f = (-0x1.bp-1) } 0xbfeb000000000000L; + test { f = (-0x1.cp-1) } 0xbfec000000000000L; + test { f = (-0x1.dp-1) } 0xbfed000000000000L; + test { f = (-0x1.ep-1) } 0xbfee000000000000L; + test { f = (-0x1.fp-1) } 0xbfef000000000000L; + test { f = (-0x1p+0) } 0xbff0000000000000L; + test { f = (-0x1.1p+0) } 0xbff1000000000000L; + test { f = (-0x1.2p+0) } 0xbff2000000000000L; + test { f = (-0x1.3p+0) } 0xbff3000000000000L; + test { f = (-0x1.4p+0) } 0xbff4000000000000L; + test { f = (-0x1.5p+0) } 0xbff5000000000000L; + test { f = (-0x1.6p+0) } 0xbff6000000000000L; + test { f = (-0x1.7p+0) } 0xbff7000000000000L; + test { f = (-0x1.8p+0) } 0xbff8000000000000L; + test { f = (-0x1.9p+0) } 0xbff9000000000000L; + test { f = (-0x1.ap+0) } 0xbffa000000000000L; + test { f = (-0x1.bp+0) } 0xbffb000000000000L; + test { f = (-0x1.cp+0) } 0xbffc000000000000L; + test { f = (-0x1.dp+0) } 0xbffd000000000000L; + test { f = (-0x1.ep+0) } 0xbffe000000000000L; + test { f = (-0x1.fp+0) } 0xbfff000000000000L; + test { f = (-0x1p+1) } 0xc000000000000000L; + test { f = (-0x1.1p+1) } 0xc001000000000000L; + test { f = (-0x1.2p+1) } 0xc002000000000000L; + test { f = (-0x1.3p+1) } 0xc003000000000000L; + test { f = (-0x1.4p+1) } 0xc004000000000000L; + test { f = (-0x1.5p+1) } 0xc005000000000000L; + test { f = (-0x1.6p+1) } 0xc006000000000000L; + test { f = (-0x1.7p+1) } 0xc007000000000000L; + test { f = (-0x1.8p+1) } 0xc008000000000000L; + test { f = (-0x1.9p+1) } 0xc009000000000000L; + test { f = (-0x1.ap+1) } 0xc00a000000000000L; + test { f = (-0x1.bp+1) } 0xc00b000000000000L; + test { f = (-0x1.cp+1) } 0xc00c000000000000L; + test { f = (-0x1.dp+1) } 0xc00d000000000000L; + test { f = (-0x1.ep+1) } 0xc00e000000000000L; + test { f = (-0x1.fp+1) } 0xc00f000000000000L; + test { f = (-0x1p+2) } 0xc010000000000000L; + test { f = (-0x1.1p+2) } 0xc011000000000000L; + test { f = (-0x1.2p+2) } 0xc012000000000000L; + test { f = (-0x1.3p+2) } 0xc013000000000000L; + test { f = (-0x1.4p+2) } 0xc014000000000000L; + test { f = (-0x1.5p+2) } 0xc015000000000000L; + test { f = (-0x1.6p+2) } 0xc016000000000000L; + test { f = (-0x1.7p+2) } 0xc017000000000000L; + test { f = (-0x1.8p+2) } 0xc018000000000000L; + test { f = (-0x1.9p+2) } 0xc019000000000000L; + test { f = (-0x1.ap+2) } 0xc01a000000000000L; + test { f = (-0x1.bp+2) } 0xc01b000000000000L; + test { f = (-0x1.cp+2) } 0xc01c000000000000L; + test { f = (-0x1.dp+2) } 0xc01d000000000000L; + test { f = (-0x1.ep+2) } 0xc01e000000000000L; + test { f = (-0x1.fp+2) } 0xc01f000000000000L; + test { f = (-0x1p+3) } 0xc020000000000000L; + test { f = (-0x1.1p+3) } 0xc021000000000000L; + test { f = (-0x1.2p+3) } 0xc022000000000000L; + test { f = (-0x1.3p+3) } 0xc023000000000000L; + test { f = (-0x1.4p+3) } 0xc024000000000000L; + test { f = (-0x1.5p+3) } 0xc025000000000000L; + test { f = (-0x1.6p+3) } 0xc026000000000000L; + test { f = (-0x1.7p+3) } 0xc027000000000000L; + test { f = (-0x1.8p+3) } 0xc028000000000000L; + test { f = (-0x1.9p+3) } 0xc029000000000000L; + test { f = (-0x1.ap+3) } 0xc02a000000000000L; + test { f = (-0x1.bp+3) } 0xc02b000000000000L; + test { f = (-0x1.cp+3) } 0xc02c000000000000L; + test { f = (-0x1.dp+3) } 0xc02d000000000000L; + test { f = (-0x1.ep+3) } 0xc02e000000000000L; + test { f = (-0x1.fp+3) } 0xc02f000000000000L; + test { f = (-0x1p+4) } 0xc030000000000000L; + test { f = (-0x1.1p+4) } 0xc031000000000000L; + test { f = (-0x1.2p+4) } 0xc032000000000000L; + test { f = (-0x1.3p+4) } 0xc033000000000000L; + test { f = (-0x1.4p+4) } 0xc034000000000000L; + test { f = (-0x1.5p+4) } 0xc035000000000000L; + test { f = (-0x1.6p+4) } 0xc036000000000000L; + test { f = (-0x1.7p+4) } 0xc037000000000000L; + test { f = (-0x1.8p+4) } 0xc038000000000000L; + test { f = (-0x1.9p+4) } 0xc039000000000000L; + test { f = (-0x1.ap+4) } 0xc03a000000000000L; + test { f = (-0x1.bp+4) } 0xc03b000000000000L; + test { f = (-0x1.cp+4) } 0xc03c000000000000L; + test { f = (-0x1.dp+4) } 0xc03d000000000000L; + test { f = (-0x1.ep+4) } 0xc03e000000000000L; + test { f = (-0x1.fp+4) } 0xc03f000000000000L; + () diff --git a/testsuite/tests/basic-float/ocamltests b/testsuite/tests/basic-float/ocamltests index 045a24cc..c2fc78d5 100644 --- a/testsuite/tests/basic-float/ocamltests +++ b/testsuite/tests/basic-float/ocamltests @@ -1,3 +1,4 @@ tfloat_hex.ml tfloat_record.ml zero_sized_float_arrays.ml +float_literals.ml diff --git a/testsuite/tests/basic-float/tfloat_hex.ml b/testsuite/tests/basic-float/tfloat_hex.ml index 5d7664c9..3fee64cd 100644 --- a/testsuite/tests/basic-float/tfloat_hex.ml +++ b/testsuite/tests/basic-float/tfloat_hex.ml @@ -20,3 +20,37 @@ let () = try_float_of_string "0x1.0p-2147483648"; try_float_of_string "0x123456789ABCDEF0p2147483647"; try_float_of_string "0x1p2147483648"; + + (* Allow underscore almost everywhere *) + try_float_of_string "_0x1.1"; + try_float_of_string "0_x1.1"; + try_float_of_string "0x_1.1"; + try_float_of_string "0x1_.1"; + try_float_of_string "0x1._"; + try_float_of_string "0x1.1_"; + try_float_of_string "0x1_p1"; + try_float_of_string "0x1p_1"; + try_float_of_string "0x1p1_"; + try_float_of_string "0x1p-1_1"; + try_float_of_string "0x1p-1_"; + try_float_of_string "0x1p+1_1"; + try_float_of_string "0x1p+1_"; + + try_float_of_string "0x1p1\000suffix" + +let () = + (* check that the compiler can also parse tokens *) + let _ = 0x1A in + let _ = 0x1Ap3 in + + let _ = 0x1.0p-2147483648 in + let _ = 0x123456789ABCDEF0p2147483647 in + let _ = 0x1p2147483648 in + + let _ = 0x1_._1p1_1 in + let _ = 0x1_._1p1_ in + let _ = 0x1_._1p-1_1 in + let _ = 0x1_._1p-1_ in + let _ = 0x1_._1p+1_1 in + let _ = 0x1_._1p+1_ in + () diff --git a/testsuite/tests/basic-float/tfloat_hex.reference b/testsuite/tests/basic-float/tfloat_hex.reference index 222649bc..3d4c6e6f 100644 --- a/testsuite/tests/basic-float/tfloat_hex.reference +++ b/testsuite/tests/basic-float/tfloat_hex.reference @@ -7,3 +7,17 @@ Failure("float_of_string") 0. inf inf +1.0625 +1.0625 +1.0625 +1.0625 +1. +1.0625 +2. +2. +2. +0.00048828125 +0.5 +2048. +2. +Failure("float_of_string") diff --git a/testsuite/tests/basic-modules/main.ml b/testsuite/tests/basic-modules/main.ml index dae92a6e..bd6d4ff3 100644 --- a/testsuite/tests/basic-modules/main.ml +++ b/testsuite/tests/basic-modules/main.ml @@ -1,5 +1,5 @@ (* TEST - modules = "offset.ml pr6726.ml pr7427.ml" + modules = "offset.ml pr6726.ml pr7427.ml pr4008.ml" *) (* PR#6435 *) @@ -16,6 +16,7 @@ module M = F (Offset) let () = M.test (Offset.M.Set.singleton "42") let v = Pr6726.Test.v +let v = Pr4008.v (* PR#7427 *) diff --git a/testsuite/tests/basic-modules/pr4008.ml b/testsuite/tests/basic-modules/pr4008.ml new file mode 100644 index 00000000..bb0df2d5 --- /dev/null +++ b/testsuite/tests/basic-modules/pr4008.ml @@ -0,0 +1,6 @@ +module rec M : sig + val f : int list -> int list +end = struct + let f = List.map succ +end +let v = M.f [] diff --git a/testsuite/tests/basic-modules/recursive_module_evaluation_errors.ml b/testsuite/tests/basic-modules/recursive_module_evaluation_errors.ml index 316f49c9..1eb63ef1 100644 --- a/testsuite/tests/basic-modules/recursive_module_evaluation_errors.ml +++ b/testsuite/tests/basic-modules/recursive_module_evaluation_errors.ml @@ -63,7 +63,7 @@ end = struct end and B: sig val value: unit end = struct let value = A.f () end [%%expect {| -Line 4, characters 6-72: +Lines 4-7, characters 6-3: 4 | ......struct 5 | module F(X:sig end) = struct end 6 | let f () = B.value @@ -93,7 +93,7 @@ module F(X: sig module type t module M: t end) = struct and B: sig val value: unit end = struct let value = A.f () end end [%%expect {| -Line 5, characters 8-62: +Lines 5-8, characters 8-5: 5 | ........struct 6 | module M = X.M 7 | let f () = B.value diff --git a/testsuite/tests/basic-more/morematch.compilers.reference b/testsuite/tests/basic-more/morematch.compilers.reference index f8857caa..9404040d 100644 --- a/testsuite/tests/basic-more/morematch.compilers.reference +++ b/testsuite/tests/basic-more/morematch.compilers.reference @@ -42,7 +42,7 @@ File "morematch.ml", line 456, characters 2-7: 456 | | _,_,Y -> 5 ^^^^^ Warning 11: this match case is unused. -File "morematch.ml", line 1050, characters 8-65: +File "morematch.ml", lines 1050-1053, characters 8-10: 1050 | ........function 1051 | | A (`A|`C) -> 0 1052 | | B (`B,`D) -> 1 diff --git a/testsuite/tests/basic-more/morematch.ml b/testsuite/tests/basic-more/morematch.ml index e9a83ff6..998daee6 100644 --- a/testsuite/tests/basic-more/morematch.ml +++ b/testsuite/tests/basic-more/morematch.ml @@ -1022,7 +1022,7 @@ test "maf" maf (`TConstr []) 5 ; test "maf" maf (`TVariant []) 6 ;; -(* PR#1310 +(* PR#3517 Using ``get_args'' in place or an ad-hoc ``matcher'' function for tuples. Has made the compiler [3.05] to fail. *) diff --git a/testsuite/tests/basic-more/robustmatch.compilers.reference b/testsuite/tests/basic-more/robustmatch.compilers.reference index 333a214d..06fa789b 100644 --- a/testsuite/tests/basic-more/robustmatch.compilers.reference +++ b/testsuite/tests/basic-more/robustmatch.compilers.reference @@ -1,4 +1,4 @@ -File "robustmatch.ml", line 33, characters 6-122: +File "robustmatch.ml", lines 33-37, characters 6-23: 33 | ......match t1, t2, x with 34 | | AB, AB, A -> () 35 | | MAB, _, A -> () @@ -7,42 +7,42 @@ File "robustmatch.ml", line 33, characters 6-122: Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (AB, MAB, A) -File "robustmatch.ml", line 54, characters 4-73: +File "robustmatch.ml", lines 54-56, characters 4-27: 54 | ....match r1, r2, a with 55 | | R1, _, 0 -> () 56 | | _, R2, "coucou" -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R1, R1, 1) -File "robustmatch.ml", line 64, characters 4-73: +File "robustmatch.ml", lines 64-66, characters 4-27: 64 | ....match r1, r2, a with 65 | | R1, _, A -> () 66 | | _, R2, "coucou" -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R1, R1, (B|C)) -File "robustmatch.ml", line 69, characters 4-73: +File "robustmatch.ml", lines 69-71, characters 4-20: 69 | ....match r1, r2, a with 70 | | _, R2, "coucou" -> () 71 | | R1, _, A -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R1, R1, (B|C)) -File "robustmatch.ml", line 74, characters 4-73: +File "robustmatch.ml", lines 74-76, characters 4-20: 74 | ....match r1, r2, a with 75 | | _, R2, "coucou" -> () 76 | | R1, _, _ -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R2, R2, "") -File "robustmatch.ml", line 85, characters 4-66: +File "robustmatch.ml", lines 85-87, characters 4-20: 85 | ....match r1, r2, a with 86 | | R1, _, A -> () 87 | | _, R2, X -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R1, R1, (B|C)) -File "robustmatch.ml", line 90, characters 4-87: +File "robustmatch.ml", lines 90-93, characters 4-20: 90 | ....match r1, r2, a with 91 | | R1, _, A -> () 92 | | _, R2, X -> () @@ -50,35 +50,35 @@ File "robustmatch.ml", line 90, characters 4-87: Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R2, R2, (Y|Z)) -File "robustmatch.ml", line 96, characters 4-66: +File "robustmatch.ml", lines 96-98, characters 4-20: 96 | ....match r1, r2, a with 97 | | R1, _, _ -> () 98 | | _, R2, X -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R2, R2, (Y|Z)) -File "robustmatch.ml", line 107, characters 4-66: +File "robustmatch.ml", lines 107-109, characters 4-20: 107 | ....match r1, r2, a with 108 | | R1, _, A -> () 109 | | _, R2, X -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R1, R1, (B|C)) -File "robustmatch.ml", line 129, characters 4-66: +File "robustmatch.ml", lines 129-131, characters 4-20: 129 | ....match r1, r2, a with 130 | | R1, _, A -> () 131 | | _, R2, X -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R1, R1, B) -File "robustmatch.ml", line 151, characters 4-66: +File "robustmatch.ml", lines 151-153, characters 4-20: 151 | ....match r1, r2, a with 152 | | R1, _, A -> () 153 | | _, R2, X -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R1, R1, B) -File "robustmatch.ml", line 156, characters 4-87: +File "robustmatch.ml", lines 156-159, characters 4-20: 156 | ....match r1, r2, a with 157 | | R1, _, A -> () 158 | | _, R2, X -> () @@ -86,21 +86,21 @@ File "robustmatch.ml", line 156, characters 4-87: Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R2, R2, Y) -File "robustmatch.ml", line 162, characters 4-66: +File "robustmatch.ml", lines 162-164, characters 4-20: 162 | ....match r1, r2, a with 163 | | R1, _, _ -> () 164 | | _, R2, X -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R2, R2, Y) -File "robustmatch.ml", line 167, characters 4-66: +File "robustmatch.ml", lines 167-169, characters 4-20: 167 | ....match r1, r2, a with 168 | | R1, _, C -> () 169 | | _, R2, Y -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R1, R1, A) -File "robustmatch.ml", line 176, characters 4-90: +File "robustmatch.ml", lines 176-179, characters 4-20: 176 | ....match r1, r2, a with 177 | | _, R1, 0 -> () 178 | | R2, _, [||] -> () @@ -108,14 +108,14 @@ File "robustmatch.ml", line 176, characters 4-90: Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R2, R2, [| _ |]) -File "robustmatch.ml", line 182, characters 4-69: +File "robustmatch.ml", lines 182-184, characters 4-23: 182 | ....match r1, r2, a with 183 | | R1, _, _ -> () 184 | | _, R2, [||] -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R2, R2, [| _ |]) -File "robustmatch.ml", line 187, characters 4-90: +File "robustmatch.ml", lines 187-190, characters 4-20: 187 | ....match r1, r2, a with 188 | | _, R2, [||] -> () 189 | | R1, _, 0 -> () @@ -123,70 +123,70 @@ File "robustmatch.ml", line 187, characters 4-90: Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R2, R2, [| _ |]) -File "robustmatch.ml", line 200, characters 4-89: +File "robustmatch.ml", lines 200-203, characters 4-19: 200 | ....match r1, r2, a with 201 | | _, R2, [||] -> () 202 | | R1, _, 0 -> () 203 | | _, _, _ -> () Warning 4: this pattern-matching is fragile. It will remain exhaustive when constructors are added to type repr. -File "robustmatch.ml", line 210, characters 4-75: +File "robustmatch.ml", lines 210-212, characters 4-27: 210 | ....match r1, r2, a with 211 | | R1, _, 'c' -> () 212 | | _, R2, "coucou" -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R1, R1, 'a') -File "robustmatch.ml", line 219, characters 4-74: +File "robustmatch.ml", lines 219-221, characters 4-27: 219 | ....match r1, r2, a with 220 | | R1, _, `A -> () 221 | | _, R2, "coucou" -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R1, R1, `B) -File "robustmatch.ml", line 228, characters 4-89: +File "robustmatch.ml", lines 228-230, characters 4-37: 228 | ....match r1, r2, a with 229 | | R1, _, (3, "") -> () 230 | | _, R2, (1, "coucou", 'a') -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R1, R1, (3, "*")) -File "robustmatch.ml", line 239, characters 4-113: +File "robustmatch.ml", lines 239-241, characters 4-51: 239 | ....match r1, r2, a with 240 | | R1, _, { x = 3; y = "" } -> () 241 | | _, R2, { a = 1; b = "coucou"; c = 'a' } -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R1, R1, {x=3; y="*"}) -File "robustmatch.ml", line 244, characters 4-113: +File "robustmatch.ml", lines 244-246, characters 4-36: 244 | ....match r1, r2, a with 245 | | R2, _, { a = 1; b = "coucou"; c = 'a' } -> () 246 | | _, R1, { x = 3; y = "" } -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R2, R2, {a=1; b="coucou"; c='b'}) -File "robustmatch.ml", line 253, characters 4-72: +File "robustmatch.ml", lines 253-255, characters 4-20: 253 | ....match r1, r2, a with 254 | | R1, _, (3, "") -> () 255 | | _, R2, 1 -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R1, R1, (3, "*")) -File "robustmatch.ml", line 263, characters 4-82: +File "robustmatch.ml", lines 263-265, characters 4-20: 263 | ....match r1, r2, a with 264 | | R1, _, { x = 3; y = "" } -> () 265 | | _, R2, 1 -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R1, R1, {x=3; y="*"}) -File "robustmatch.ml", line 272, characters 4-71: +File "robustmatch.ml", lines 272-274, characters 4-20: 272 | ....match r1, r2, a with 273 | | R1, _, lazy 1 -> () 274 | | _, R2, 1 -> () Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: (R1, R1, lazy 0) -File "robustmatch.ml", line 281, characters 4-99: +File "robustmatch.ml", lines 281-284, characters 4-24: 281 | ....match r1, r2, a with 282 | | R1, _, () -> () 283 | | _, R2, "coucou" -> () diff --git a/testsuite/tests/basic/localexn.ml b/testsuite/tests/basic/localexn.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/basic/localfunction.ml b/testsuite/tests/basic/localfunction.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/basic/localfunction.reference b/testsuite/tests/basic/localfunction.reference old mode 100755 new mode 100644 diff --git a/testsuite/tests/basic/opt_variants.ml b/testsuite/tests/basic/opt_variants.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/basic/patmatch_incoherence.ml b/testsuite/tests/basic/patmatch_incoherence.ml index 10d38dbb..c54fd918 100644 --- a/testsuite/tests/basic/patmatch_incoherence.ml +++ b/testsuite/tests/basic/patmatch_incoherence.ml @@ -35,7 +35,7 @@ match { x = assert false } with | { x = None } -> () ;; [%%expect{| -Line 1, characters 0-70: +Lines 1-3, characters 0-20: 1 | match { x = assert false } with 2 | | { x = 3 } -> () 3 | | { x = None } -> () @@ -50,7 +50,7 @@ match { x = assert false } with | { x = "" } -> () ;; [%%expect{| -Line 1, characters 0-71: +Lines 1-3, characters 0-18: 1 | match { x = assert false } with 2 | | { x = None } -> () 3 | | { x = "" } -> () @@ -65,7 +65,7 @@ match { x = assert false } with | { x = `X } -> () ;; [%%expect{| -Line 1, characters 0-71: +Lines 1-3, characters 0-18: 1 | match { x = assert false } with 2 | | { x = None } -> () 3 | | { x = `X } -> () @@ -80,7 +80,7 @@ match { x = assert false } with | { x = 3 } -> () ;; [%%expect{| -Line 1, characters 0-70: +Lines 1-3, characters 0-17: 1 | match { x = assert false } with 2 | | { x = [||] } -> () 3 | | { x = 3 } -> () @@ -95,7 +95,7 @@ match { x = assert false } with | { x = 3 } -> () ;; [%%expect{| -Line 1, characters 0-68: +Lines 1-3, characters 0-17: 1 | match { x = assert false } with 2 | | { x = `X } -> () 3 | | { x = 3 } -> () @@ -110,7 +110,7 @@ match { x = assert false } with | { x = 3 } -> () ;; [%%expect{| -Line 1, characters 0-74: +Lines 1-3, characters 0-17: 1 | match { x = assert false } with 2 | | { x = `X "lol" } -> () 3 | | { x = 3 } -> () @@ -126,7 +126,7 @@ match { x = assert false } with | { x = 3 } -> () ;; [%%expect{| -Line 1, characters 0-95: +Lines 1-4, characters 0-17: 1 | match { x = assert false } with 2 | | { x = (2., "") } -> () 3 | | { x = None } -> () diff --git a/testsuite/tests/basic/pr7657.ml b/testsuite/tests/basic/pr7657.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/basic/switch_opts.ml b/testsuite/tests/basic/switch_opts.ml index a32772e5..b4e563fe 100644 --- a/testsuite/tests/basic/switch_opts.ml +++ b/testsuite/tests/basic/switch_opts.ml @@ -12,54 +12,298 @@ type t = A | B | C (* These test functions need to have at least three cases. Functions with fewer cases don't trigger the optimisation, as they are compiled to if-then-else, not switch *) -let testcases = [ - Test (3, 3, function 1 -> 1 | 2 -> 2 | 3 -> 3 | _ -> 0); - Test (3, -3, function 1 -> 1 | 2 -> 2 | 3 -> -3 | _ -> 0); - Test (3, min_int, function 1 -> 1 | 2 -> 2 | 3 -> min_int | _ -> 0); - Test (3, max_int, function 1 -> 1 | 2 -> 2 | 3 -> max_int | _ -> 0); - Test (3, 3., function 1 -> 1. | 2 -> 2. | 3 -> 3. | _ -> 0.); - Test (3, Sys.opaque_identity "c" ^ Sys.opaque_identity "c", - function 1 -> "a" | 2 -> "b" | 3 -> "cc" | _ -> ""); - Test (3, List.rev [3;2;1], - function 1 -> [] | 2 -> [42] | 3 -> [1;2;3] | _ -> [415]); - - Test (C, 3, function A -> 1 | B -> 2 | C -> 3); - Test (C, -3, function A -> 1 | B -> 2 | C -> -3); - Test (C, min_int, function A -> 1 | B -> 2 | C -> min_int); - Test (C, max_int, function A -> 1 | B -> 2 | C -> max_int); - Test (C, 3., function A -> 1. | B -> 2. | C -> 3.); - Test (C, "c", function A -> "a" | B -> "b" | C -> "c"); - Test (C, List.rev [3;2;1], function A -> [] | B -> [42] | C -> [1;2;3]); - - Test (42, 42, function - | 1 -> 1 | 2 -> 2 | 3 -> 3 | 4 -> 4 | 5 -> 5 | 6 -> 6 | 7 -> 7 | 8 -> 8 - | 9 -> 9 | 10 -> 10 | 11 -> 11 | 12 -> 12 | 13 -> 13 | 14 -> 14 | 15 -> 15 - | 16 -> 16 | 17 -> 17 | 18 -> 18 | 19 -> 19 | 20 -> 20 | 21 -> 21 | 22 -> 22 - | 23 -> 23 | 24 -> 24 | 25 -> 25 | 26 -> 26 | 27 -> 27 | 28 -> 28 | 29 -> 29 - | 30 -> 30 | 31 -> 31 | 32 -> 32 | 33 -> 33 | 34 -> 34 | 35 -> 35 | 36 -> 36 - | 37 -> 37 | 38 -> 38 | 39 -> 39 | 40 -> 40 | 41 -> 41 | 42 -> 42 | 43 -> 43 - | 44 -> 44 | 45 -> 45 | 46 -> 46 | 47 -> 47 | 48 -> 48 | 49 -> 49 | 50 -> 50 - | 51 -> 51 | 52 -> 52 | 53 -> 53 | 54 -> 54 | 55 -> 55 | 56 -> 56 | 57 -> 57 - | 58 -> 58 | 59 -> 59 | 60 -> 60 | 61 -> 61 | 62 -> 62 | 63 -> 63 | 64 -> 64 - | 65 -> 65 | 66 -> 66 | 67 -> 67 | 68 -> 68 | 69 -> 69 | 70 -> 70 | 71 -> 71 - | 72 -> 72 | 73 -> 73 | 74 -> 74 | 75 -> 75 | 76 -> 76 | 77 -> 77 | 78 -> 78 - | 79 -> 79 | 80 -> 80 | 81 -> 81 | 82 -> 82 | 83 -> 83 | 84 -> 84 | 85 -> 85 - | 86 -> 86 | 87 -> 87 | 88 -> 88 | 89 -> 89 | 90 -> 90 | 91 -> 91 | 92 -> 92 - | 93 -> 93 | 94 -> 94 | 95 -> 95 | 96 -> 96 | 97 -> 97 | 98 -> 98 | 99 -> 99 - | _ -> 0); - - Test (3, `Tertiary, function - | 1 -> `Primary - | 2 -> `Secondary - | 3 -> `Tertiary - | n -> invalid_arg "test") - ] let passes = ref 0 -let run_test (Test (a, b, f)) = - assert (f a = b); + +let full_test line ~f ~results () = + let f = Sys.opaque_identity f in + List.iter + (fun (input, output) -> + let result = f input in + if result <> output + then raise (Assert_failure (__FILE__,line,0)) + ) + results; incr passes +let test_int_match = + full_test __LINE__ + ~f:(function + | 1 -> 1 + | 2 -> 2 + | 3 -> 3 + | _ -> 0 + ) + ~results: + [ 1,1; 2,2; 3,3; 4,0; 0,0 ] + +let test_int_match_reverse = + full_test __LINE__ + ~f:(function + | 1 -> 3 + | 2 -> 2 + | 3 -> 1 + | _ -> 0 + ) + ~results: + [ 1,3; 2,2; 3,1; 4,0; 0,0 ] + +let test_int_match_negative = + full_test __LINE__ + ~f:(function + | 1 -> -1 + | 2 -> -2 + | 3 -> -3 + | _ -> 0 + ) + ~results: + [ 1,-1; 2,-2; 3,-3; 4,0; 0,0 ] + +let test_int_match_negative_reverse = + full_test __LINE__ + ~f:(function + | 1 -> -3 + | 2 -> -2 + | 3 -> -1 + | _ -> 0 + ) + ~results: + [ 1,-3; 2,-2; 3,-1; 4,0; 0,0 ] + +let test_int_min_int = + full_test __LINE__ + ~f:(function + | 1 -> 1 + | 2 -> 2 + | 3 -> min_int + | _ -> 0 + ) + ~results: + [ 1,1; 2,2; 3,min_int; 4,0; 0,0 ] + +let test_int_max_int = + full_test __LINE__ + ~f:(function + | 1 -> 1 + | 2 -> 2 + | 3 -> max_int + | _ -> 0 + ) + ~results: + [ 1,1; 2,2; 3,max_int; 4,0; 0,0 ] + +let test_float = + full_test __LINE__ + ~f:(function + | 1 -> 1.0 + | 2 -> 2.0 + | 3 -> 3.0 + | _ -> 0.0 + ) + ~results: + [ 1,1.0; 2,2.0; 3,3.0; 4,0.0; 0,0.0 ] + +let test_string = + full_test __LINE__ + ~f:(function + | 1 -> "a" + | 2 -> "b" + | 3 -> "cc" + | _ -> "" + ) + ~results: + [ 1,"a"; 2, "b" + ; 3, Sys.opaque_identity "c" ^ Sys.opaque_identity "c"; 4, ""; 0, "" ] + +let test_list = + full_test __LINE__ + ~f:(function + | 1 -> [] + | 2 -> [ 42 ] + | 3 -> [ 1; 2; 3 ] + | _ -> [ 415 ] + ) + ~results: + [ 1, []; 2, [ 42 ]; 3, List.rev [3;2;1]; 4, [ 415 ]; 0, [ 415 ] ] + +let test_abc = + full_test __LINE__ + ~f:(function + | A -> 1 + | B -> 2 + | C -> 3 + ) + ~results: + [ A, 1; B, 2; C, 3] + +let test_abc_unsorted = + full_test __LINE__ + ~f:(function + | C -> 3 + | A -> 1 + | B -> 2 + ) + ~results: + [ A, 1; B, 2; C, 3] + +let test_abc_neg3 = + full_test __LINE__ + ~f:(function + | A -> 1 + | B -> 2 + | C -> -3 + ) + ~results: + [ A, 1; B, 2; C, -3] + +let test_abc_min_int = + full_test __LINE__ + ~f:(function + | A -> 1 + | B -> 2 + | C -> min_int + ) + ~results: + [ A, 1; B, 2; C, min_int ] + +let test_abc_max_int = + full_test __LINE__ + ~f:(function + | A -> 1 + | B -> 2 + | C -> max_int + ) + ~results: + [ A, 1; B, 2; C, max_int ] + +let test_abc_float = + full_test __LINE__ + ~f:(function + | A -> 1. + | B -> 2. + | C -> 3. + ) + ~results: + [ A, 1.; B, 2.; C, 3. ] + +let test_abc_string = + full_test __LINE__ + ~f:(function + | A -> "a" + | B -> "b" + | C -> "c" + ) + ~results: + [ A, "a"; B, "b"; C, "c" ] + +let test_abc_list = + full_test __LINE__ + ~f:(function + | A -> [] + | B -> [42] + | C -> [1;2;3] + ) + ~results: + [ A, []; B, [42]; C, List.rev [3;2;1] ] + +let test_f99 = + full_test __LINE__ + ~f:(function + | 1 -> 1 | 2 -> 2 | 3 -> 3 | 4 -> 4 | 5 -> 5 | 6 -> 6 | 7 -> 7 | 8 -> 8 + | 9 -> 9 | 10 -> 10 | 11 -> 11 | 12 -> 12 | 13 -> 13 | 14 -> 14 | 15 -> 15 + | 16 -> 16 | 17 -> 17 | 18 -> 18 | 19 -> 19 | 20 -> 20 | 21 -> 21 | 22 -> 22 + | 23 -> 23 | 24 -> 24 | 25 -> 25 | 26 -> 26 | 27 -> 27 | 28 -> 28 | 29 -> 29 + | 30 -> 30 | 31 -> 31 | 32 -> 32 | 33 -> 33 | 34 -> 34 | 35 -> 35 | 36 -> 36 + | 37 -> 37 | 38 -> 38 | 39 -> 39 | 40 -> 40 | 41 -> 41 | 42 -> 42 | 43 -> 43 + | 44 -> 44 | 45 -> 45 | 46 -> 46 | 47 -> 47 | 48 -> 48 | 49 -> 49 | 50 -> 50 + | 51 -> 51 | 52 -> 52 | 53 -> 53 | 54 -> 54 | 55 -> 55 | 56 -> 56 | 57 -> 57 + | 58 -> 58 | 59 -> 59 | 60 -> 60 | 61 -> 61 | 62 -> 62 | 63 -> 63 | 64 -> 64 + | 65 -> 65 | 66 -> 66 | 67 -> 67 | 68 -> 68 | 69 -> 69 | 70 -> 70 | 71 -> 71 + | 72 -> 72 | 73 -> 73 | 74 -> 74 | 75 -> 75 | 76 -> 76 | 77 -> 77 | 78 -> 78 + | 79 -> 79 | 80 -> 80 | 81 -> 81 | 82 -> 82 | 83 -> 83 | 84 -> 84 | 85 -> 85 + | 86 -> 86 | 87 -> 87 | 88 -> 88 | 89 -> 89 | 90 -> 90 | 91 -> 91 | 92 -> 92 + | 93 -> 93 | 94 -> 94 | 95 -> 95 | 96 -> 96 | 97 -> 97 | 98 -> 98 | 99 -> 99 + | _ -> 0 + ) + ~results: + [ 1,1; 42,42; 98, 98; 99,99; 100, 0 ] + +let test_poly = + full_test __LINE__ + ~f:(function + | 1 -> `Primary + | 2 -> `Secondary + | 3 -> `Tertiary + | n -> invalid_arg "test" + ) + ~results: + [ 1, `Primary; 2, `Secondary; 3, `Tertiary ] + +let test_or = + full_test __LINE__ + ~f:(function + | 1 | 2 | 3 -> 0 + | 4 | 5 | 6 -> 1 + | 7 -> 2 + | _ -> 0 + ) + ~results: + [ 1,0; 2,0; 3,0; 4,1; 5,1; 6,1; 7,2; 8,0; 0,0 ] + +type t' = E | F | G | H + +let test_or_efgh = + full_test __LINE__ + ~f:(function + | E | H -> 0 + | F -> 1 + | G -> 2 + ) + ~results: + [ E,0; H,0; F,1; G,2 ] + +type 'a gadt = + | Ag : int gadt + | Bg : string gadt + | Cg : int gadt + | Dg : int gadt + | Eg : int gadt + +let test_gadt = + full_test __LINE__ + ~f:(function + | Ag -> 1 + | Cg -> 2 + | Dg -> 3 + | Eg -> 4 + ) + ~results: + [ Ag,1; Cg,2; Dg,3; Eg,4 ] + +let () = + test_int_match (); + test_int_match_reverse (); + test_int_match_negative (); + test_int_match_negative_reverse (); + test_int_min_int (); + test_int_max_int (); + test_float (); + test_string (); + test_list (); + test_abc (); + test_abc_unsorted (); + test_abc_neg3 (); + test_abc_min_int (); + test_abc_max_int (); + test_abc_float (); + test_abc_string (); + test_abc_list (); + test_f99 (); + test_poly (); + test_or (); + test_or_efgh (); + test_gadt (); + () + let () = - List.iter run_test testcases; Printf.printf "%d tests passed\n" !passes diff --git a/testsuite/tests/basic/switch_opts.reference b/testsuite/tests/basic/switch_opts.reference index 48a00459..cb07836c 100644 --- a/testsuite/tests/basic/switch_opts.reference +++ b/testsuite/tests/basic/switch_opts.reference @@ -1 +1 @@ -16 tests passed +22 tests passed diff --git a/testsuite/tests/embedded/cmstub.c b/testsuite/tests/embedded/cmstub.c index a83ad61e..82599002 100644 --- a/testsuite/tests/embedded/cmstub.c +++ b/testsuite/tests/embedded/cmstub.c @@ -19,12 +19,12 @@ int fib(int n) { - value * fib_closure = caml_named_value("fib"); + const value * fib_closure = caml_named_value("fib"); return Int_val(caml_callback(*fib_closure, Val_int(n))); } char * format_result(int n) { - value * format_result_closure = caml_named_value("format_result"); + const value * format_result_closure = caml_named_value("format_result"); return strdup(String_val(caml_callback(*format_result_closure, Val_int(n)))); } diff --git a/testsuite/tests/float-unboxing/float_subst_boxed_number.ml b/testsuite/tests/float-unboxing/float_subst_boxed_number.ml index c8c07273..4ca01612 100644 --- a/testsuite/tests/float-unboxing/float_subst_boxed_number.ml +++ b/testsuite/tests/float-unboxing/float_subst_boxed_number.ml @@ -3,6 +3,8 @@ flags = "-w -55" ocamlc_flags = "config.cmo" ocamlopt_flags = "-inline 20 config.cmx" + * native + compare_programs = "false" *) let eliminate_intermediate_float_record () = diff --git a/testsuite/tests/gc-roots/globroots.ml b/testsuite/tests/gc-roots/globroots.ml index df438bc4..43d93e3f 100644 --- a/testsuite/tests/gc-roots/globroots.ml +++ b/testsuite/tests/gc-roots/globroots.ml @@ -77,6 +77,10 @@ module TestGenerational = Test(Generational) external young2old : unit -> unit = "gb_young2old" let _ = young2old (); Gc.full_major () +external static2young : int * int -> (unit -> unit) -> int = "gb_static2young" +let _ = + assert (static2young (1, 1) Gc.full_major == 0x42) + let _ = let n = if Array.length Sys.argv < 2 then 10000 else int_of_string Sys.argv.(1) in diff --git a/testsuite/tests/gc-roots/globrootsprim.c b/testsuite/tests/gc-roots/globrootsprim.c index 28ad2267..0eb777b0 100644 --- a/testsuite/tests/gc-roots/globrootsprim.c +++ b/testsuite/tests/gc-roots/globrootsprim.c @@ -17,6 +17,7 @@ #include "caml/memory.h" #include "caml/alloc.h" #include "caml/gc.h" +#include "caml/callback.h" struct block { value header; value v; }; @@ -81,3 +82,32 @@ value gb_young2old(value _dummy) { root += sizeof(value); return Val_unit; } + +value gb_static2young(value static_value, value full_major) { + CAMLparam2 (static_value, full_major); + CAMLlocal1(v); + int i; + + root = Val_unit; + caml_register_generational_global_root(&root); + + /* Write a static value in the root. */ + caml_modify_generational_global_root(&root, static_value); + + /* Overwrite it with a young value. */ + v = caml_alloc_small(1, 0); + Field(v, 0) = Val_long(0x42); + caml_modify_generational_global_root(&root, v); + + /* Promote the young value */ + caml_callback(full_major, Val_unit); + + /* Fill the minor heap to make sure the old block is overwritten */ + for(i = 0; i < 1000000; i++) + caml_alloc_small(1, 0); + + v = Field(root, 0); + caml_remove_generational_global_root(&root); + + CAMLreturn(v); +} diff --git a/testsuite/tests/generalized-open/clambda_optim.ml b/testsuite/tests/generalized-open/clambda_optim.ml new file mode 100644 index 00000000..d7ca317e --- /dev/null +++ b/testsuite/tests/generalized-open/clambda_optim.ml @@ -0,0 +1,15 @@ +(* TEST + +compile_only = "true" + +* no-flambda +** setup-ocamlopt.byte-build-env +*** ocamlopt.byte +**** check-ocamlopt.byte-output + +*) + +module Stable = struct + open struct module V0 = struct module U = struct end end end + module V0 = V0.U +end diff --git a/testsuite/tests/generalized-open/gpr1506.ml b/testsuite/tests/generalized-open/gpr1506.ml index f8c8d7e9..a6747abd 100644 --- a/testsuite/tests/generalized-open/gpr1506.ml +++ b/testsuite/tests/generalized-open/gpr1506.ml @@ -115,7 +115,7 @@ module A = struct end end [%%expect{| -Line 3, characters 4-56: +Lines 3-6, characters 4-7: 3 | ....open struct 4 | type t = T 5 | let x = T @@ -135,7 +135,7 @@ module A = struct let g = y end [%%expect{| -Line 3, characters 4-40: +Lines 3-5, characters 4-7: 3 | ....open struct 4 | type t = T 5 | end diff --git a/testsuite/tests/generalized-open/ocamltests b/testsuite/tests/generalized-open/ocamltests index 897bd052..ec6f2cff 100644 --- a/testsuite/tests/generalized-open/ocamltests +++ b/testsuite/tests/generalized-open/ocamltests @@ -1,5 +1,6 @@ accepted_batch.ml accepted_expect.ml +clambda_optim.ml expansiveness.ml funct_body.ml gpr1506.ml diff --git a/testsuite/tests/let-syntax/let_syntax.ml b/testsuite/tests/let-syntax/let_syntax.ml index 3837d57a..b8d6673e 100644 --- a/testsuite/tests/let-syntax/let_syntax.ml +++ b/testsuite/tests/let-syntax/let_syntax.ml @@ -217,6 +217,7 @@ Line 3, characters 13-14: ^ Error: This expression has type int but an expression was expected of type float + Hint: Did you mean `1.'? |}];; module Ill_typed_3 = struct @@ -289,7 +290,7 @@ let ill_typed_5 = x + y + z );; [%%expect{| -Line 3, characters 9-44: +Lines 3-5, characters 9-14: 3 | .........x = 1 4 | and+ y = 2 5 | and+ z = 3... @@ -319,7 +320,7 @@ let ill_typed_6 = x + y + z );; [%%expect{| -Line 3, characters 9-29: +Lines 3-4, characters 9-14: 3 | .........x = 1 4 | and+ y = 2 Error: These bindings have type int * int but bindings were expected of type @@ -511,7 +512,7 @@ let indexed_monad4 = return (first ^ second) );; [%%expect{| -Line 6, characters 4-55: +Lines 6-7, characters 4-29: 6 | ....let* second = read in 7 | return (first ^ second) Error: This expression has type diff --git a/testsuite/tests/letrec-check/basic.ml b/testsuite/tests/letrec-check/basic.ml index fea13c48..ffdb56d1 100644 --- a/testsuite/tests/letrec-check/basic.ml +++ b/testsuite/tests/letrec-check/basic.ml @@ -172,7 +172,7 @@ let rec x = done and y = x; ();; [%%expect{| -Line 2, characters 2-52: +Lines 2-4, characters 2-6: 2 | ..for i = 0 to 1 do 3 | let z = y in ignore z 4 | done @@ -185,7 +185,7 @@ let rec x = done and y = 10;; [%%expect{| -Line 2, characters 2-33: +Lines 2-4, characters 2-6: 2 | ..for i = 0 to y do 3 | () 4 | done @@ -198,7 +198,7 @@ let rec x = done and y = 0;; [%%expect{| -Line 2, characters 2-34: +Lines 2-4, characters 2-6: 2 | ..for i = y to 10 do 3 | () 4 | done @@ -211,7 +211,7 @@ let rec x = done and y = x; ();; [%%expect{| -Line 2, characters 2-49: +Lines 2-4, characters 2-6: 2 | ..while false do 3 | let y = x in ignore y 4 | done @@ -224,7 +224,7 @@ let rec x = done and y = false;; [%%expect{| -Line 2, characters 2-26: +Lines 2-4, characters 2-6: 2 | ..while y do 3 | () 4 | done @@ -237,7 +237,7 @@ let rec x = done and y = false;; [%%expect{| -Line 2, characters 2-45: +Lines 2-4, characters 2-6: 2 | ..while y do 3 | let y = x in ignore y 4 | done @@ -320,7 +320,7 @@ let rec x = and y = match x with z -> ("y", z);; [%%expect{| -Line 2, characters 2-85: +Lines 2-4, characters 2-30: 2 | ..match let _ = y in raise Not_found with 3 | _ -> "x" 4 | | exception Not_found -> "z" @@ -346,7 +346,7 @@ let rec wrong = and y = ref wrong in ref ("foo" ^ ! ! !x);; [%%expect{| -Line 10, characters 2-65: +Lines 10-12, characters 2-25: 10 | ..let rec x = ref y 11 | and y = ref wrong 12 | in ref ("foo" ^ ! ! !x).. diff --git a/testsuite/tests/letrec-check/extension_constructor.ml b/testsuite/tests/letrec-check/extension_constructor.ml index e581a0ac..93171ae1 100644 --- a/testsuite/tests/letrec-check/extension_constructor.ml +++ b/testsuite/tests/letrec-check/extension_constructor.ml @@ -18,7 +18,7 @@ let rec x = and (m : (module T)) = (module (struct exception A of int end) : T);; [%%expect{| -Line 2, characters 2-36: +Lines 2-3, characters 2-8: 2 | ..let module M = (val m) in 3 | M.A 42 Error: This kind of expression is not allowed as right-hand side of `let rec' diff --git a/testsuite/tests/letrec-check/modules.ml b/testsuite/tests/letrec-check/modules.ml index 883c49d9..6507d9a5 100644 --- a/testsuite/tests/letrec-check/modules.ml +++ b/testsuite/tests/letrec-check/modules.ml @@ -37,7 +37,7 @@ let rec x = module N = struct let y = x end end in M.N.y;; [%%expect{| -Line 2, characters 2-74: +Lines 2-4, characters 2-14: 2 | ..let module M = struct 3 | module N = struct let y = x end 4 | end in M.N.y.. diff --git a/testsuite/tests/letrec-check/pr7706.ocaml.reference b/testsuite/tests/letrec-check/pr7706.ocaml.reference index 3303026b..71544e4a 100644 --- a/testsuite/tests/letrec-check/pr7706.ocaml.reference +++ b/testsuite/tests/letrec-check/pr7706.ocaml.reference @@ -1,4 +1,4 @@ -Line 5, characters 2-67: +Lines 5-6, characters 2-3: 5 | ..let y = if false then (fun z -> 1) else (fun z -> x 4 + 1) in 6 | y.. Error: This kind of expression is not allowed as right-hand side of `let rec' diff --git a/testsuite/tests/letrec-check/unboxed.ml b/testsuite/tests/letrec-check/unboxed.ml index 78284722..7c04199e 100644 --- a/testsuite/tests/letrec-check/unboxed.ml +++ b/testsuite/tests/letrec-check/unboxed.ml @@ -59,7 +59,7 @@ let rec a = [%%expect{| type a = { a : b; } [@@unboxed] and b = X of a | Y -Line 5, characters 2-75: +Lines 5-9, characters 2-10: 5 | ..{a= 6 | (if Sys.opaque_identity true then 7 | X a @@ -99,7 +99,7 @@ let rec d = [%%expect{| type d = D of e [@@unboxed] and e = V of d | W -Line 5, characters 2-72: +Lines 5-9, characters 2-9: 5 | ..D 6 | (if Sys.opaque_identity true then 7 | V d diff --git a/testsuite/tests/letrec-compilation/ocamltests b/testsuite/tests/letrec-compilation/ocamltests index 6fb1f819..5ac062fb 100644 --- a/testsuite/tests/letrec-compilation/ocamltests +++ b/testsuite/tests/letrec-compilation/ocamltests @@ -14,5 +14,6 @@ mixing_value_closures_2.ml mutual_functions.ml nested.ml pr4989.ml +pr8681.ml record_with.ml ref.ml diff --git a/testsuite/tests/letrec-compilation/pr8681.ml b/testsuite/tests/letrec-compilation/pr8681.ml new file mode 100644 index 00000000..7e9ab0e8 --- /dev/null +++ b/testsuite/tests/letrec-compilation/pr8681.ml @@ -0,0 +1,63 @@ +(* TEST *) +let rec h = + let rec f n = if n >= 0 then g (n - 1) + and g n = h n; f n in + f + +let () = Gc.minor () +let () = ignore (h 10) + +let mooo x = + let rec h = + ignore (Sys.opaque_identity x); + let rec g n = h n; f n + and f n = if n >= 0 then g (n - 1) in + f + in + h + +let h = mooo 3 +let () = Gc.minor () +let () = ignore (h 10) + + +let rec foo = + let rec f = function + | 0 -> 100 + | n -> foo (n-1) + and g = function + | 0 -> 200 + | n -> f (n-1) in + g + +let () = print_int (foo 2); print_newline () +let () = print_int (foo 7); print_newline () + + +let with_free_vars a b c = + let rec foo = + let rec f = function + | 0 -> 100 + a + b + c + | n -> foo (n-1) + and g = function + | 0 -> 200 + a + b + c + | n -> f (n-1) in + g in + foo + +let () = print_int (with_free_vars 1 2 3 2); print_newline () +let () = print_int (with_free_vars 1 2 3 7); print_newline () + +let bar = + let rec f = function + | 0 -> 3 + | n -> g (n - 1) + and g = function + | 0 -> 10 + f 10 + | n -> f (n - 1) + in + let rec foof = f + and goof = g + in (foof, goof) + +let () = print_int (snd bar 42); print_newline () diff --git a/testsuite/tests/letrec-compilation/pr8681.reference b/testsuite/tests/letrec-compilation/pr8681.reference new file mode 100644 index 00000000..8e0fba10 --- /dev/null +++ b/testsuite/tests/letrec-compilation/pr8681.reference @@ -0,0 +1,5 @@ +200 +100 +206 +106 +13 diff --git a/testsuite/tests/lib-arg/testerror.ml b/testsuite/tests/lib-arg/testerror.ml index 94409452..6ae29205 100644 --- a/testsuite/tests/lib-arg/testerror.ml +++ b/testsuite/tests/lib-arg/testerror.ml @@ -1,4 +1,6 @@ (* TEST + * native + compare_programs = "false" *) (** Test that the right message errors are emitted by Arg *) diff --git a/testsuite/tests/lib-bigarray-file/mapfile.ml b/testsuite/tests/lib-bigarray-file/mapfile.ml index a28d5486..a359cd1b 100644 --- a/testsuite/tests/lib-bigarray-file/mapfile.ml +++ b/testsuite/tests/lib-bigarray-file/mapfile.ml @@ -1,6 +1,7 @@ (* TEST * hasunix include unix + ** native *) open Bigarray diff --git a/testsuite/tests/lib-bytes/binary.ml b/testsuite/tests/lib-bytes/binary.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/lib-filename/extension.ml b/testsuite/tests/lib-filename/extension.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/lib-filename/suffix.ml b/testsuite/tests/lib-filename/suffix.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/lib-int/test.ml b/testsuite/tests/lib-int/test.ml index 322ae97c..592dbb33 100644 --- a/testsuite/tests/lib-int/test.ml +++ b/testsuite/tests/lib-int/test.ml @@ -25,6 +25,7 @@ let test_logops () = assert (Int.logxor 0xF0FF 0x0F0F = 0xFFF0); assert (Int.lognot Int.max_int = Int.min_int); assert (Int.shift_left 1 4 = 16); + assert (Int.shift_left (Int.compare 0 0) 63 = 0); (* Issue #8864 *) assert (Int.shift_right 16 4 = 1); assert (Int.shift_right (-16) 4 = (-1)); assert (Int.shift_right (-16) 4 = (-1)); diff --git a/testsuite/tests/lib-obj/ocamltests b/testsuite/tests/lib-obj/ocamltests index 55f0b5b3..bdddfe9e 100644 --- a/testsuite/tests/lib-obj/ocamltests +++ b/testsuite/tests/lib-obj/ocamltests @@ -1 +1,2 @@ reachable_words.ml +with_tag.ml diff --git a/testsuite/tests/lib-obj/reachable_words.ml b/testsuite/tests/lib-obj/reachable_words.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/lib-obj/with_tag.ml b/testsuite/tests/lib-obj/with_tag.ml new file mode 100644 index 00000000..a4b69ea1 --- /dev/null +++ b/testsuite/tests/lib-obj/with_tag.ml @@ -0,0 +1,31 @@ +(* TEST +*) + +type t = +| A of string * float +| B of string * float + +let () = + assert (Obj.dup (Obj.repr (A ("hello", 10.))) = Obj.repr (A ("hello", 10.))); + assert (Obj.with_tag 1 (Obj.repr (A ("hello", 10.))) = Obj.repr (B ("hello", 10.))) + +let () = + assert (Obj.tag (Obj.with_tag 42 (Obj.repr [| |])) = 42) + +(* check optimisations *) +let raw_allocs f = + let before = Gc.minor_words () in + f (); + let after = Gc.minor_words () in + int_of_float (after -. before) + +let allocs = + let overhead = raw_allocs (fun () -> ()) in + fun f -> raw_allocs f - overhead + +let () = + assert (allocs (fun () -> Obj.with_tag 1 (Obj.repr (A ("hello", 10.)))) = 0); + assert (allocs (fun () -> Obj.with_tag 1 (Obj.repr (ref 10))) = 2) + +let () = + print_endline "ok" diff --git a/testsuite/tests/lib-obj/with_tag.reference b/testsuite/tests/lib-obj/with_tag.reference new file mode 100644 index 00000000..9766475a --- /dev/null +++ b/testsuite/tests/lib-obj/with_tag.reference @@ -0,0 +1 @@ +ok diff --git a/testsuite/tests/lib-printf/tprintf.ml b/testsuite/tests/lib-printf/tprintf.ml index 8036dfb7..54799e12 100644 --- a/testsuite/tests/lib-printf/tprintf.ml +++ b/testsuite/tests/lib-printf/tprintf.ml @@ -285,15 +285,11 @@ try test (sprintf "%4F" 3. = " 3."); test (sprintf "%-4F" 3. = "3. "); test (sprintf "%04F" 3. = "003."); -(* plus-padding unsupported test (sprintf "%+4F" 3. = " +3."); -*) -(* no precision - test (sprintf "%.3F" 42.42 = "42.420"); - test (sprintf "%12.3F" 42.42e42 = " 4.242e+43"); - test (sprintf "%.3F" 42.00 = "42.000"); - test (sprintf "%.3F" 0.0042 = "0.004"); -*) + test (sprintf "%.3F" 42.42 = "42.4"); + test (sprintf "%12.3F" 42.42e42 =* " 4.24e+43"); + test (sprintf "%.3F" 42.00 = "42."); + test (sprintf "%.3F" 0.0042 = "0.0042"); printf "\nh\n%!"; test (sprintf "%+h" (+0.) = "+0x0p+0"); @@ -373,23 +369,27 @@ try (*test (sprintf "%-0+ #14.3E" 42.42 =* "+4.242E+01 ");*) (* >> '-' is incompatible with '0', '#' is incompatible with 'E' *) -(* %g gives strange results that correspond to neither %f nor %e printf "\ng\n%!"; - test (sprintf "%g" (-42.42) = "-42.42000"); - test (sprintf "%-15g" (-42.42) = "-42.42000 "); - test (sprintf "%015g" (-42.42) = "-00000042.42000"); - test (sprintf "%+g" 42.42 = "+42.42000"); - test (sprintf "% g" 42.42 = " 42.42000"); - test (sprintf "%#g" 42.42 = "42.42000"); - test (sprintf "%15g" 42.42 = " 42.42000"); - test (sprintf "%*g" 14 42.42 = " 42.42000"); - test (sprintf "%-0+ #14g" 42.42 = "+42.42000 "); - test (sprintf "%.3g" (-42.42) = "-42.420"); -*) + test (sprintf "%g" (-42.42) = "-42.42"); + test (sprintf "%.3g" (-4242.) =* "-4.24e+03"); + test (sprintf "%-15g" (-42.42) = "-42.42 "); + test (sprintf "%015g" (-42.42) = "-00000000042.42"); + test (sprintf "%+g" 42.42 = "+42.42"); + test (sprintf "% g" 42.42 = " 42.42"); + test (sprintf "%15g" 42.42 = " 42.42"); + test (sprintf "%*g" 14 42.42 = " 42.42"); + test (sprintf "%.3g" (-42.42) = "-42.4"); -(* Same for %G printf "\nG\n%!"; -*) + test (sprintf "%G" (-42.42) = "-42.42"); + test (sprintf "%.3G" (-4242.) =* "-4.24E+03"); + test (sprintf "%-15G" (-42.42) = "-42.42 "); + test (sprintf "%015G" (-42.42) = "-00000000042.42"); + test (sprintf "%+G" 42.42 = "+42.42"); + test (sprintf "% G" 42.42 = " 42.42"); + test (sprintf "%15G" 42.42 = " 42.42"); + test (sprintf "%*G" 14 42.42 = " 42.42"); + test (sprintf "%.3G" (-42.42) = "-42.4"); printf "\nB\n%!"; test (sprintf "%B" true = "true"); diff --git a/testsuite/tests/lib-printf/tprintf.reference b/testsuite/tests/lib-printf/tprintf.reference index af593cd4..a1b6b815 100644 --- a/testsuite/tests/lib-printf/tprintf.reference +++ b/testsuite/tests/lib-printf/tprintf.reference @@ -29,67 +29,71 @@ C f 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 F - 107 108 109 110 111 112 113 + 107 108 109 110 111 112 113 114 115 116 117 118 h - 114 115 116 117 118 119 120 121 122 123 124 125 126 + 119 120 121 122 123 124 125 126 127 128 129 130 131 H - 127 128 129 130 131 132 133 134 135 136 137 138 139 + 132 133 134 135 136 137 138 139 140 141 142 143 144 e - 140 141 142 143 144 145 146 147 148 149 150 151 152 153 + 145 146 147 148 149 150 151 152 153 154 155 156 157 158 E - 154 155 156 157 158 159 160 161 162 163 164 165 166 167 + 159 160 161 162 163 164 165 166 167 168 169 170 171 172 +g + 173 174 175 176 177 178 179 180 181 +G + 182 183 184 185 186 187 188 189 190 B - 168 169 170 171 + 191 192 193 194 ld/li positive - 172 173 174 175 176 177 178 + 195 196 197 198 199 200 201 ld/li negative - 179 180 181 182 183 184 185 + 202 203 204 205 206 207 208 lu positive - 186 187 188 189 190 + 209 210 211 212 213 lu negative - 191 + 214 lx positive - 192 193 194 195 196 197 + 215 216 217 218 219 220 lx negative - 198 + 221 lX positive - 199 200 201 202 203 204 + 222 223 224 225 226 227 lx negative - 205 + 228 lo positive - 206 207 208 209 210 211 + 229 230 231 232 233 234 lo negative - 212 + 235 Ld/Li positive - 213 214 215 216 217 + 236 237 238 239 240 Ld/Li negative - 218 219 220 221 222 + 241 242 243 244 245 Lu positive - 223 224 225 226 227 + 246 247 248 249 250 Lu negative - 228 + 251 Lx positive - 229 230 231 232 233 234 + 252 253 254 255 256 257 Lx negative - 235 + 258 LX positive - 236 237 238 239 240 241 + 259 260 261 262 263 264 Lx negative - 242 + 265 Lo positive - 243 244 245 246 247 248 + 266 267 268 269 270 271 Lo negative - 249 + 272 a - 250 + 273 t - 251 + 274 {...%} - 252 + 275 (...%) - 253 + 276 ! % @ , and constants - 254 255 256 257 258 259 260 + 277 278 279 280 281 282 283 end of tests All tests succeeded. diff --git a/testsuite/tests/lib-stream/mpr7769.ml b/testsuite/tests/lib-stream/mpr7769.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/lib-stream/mpr7769.reference b/testsuite/tests/lib-stream/mpr7769.reference old mode 100755 new mode 100644 diff --git a/testsuite/tests/lib-systhreads/ocamltests b/testsuite/tests/lib-systhreads/ocamltests index 4723c9f1..ccae4b47 100644 --- a/testsuite/tests/lib-systhreads/ocamltests +++ b/testsuite/tests/lib-systhreads/ocamltests @@ -1,3 +1,4 @@ testfork.ml testpreempt.ml +testyield.ml threadsigmask.ml diff --git a/testsuite/tests/lib-systhreads/testyield.ml b/testsuite/tests/lib-systhreads/testyield.ml new file mode 100644 index 00000000..30e70ce9 --- /dev/null +++ b/testsuite/tests/lib-systhreads/testyield.ml @@ -0,0 +1,51 @@ +(* TEST + (* Test that yielding between busy threads reliably triggers a thread + switch. *) + include systhreads + * not-windows + ** bytecode + ** native +*) + +let threads = 4 + +let are_ready = ref 0 + +let yields = ref 0 + +let iters = 50000 + +let last = ref (-1) + +let report thread run_length = + (* The below loop tests how many times in a row a loop that calls yield runs + without changing threads. Ideally the answer would *always* be one, but + it's not clear we can reliably guarantee that unless nothing else ever + drops the Ocaml lock, so instead just rely on it being small. *) + if run_length > 3 + then Printf.printf "Thread %d ran %d consecutive iters\n" thread run_length + + +let threads = + List.init threads (Thread.create (fun i -> + incr are_ready; + (* Don't make any progress until all threads are spawned and properly + contending for the Ocaml lock. *) + while !are_ready < threads do + Thread.yield () + done; + let consecutive = ref 0 in + while !yields < iters do + incr yields; + last := i; + Thread.yield (); + incr consecutive; + if not (!last = i) + then ( + report i !consecutive; + consecutive := 0) + done; + if !consecutive > 0 then report i !consecutive; + ));; + +List.iter Thread.join threads diff --git a/testsuite/tests/lib-threads/delayintr.ml b/testsuite/tests/lib-threads/delayintr.ml new file mode 100644 index 00000000..03f63a10 --- /dev/null +++ b/testsuite/tests/lib-threads/delayintr.ml @@ -0,0 +1,61 @@ +(* TEST + +* hassysthreads +include systhreads + +files = "sigint.c" + +** libunix (* excludes mingw32/64 and msvc32/64 *) + +*** setup-ocamlc.byte-build-env + +program = "${test_build_directory}/delayintr.byte" + +**** ocamlc.byte + +program = "sigint" +all_modules = "sigint.c" + +***** ocamlc.byte + +program = "${test_build_directory}/delayintr.byte" +all_modules = "delayintr.ml" + +****** check-ocamlc.byte-output +******* run +******** check-program-output + +*** setup-ocamlopt.byte-build-env + +program = "${test_build_directory}/delayintr.opt" + +**** ocamlopt.byte + +program = "sigint" +all_modules = "sigint.c" + +***** ocamlopt.byte + +program = "${test_build_directory}/delayintr.opt" +all_modules = "delayintr.ml" + +****** check-ocamlopt.byte-output +******* run +******** check-program-output + +*) + +(* Regression test for MPR#7903 *) + +let () = + let start = Unix.gettimeofday() in + let sighandler _ = + let now = Unix.gettimeofday() in + if now -. start <= 20. then begin + print_string "Received signal early\n"; exit 0 + end else begin + print_string "Received signal late\n"; exit 2 + end in + Sys.set_signal Sys.sigint (Sys.Signal_handle sighandler); + Thread.delay 30.; + print_string "No signal received\n"; exit 4 diff --git a/testsuite/tests/lib-threads/delayintr.reference b/testsuite/tests/lib-threads/delayintr.reference new file mode 100644 index 00000000..32476d36 --- /dev/null +++ b/testsuite/tests/lib-threads/delayintr.reference @@ -0,0 +1 @@ +Received signal early diff --git a/testsuite/tests/lib-threads/delayintr.run b/testsuite/tests/lib-threads/delayintr.run new file mode 100644 index 00000000..1611435d --- /dev/null +++ b/testsuite/tests/lib-threads/delayintr.run @@ -0,0 +1,5 @@ +${program} > ${output} & +pid=$! +sleep 2 +./sigint $pid +wait diff --git a/testsuite/tests/lib-threads/ocamltests b/testsuite/tests/lib-threads/ocamltests index 1df74eb5..54350865 100644 --- a/testsuite/tests/lib-threads/ocamltests +++ b/testsuite/tests/lib-threads/ocamltests @@ -3,6 +3,7 @@ bank.ml beat.ml bufchan.ml close.ml +delayintr.ml fileio.ml pr4466.ml pr5325.ml diff --git a/testsuite/tests/lib-threads/pr4466.ml b/testsuite/tests/lib-threads/pr4466.ml index e09fee1b..0cda04a7 100644 --- a/testsuite/tests/lib-threads/pr4466.ml +++ b/testsuite/tests/lib-threads/pr4466.ml @@ -1,7 +1,9 @@ (* TEST * hassysthreads -include systhreads + include systhreads +** native + compare_programs = "false" *) diff --git a/testsuite/tests/lib-unix/common/wait_nohang.ml b/testsuite/tests/lib-unix/common/wait_nohang.ml index fb4cacb9..5d6e73e5 100644 --- a/testsuite/tests/lib-unix/common/wait_nohang.ml +++ b/testsuite/tests/lib-unix/common/wait_nohang.ml @@ -1,17 +1,52 @@ (* TEST + +files = "reflector.ml" + * hasunix +** setup-ocamlc.byte-build-env +program = "${test_build_directory}/wait_nohang.byte" +*** ocamlc.byte +program = "${test_build_directory}/reflector.exe" +all_modules = "reflector.ml" +**** ocamlc.byte +include unix +program = "${test_build_directory}/wait_nohang.byte" +all_modules= "wait_nohang.ml" +***** check-ocamlc.byte-output +****** run +******* check-program-output + +** setup-ocamlopt.byte-build-env +program = "${test_build_directory}/wait_nohang.opt" +*** ocamlopt.byte +program = "${test_build_directory}/reflector.exe" +all_modules = "reflector.ml" +**** ocamlopt.byte include unix +program = "${test_build_directory}/wait_nohang.opt" +all_modules= "wait_nohang.ml" +***** check-ocamlopt.byte-output +****** run +******* check-program-output + *) +let refl = + Filename.concat Filename.current_dir_name "reflector.exe" + let () = - let fd = Unix.openfile "plop" [O_CREAT; O_WRONLY] 0o666 in - let pid = - Unix.create_process "echo" [|"echo"; "toto"|] Unix.stdin fd Unix.stderr - in - Unix.close fd; - while fst (Unix.waitpid [WNOHANG] pid) = 0 do - Unix.sleepf 0.001 - done; - match Sys.remove "plop" with - | () -> print_endline "OK" - | exception (Sys_error _) -> print_endline "ERROR" + let oc = Unix.open_process_out (refl ^ " -i2o") in + let pid = Unix.process_out_pid oc in + let (pid1, status1) = Unix.waitpid [WNOHANG] pid in + assert (pid1 = 0); + assert (status1 = WEXITED 0); + output_string oc "aa\n"; close_out oc; + let rec busywait () = + let (pid2, status2) = Unix.waitpid [WNOHANG] pid in + if pid2 = 0 then begin + Unix.sleepf 0.001; busywait() + end else begin + assert (pid2 = pid); + assert (status2 = WEXITED 0) + end + in busywait() diff --git a/testsuite/tests/lib-unix/common/wait_nohang.reference b/testsuite/tests/lib-unix/common/wait_nohang.reference index d86bac9d..e61ef7b9 100644 --- a/testsuite/tests/lib-unix/common/wait_nohang.reference +++ b/testsuite/tests/lib-unix/common/wait_nohang.reference @@ -1 +1 @@ -OK +aa diff --git a/testsuite/tests/lib-unix/unix-socket/is-linux.sh b/testsuite/tests/lib-unix/unix-socket/is-linux.sh new file mode 100755 index 00000000..80815e84 --- /dev/null +++ b/testsuite/tests/lib-unix/unix-socket/is-linux.sh @@ -0,0 +1,21 @@ +#!/bin/sh + +# This script is related to the 'recvfrom_linux.ml' test. + +uname="$(uname -s)" +if [ "$uname" = "Linux" ]; then + +# Workaround: the tests that come after this script +# (bytecode and native) depend on stdout redirection, but +# running a script sets both of those to the empty string. +# See https://caml.inria.fr/mantis/view.php?id=7910 + cat > "$ocamltest_response" < "$ocamltest_response" + exit ${TEST_SKIP} +fi diff --git a/testsuite/tests/lib-unix/unix-socket/ocamltests b/testsuite/tests/lib-unix/unix-socket/ocamltests new file mode 100644 index 00000000..34b36e47 --- /dev/null +++ b/testsuite/tests/lib-unix/unix-socket/ocamltests @@ -0,0 +1,2 @@ +recvfrom_unix.ml +recvfrom_linux.ml diff --git a/testsuite/tests/lib-unix/unix-socket/recvfrom.ml b/testsuite/tests/lib-unix/unix-socket/recvfrom.ml new file mode 100644 index 00000000..f18e0846 --- /dev/null +++ b/testsuite/tests/lib-unix/unix-socket/recvfrom.ml @@ -0,0 +1,33 @@ +open Unix + +let path_of_addr = function + | ADDR_UNIX path -> path + | _ -> assert false +;; + +let test_sender ~client_socket ~server_socket ~server_addr ~client_addr = + Printf.printf "%S" (path_of_addr client_addr); + let byte = Bytes.make 1 't' in + let sent_len = sendto client_socket byte 0 1 [] server_addr in + assert (sent_len = 1); + let buf = Bytes.make 1024 '\x00' in + let (recv_len, sender) = recvfrom server_socket buf 0 1024 [] in + + Printf.printf " as %S: " (path_of_addr sender); + assert (sender = client_addr); + assert (Bytes.sub_string buf 0 recv_len = "t"); + print_endline "OK";; + +let ensure_no_file path = + try unlink path with Unix_error (ENOENT, _, _) -> ();; + +let with_socket fn = + let s = socket PF_UNIX SOCK_DGRAM 0 in + Fun.protect ~finally:(fun () -> close s) (fun () -> fn s) + +let with_bound_socket path fn = + with_socket (fun s -> + let addr = ADDR_UNIX path in + bind s addr; + fn addr s + ) diff --git a/testsuite/tests/lib-unix/unix-socket/recvfrom_linux.ml b/testsuite/tests/lib-unix/unix-socket/recvfrom_linux.ml new file mode 100644 index 00000000..73fa3fb2 --- /dev/null +++ b/testsuite/tests/lib-unix/unix-socket/recvfrom_linux.ml @@ -0,0 +1,21 @@ +(* TEST +include unix +modules = "recvfrom.ml" +script = "sh ${test_source_directory}/is-linux.sh" +* hasunix +** script +*** bytecode +*** native +*) +open Recvfrom + +let () = + let server_path = "ocaml-test-socket-linux" in + ensure_no_file server_path; + at_exit (fun () -> ensure_no_file server_path); + with_bound_socket server_path (fun server_addr server_socket -> + (* abstract socket *) + with_bound_socket "\x00ocaml-abstract-socket" (fun client_addr client_socket -> + test_sender ~client_socket ~server_socket ~server_addr ~client_addr + ); + ) diff --git a/testsuite/tests/lib-unix/unix-socket/recvfrom_linux.reference b/testsuite/tests/lib-unix/unix-socket/recvfrom_linux.reference new file mode 100644 index 00000000..df4d7cb0 --- /dev/null +++ b/testsuite/tests/lib-unix/unix-socket/recvfrom_linux.reference @@ -0,0 +1 @@ +"\000ocaml-abstract-socket" as "\000ocaml-abstract-socket": OK diff --git a/testsuite/tests/lib-unix/unix-socket/recvfrom_unix.ml b/testsuite/tests/lib-unix/unix-socket/recvfrom_unix.ml new file mode 100644 index 00000000..dc66b169 --- /dev/null +++ b/testsuite/tests/lib-unix/unix-socket/recvfrom_unix.ml @@ -0,0 +1,23 @@ +(* TEST +include unix +modules = "recvfrom.ml" +* not-windows +** bytecode +** native +*) +open Recvfrom + +let () = + let server_path = "ocaml-test-socket-unix" in + ensure_no_file server_path; + at_exit (fun () -> ensure_no_file server_path); + with_bound_socket server_path (fun server_addr server_socket -> + (* path socket, just reuse server addr *) + test_sender ~client_socket:server_socket ~server_socket ~server_addr ~client_addr:server_addr; + + (* unnamed socket *) + with_socket (fun client_socket -> + (* unbound socket should be treated as empty path *) + test_sender ~client_socket ~server_socket ~server_addr ~client_addr:(ADDR_UNIX "") + ) + ) diff --git a/testsuite/tests/lib-unix/unix-socket/recvfrom_unix.reference b/testsuite/tests/lib-unix/unix-socket/recvfrom_unix.reference new file mode 100644 index 00000000..26bbaa40 --- /dev/null +++ b/testsuite/tests/lib-unix/unix-socket/recvfrom_unix.reference @@ -0,0 +1,2 @@ +"ocaml-test-socket-unix" as "ocaml-test-socket-unix": OK +"" as "": OK diff --git a/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml b/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml index 8b6bb3fd..4a16ada8 100644 --- a/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml +++ b/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml @@ -16,7 +16,7 @@ let test_match_exhaustiveness () = ;; [%%expect{| -Line 8, characters 4-83: +Lines 8-11, characters 4-16: 8 | ....match None with 9 | | exception e -> () 10 | | Some false -> () @@ -35,7 +35,7 @@ let test_match_exhaustiveness_nest1 () = ;; [%%expect{| -Line 2, characters 4-73: +Lines 2-4, characters 4-30: 2 | ....match None with 3 | | Some false -> () 4 | | None | exception _ -> () @@ -53,7 +53,7 @@ let test_match_exhaustiveness_nest2 () = ;; [%%expect{| -Line 2, characters 4-73: +Lines 2-4, characters 4-16: 2 | ....match None with 3 | | Some false | exception _ -> () 4 | | None -> () @@ -72,7 +72,7 @@ let test_match_exhaustiveness_full () = ;; [%%expect{| -Line 2, characters 4-111: +Lines 2-5, characters 4-30: 2 | ....match None with 3 | | exception e -> () 4 | | Some false | exception _ -> () diff --git a/testsuite/tests/misc/sorts.ml b/testsuite/tests/misc/sorts.ml index 1f76de0c..f336181a 100644 --- a/testsuite/tests/misc/sorts.ml +++ b/testsuite/tests/misc/sorts.ml @@ -4164,24 +4164,6 @@ let ainsertion_1 cmp a = done; ;; -(************************************************************************) -(* merge sort on lists via arrays *) - -let array_to_list_in_place a = - let l = Array.length a in - let rec loop accu n p = - if p <= 0 then accu else begin - if p = n then begin - Obj.truncate (Obj.repr a) p; - loop (a.(p-1) :: accu) (n-1000) (p-1) - end else begin - loop (a.(p-1) :: accu) n (p-1) - end - end - in - loop [] l l -;; - let array_of_list l len = match l with | [] -> [| |] @@ -4199,7 +4181,7 @@ let array_of_list l len = let lmerge_0a cmp l = let a = Array.of_list l in amerge_1e cmp a; - array_to_list_in_place a + Array.to_list a ;; let lmerge_0b cmp l = @@ -4207,19 +4189,19 @@ let lmerge_0b cmp l = if len > 256 then Gc.minor (); let a = array_of_list l len in amerge_1e cmp a; - array_to_list_in_place a + Array.to_list a ;; let lshell_0 cmp l = let a = Array.of_list l in ashell_2 cmp a; - array_to_list_in_place a + Array.to_list a ;; let lquick_0 cmp l = let a = Array.of_list l in aquick_3f cmp a; - array_to_list_in_place a + Array.to_list a ;; (************************************************************************) diff --git a/testsuite/tests/parsetree/source.ml b/testsuite/tests/parsetree/source.ml index a183f448..93a0d263 100644 --- a/testsuite/tests/parsetree/source.ml +++ b/testsuite/tests/parsetree/source.ml @@ -7364,3 +7364,11 @@ let x = ` (* wait for it *) Bar type (+' a, -' a', ' a'b', 'ab', ' abcd', ' (* ! *) x) t = ' a * ' a' * ' a'b' * 'ab' * ' abcd' * ' (* !! *) x as ' a' + +(* #2190 *) + +let f = function + | lazy (A foo) -> foo + +let () = + f (fun (type t) -> x) diff --git a/testsuite/tests/ppx-contexts/myppx.ml b/testsuite/tests/ppx-contexts/myppx.ml index a42f0721..76c80d64 100644 --- a/testsuite/tests/ppx-contexts/myppx.ml +++ b/testsuite/tests/ppx-contexts/myppx.ml @@ -28,8 +28,6 @@ let () = !Clflags.debug; Printf.eprintf "use_threads: %B\n" !Clflags.use_threads; - Printf.eprintf "use_vmthreads: %B\n" - !Clflags.use_vmthreads; Printf.eprintf "recursive_types: %B\n" !Clflags.recursive_types; Printf.eprintf "principal: %B\n" diff --git a/testsuite/tests/ppx-contexts/test.compilers.reference b/testsuite/tests/ppx-contexts/test.compilers.reference index c6f393f8..b3486e40 100644 --- a/testsuite/tests/ppx-contexts/test.compilers.reference +++ b/testsuite/tests/ppx-contexts/test.compilers.reference @@ -4,25 +4,18 @@ open_modules: ["List"] for_package: "None" use_debug: false use_threads: true -use_vmthreads: false recursive_types: true principal: true transparent_modules: false unboxed_types: true unsafe_string: false -File "_none_", line 1: -Alert deprecated: The -vmthread argument of ocamlc is deprecated -since OCaml 4.08.0. Please switch to system threads, which have the -same API. Lightweight threads with VM-level scheduling are provided by -third-party libraries such as Lwt, but with a different API. tool_name: "ocamlc" open_modules: [] for_package: "None" use_debug: true use_threads: false -use_vmthreads: true recursive_types: false principal: false transparent_modules: true diff --git a/testsuite/tests/ppx-contexts/test.ml b/testsuite/tests/ppx-contexts/test.ml index 3a9719e9..e61840c4 100644 --- a/testsuite/tests/ppx-contexts/test.ml +++ b/testsuite/tests/ppx-contexts/test.ml @@ -18,8 +18,7 @@ flags = "-thread \ -ppx ${program}" **** ocamlc.byte module = "test.ml" -flags = "-vmthread \ - -g \ +flags = "-g \ -no-alias-deps \ -no-unboxed-types \ -unsafe-string \ diff --git a/testsuite/tests/printing-types/disambiguation.ml b/testsuite/tests/printing-types/disambiguation.ml new file mode 100644 index 00000000..24c431a1 --- /dev/null +++ b/testsuite/tests/printing-types/disambiguation.ml @@ -0,0 +1,42 @@ +(* TEST + * expect +*) + +type 'a x = private [> `x] as 'a;; +[%%expect {| +Line 1: +Error: Type declarations do not match: + type 'a x = private [> `x ] constraint 'a = 'a x + is not included in + type 'a x + Their constraints differ. +|}, Principal{| +Line 1: +Error: Type declarations do not match: + type 'a x = private 'a constraint 'a = [> `x ] + is not included in + type 'a x + Their constraints differ. +|}];; + + +type int;; +[%%expect {| +type int +|}];; + +let x = 0;; +[%%expect {| +val x : int/2 = 0 +|}];; + + +type float;; +[%%expect {| +type float +|}];; + +0.;; +[%%expect {| +- : float/2 = 0. +|}];; diff --git a/testsuite/tests/printing-types/ocamltests b/testsuite/tests/printing-types/ocamltests index 3a974ca8..a97308a9 100644 --- a/testsuite/tests/printing-types/ocamltests +++ b/testsuite/tests/printing-types/ocamltests @@ -1 +1,2 @@ +disambiguation.ml pr248.ml diff --git a/testsuite/tests/self-contained-toplevel/main.ml b/testsuite/tests/self-contained-toplevel/main.ml index 5bd6b61f..4be67c87 100644 --- a/testsuite/tests/self-contained-toplevel/main.ml +++ b/testsuite/tests/self-contained-toplevel/main.ml @@ -21,11 +21,12 @@ arguments = "input.ml" let () = (* Make sure it's no longer available on disk *) if Sys.file_exists "foo.cmi" then Sys.remove "foo.cmi"; - let old_loader = !Env.Persistent_signature.load in - Env.Persistent_signature.load := (fun ~unit_name -> + let module Persistent_signature = Persistent_env.Persistent_signature in + let old_loader = !Persistent_signature.load in + Persistent_signature.load := (fun ~unit_name -> match unit_name with | "Foo" -> - Some { Env.Persistent_signature. + Some { Persistent_signature. filename = Sys.executable_name ; cmi = Marshal.from_string Cached_cmi.foo 0 } diff --git a/testsuite/tests/tool-debugger/printer/debuggee.ml b/testsuite/tests/tool-debugger/printer/debuggee.ml new file mode 100644 index 00000000..3289f518 --- /dev/null +++ b/testsuite/tests/tool-debugger/printer/debuggee.ml @@ -0,0 +1,22 @@ +(* TEST +flags += " -g " +ocamldebug_script = "${test_source_directory}/input_script" +files = "printer.ml" +include debugger +* debugger +** shared-libraries +*** setup-ocamlc.byte-build-env +**** ocamlc.byte +module = "printer.ml" +**** ocamlc.byte +***** check-ocamlc.byte-output +****** ocamldebug +******* check-program-output +*) + +let f x = + for _i = 0 to x do + print_endline "..." + done + +let () = f 3 diff --git a/testsuite/tests/tool-debugger/printer/debuggee.reference b/testsuite/tests/tool-debugger/printer/debuggee.reference new file mode 100644 index 00000000..2d06dde6 --- /dev/null +++ b/testsuite/tests/tool-debugger/printer/debuggee.reference @@ -0,0 +1,5 @@ +File printer.cmo loaded +Loading program... done. +Breakpoint: 1 +18 <|b|>for _i = 0 to x do +x: int = S S O diff --git a/testsuite/tests/tool-debugger/printer/input_script b/testsuite/tests/tool-debugger/printer/input_script new file mode 100644 index 00000000..b1279f60 --- /dev/null +++ b/testsuite/tests/tool-debugger/printer/input_script @@ -0,0 +1,7 @@ +load_printer printer.cmo +install_printer Printer.p +set print_depth 2 +break @ Debuggee 18 +run +print x +quit diff --git a/testsuite/tests/tool-debugger/printer/ocamltests b/testsuite/tests/tool-debugger/printer/ocamltests new file mode 100644 index 00000000..4f8025c7 --- /dev/null +++ b/testsuite/tests/tool-debugger/printer/ocamltests @@ -0,0 +1 @@ +debuggee.ml diff --git a/testsuite/tests/tool-debugger/printer/printer.ml b/testsuite/tests/tool-debugger/printer/printer.ml new file mode 100644 index 00000000..6ad8f615 --- /dev/null +++ b/testsuite/tests/tool-debugger/printer/printer.ml @@ -0,0 +1,8 @@ +let p : Format.formatter -> int -> unit = fun fmt n -> + (* We use `max_printer_depth` to tweak the output so that + this test shows that the printer not only compiles + against the debugger's code, but also uses its state. *) + for _i = 1 to min n !Printval.max_printer_depth do + Format.pp_print_string fmt "S "; + done; + Format.pp_print_string fmt "O" diff --git a/testsuite/tests/tool-ocamldep-shadowing/a.ml b/testsuite/tests/tool-ocamldep-shadowing/a.ml new file mode 100644 index 00000000..31973b40 --- /dev/null +++ b/testsuite/tests/tool-ocamldep-shadowing/a.ml @@ -0,0 +1,13 @@ +(* TEST + +* setup-ocamlc.byte-build-env +** script +script = "cp -R ${test_source_directory}/dir1 ${test_source_directory}/dir2 ." +*** ocamlc.byte +commandline = "-depend -slash -I dir1 -I dir2 a.ml" +**** check-ocamlc.byte-output +compiler_reference = "${test_source_directory}/a.reference" +*) + +include B +include C diff --git a/testsuite/tests/tool-ocamldep-shadowing/a.reference b/testsuite/tests/tool-ocamldep-shadowing/a.reference new file mode 100644 index 00000000..c7458e19 --- /dev/null +++ b/testsuite/tests/tool-ocamldep-shadowing/a.reference @@ -0,0 +1,6 @@ +a.cmo : \ + dir2/c.cmi \ + dir1/b.cmo +a.cmx : \ + dir2/c.cmi \ + dir1/b.cmx diff --git a/testsuite/tests/tool-ocamldep-shadowing/dir1/b.ml b/testsuite/tests/tool-ocamldep-shadowing/dir1/b.ml new file mode 100644 index 00000000..e69de29b diff --git a/testsuite/tests/tool-ocamldep-shadowing/dir2/b.mli b/testsuite/tests/tool-ocamldep-shadowing/dir2/b.mli new file mode 100644 index 00000000..e69de29b diff --git a/testsuite/tests/tool-ocamldep-shadowing/dir2/c.mli b/testsuite/tests/tool-ocamldep-shadowing/dir2/c.mli new file mode 100644 index 00000000..e69de29b diff --git a/testsuite/tests/tool-ocamldep-shadowing/ocamltests b/testsuite/tests/tool-ocamldep-shadowing/ocamltests new file mode 100644 index 00000000..c2790eaf --- /dev/null +++ b/testsuite/tests/tool-ocamldep-shadowing/ocamltests @@ -0,0 +1 @@ +a.ml diff --git a/testsuite/tests/tool-toplevel-invocation/print_args.ml b/testsuite/tests/tool-toplevel-invocation/print_args.ml new file mode 100644 index 00000000..d4b84485 --- /dev/null +++ b/testsuite/tests/tool-toplevel-invocation/print_args.ml @@ -0,0 +1 @@ +Array.iter (fun x -> print_endline (Filename.basename x)) Sys.argv;; diff --git a/testsuite/tests/tool-toplevel-invocation/print_args.reference b/testsuite/tests/tool-toplevel-invocation/print_args.reference new file mode 100644 index 00000000..186b46a3 --- /dev/null +++ b/testsuite/tests/tool-toplevel-invocation/print_args.reference @@ -0,0 +1,3 @@ +print_args.ml +foo +bar diff --git a/testsuite/tests/tool-toplevel-invocation/test.ml b/testsuite/tests/tool-toplevel-invocation/test.ml index 1229e5db..8beae14f 100644 --- a/testsuite/tests/tool-toplevel-invocation/test.ml +++ b/testsuite/tests/tool-toplevel-invocation/test.ml @@ -40,6 +40,12 @@ compiler_reference = "${test_source_directory}/working_arg.txt.reference" compiler_output = "${test_build_directory}/working_arg.output" *** check-ocaml-output +** ocaml +flags = "${test_source_directory}/print_args.ml foo bar" +compiler_reference = "${test_source_directory}/print_args.reference" +compiler_output = "${test_build_directory}/print_args.output" +*** check-ocaml-output + *) printf "Test succeeds\n";; diff --git a/testsuite/tests/tool-toplevel/error_highlighting.compilers.reference b/testsuite/tests/tool-toplevel/error_highlighting.compilers.reference index d1e221ec..c0edb9c5 100644 --- a/testsuite/tests/tool-toplevel/error_highlighting.compilers.reference +++ b/testsuite/tests/tool-toplevel/error_highlighting.compilers.reference @@ -24,6 +24,7 @@ Line 3, characters 8-9: ^ Error: This expression has type int but an expression was expected of type float + Hint: Did you mean `1.'? Line 4, characters 2-4: 4 | 2 in ^^ @@ -32,7 +33,7 @@ Line 2, characters 8-9: 2 | let x = (1 ^ This '(' might be unmatched -Line 2, characters 8-17: +Lines 2-4, characters 8-2: 2 | ........(1 3 | + 4 | 2)... @@ -59,7 +60,7 @@ File "error_highlighting_use3.ml", line 1, characters 8-9: 1 | let x = (1 ^ This '(' might be unmatched -File "error_highlighting_use4.ml", line 1, characters 8-17: +File "error_highlighting_use4.ml", lines 1-3, characters 8-2: 1 | ........(1 2 | + 3 | 2)... diff --git a/testsuite/tests/tool-toplevel/ocamltests b/testsuite/tests/tool-toplevel/ocamltests index 28d1ff56..b8c2470b 100644 --- a/testsuite/tests/tool-toplevel/ocamltests +++ b/testsuite/tests/tool-toplevel/ocamltests @@ -5,3 +5,4 @@ pr7751.ml strings.ml tracing.ml error_highlighting.ml +uncaught_exceptions.ml diff --git a/testsuite/tests/tool-toplevel/uncaught_exceptions.ml b/testsuite/tests/tool-toplevel/uncaught_exceptions.ml new file mode 100644 index 00000000..3544e1dd --- /dev/null +++ b/testsuite/tests/tool-toplevel/uncaught_exceptions.ml @@ -0,0 +1,45 @@ +(* TEST + * expect +*) + +(* PR#8594 *) +Printexc.register_printer (fun e -> + match e with + | Division_by_zero -> Some "A division by zero is undefined" + | _ -> None);; +[%%expect{| +- : unit = () +|}];; + +Printexc.register_printer (fun e -> + match e with + | Exit -> Some "Catching an exit" + | _ -> None);; +[%%expect{| +- : unit = () +|}];; + +raise Not_found;; +[%%expect{| +Exception: Not_found. +|}];; + +raise Exit;; +[%%expect{| +Exception: Catching an exit +|}];; + +exception Foo of string;; +[%%expect {| +exception Foo of string +|}];; + +raise (Foo "bar");; +[%%expect {| +Exception: Foo "bar". +|}];; + +raise Division_by_zero;; +[%%expect {| +Exception: A division by zero is undefined +|}];; diff --git a/testsuite/tests/typing-core-bugs/const_int_hint.ml b/testsuite/tests/typing-core-bugs/const_int_hint.ml new file mode 100644 index 00000000..bc4b528b --- /dev/null +++ b/testsuite/tests/typing-core-bugs/const_int_hint.ml @@ -0,0 +1,152 @@ +(* TEST + * expect +*) + +let _ = Int32.(add 1 2l);; +[%%expect{| +Line 1, characters 19-20: +1 | let _ = Int32.(add 1 2l);; + ^ +Error: This expression has type int but an expression was expected of type + int32 + Hint: Did you mean `1l'? +|}] + +let _ : int32 * int32 = 42l, 43;; +[%%expect{| +Line 1, characters 29-31: +1 | let _ : int32 * int32 = 42l, 43;; + ^^ +Error: This expression has type int but an expression was expected of type + int32 + Hint: Did you mean `43l'? +|}] + +let _ : int32 * nativeint = 42l, 43;; +[%%expect{| +Line 1, characters 33-35: +1 | let _ : int32 * nativeint = 42l, 43;; + ^^ +Error: This expression has type int but an expression was expected of type + nativeint + Hint: Did you mean `43n'? +|}] + +let _ = min 6L 7;; +[%%expect{| +Line 1, characters 15-16: +1 | let _ = min 6L 7;; + ^ +Error: This expression has type int but an expression was expected of type + int64 + Hint: Did you mean `7L'? +|}] + +let _ : float = 123;; +[%%expect{| +Line 1, characters 16-19: +1 | let _ : float = 123;; + ^^^ +Error: This expression has type int but an expression was expected of type + float + Hint: Did you mean `123.'? +|}] + +(* no hint *) +let x = 0 +let _ = Int32.(add x 2l);; +[%%expect{| +val x : int = 0 +Line 2, characters 19-20: +2 | let _ = Int32.(add x 2l);; + ^ +Error: This expression has type int but an expression was expected of type + int32 +|}] + +(* pattern *) +let _ : int32 -> int32 = function + | 0 -> 0l + | x -> x +[%%expect{| +Line 2, characters 4-5: +2 | | 0 -> 0l + ^ +Error: This pattern matches values of type int + but a pattern was expected which matches values of type int32 + Hint: Did you mean `0l'? +|}, Principal{| +Line 2, characters 4-5: +2 | | 0 -> 0l + ^ +Error: This pattern matches values of type int + but a pattern was expected which matches values of type int32 +|}] + +let _ : int64 -> int64 = function + | 1L | 2 -> 3L + | x -> x;; +[%%expect{| +Line 2, characters 9-10: +2 | | 1L | 2 -> 3L + ^ +Error: This pattern matches values of type int + but a pattern was expected which matches values of type int64 + Hint: Did you mean `2L'? +|}] + +(* symmetric *) +let _ : int32 = 1L;; +[%%expect{| +Line 1, characters 16-18: +1 | let _ : int32 = 1L;; + ^^ +Error: This expression has type int64 but an expression was expected of type + int32 + Hint: Did you mean `1l'? +|}] +let _ : float = 1L;; +[%%expect{| +Line 1, characters 16-18: +1 | let _ : float = 1L;; + ^^ +Error: This expression has type int64 but an expression was expected of type + float + Hint: Did you mean `1.'? +|}] +let _ : int64 = 1n;; +[%%expect{| +Line 1, characters 16-18: +1 | let _ : int64 = 1n;; + ^^ +Error: This expression has type nativeint + but an expression was expected of type int64 + Hint: Did you mean `1L'? +|}] +let _ : nativeint = 1l;; +[%%expect{| +Line 1, characters 20-22: +1 | let _ : nativeint = 1l;; + ^^ +Error: This expression has type int32 but an expression was expected of type + nativeint + Hint: Did you mean `1n'? +|}] + +(* not implemented *) +let _ : int64 = 0.;; +[%%expect{| +Line 1, characters 16-18: +1 | let _ : int64 = 0.;; + ^^ +Error: This expression has type float but an expression was expected of type + int64 +|}] +let _ : int = 1L;; +[%%expect{| +Line 1, characters 14-16: +1 | let _ : int = 1L;; + ^^ +Error: This expression has type int64 but an expression was expected of type + int +|}] diff --git a/testsuite/tests/typing-core-bugs/ocamltests b/testsuite/tests/typing-core-bugs/ocamltests index 089ea717..02cb7e3e 100644 --- a/testsuite/tests/typing-core-bugs/ocamltests +++ b/testsuite/tests/typing-core-bugs/ocamltests @@ -2,3 +2,4 @@ missing_rec_hint.ml unit_fun_hints.ml type_expected_explanation.ml repeated_did_you_mean.ml +const_int_hint.ml diff --git a/testsuite/tests/typing-core-bugs/repeated_did_you_mean.ml b/testsuite/tests/typing-core-bugs/repeated_did_you_mean.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/typing-deprecated/alerts.ml b/testsuite/tests/typing-deprecated/alerts.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/typing-extensions/extensions.ml b/testsuite/tests/typing-extensions/extensions.ml index f4867449..bdd0ff3b 100644 --- a/testsuite/tests/typing-extensions/extensions.ml +++ b/testsuite/tests/typing-extensions/extensions.ml @@ -1,47 +1,87 @@ (* TEST - * toplevel + * expect *) (* Ignore OCAMLRUNPARAM=b to be reproducible *) Printexc.record_backtrace false;; +[%%expect {| +- : unit = () +|}] type foo = .. ;; +[%%expect {| +type foo = .. +|}] type foo += A | B of int ;; +[%%expect {| +type foo += A | B of int +|}] let is_a x = match x with A -> true | _ -> false ;; +[%%expect {| +val is_a : foo -> bool = +|}] (* The type must be open to create extension *) type foo ;; +[%%expect {| +type foo +|}] -type foo += A of int (* Error type is not open *) +type foo += A of int ;; +[%%expect {| +Line 1, characters 0-20: +1 | type foo += A of int + ^^^^^^^^^^^^^^^^^^^^ +Error: Type definition foo is not extensible +|}] (* The type must be public to create extension *) type foo = private .. ;; +[%%expect {| +type foo = private .. +|}] -type foo += A of int (* Error type is private *) +type foo += A of int ;; +[%%expect {| +Line 1, characters 12-20: +1 | type foo += A of int + ^^^^^^^^ +Error: Cannot extend private type definition foo +|}] (* The type parameters must match *) type 'a foo = .. ;; +[%%expect {| +type 'a foo = .. +|}] -type ('a, 'b) foo += A of int (* Error: type parameter mismatch *) +type ('a, 'b) foo += A of int ;; +[%%expect {| +Line 1, characters 0-29: +1 | type ('a, 'b) foo += A of int + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This extension does not match the definition of type foo + They have different arities. +|}] (* In a signature the type can be private *) @@ -51,20 +91,32 @@ sig type foo += A of float end ;; +[%%expect {| +module type S = sig type foo = private .. type foo += A of float end +|}] (* But it must still be extensible *) module type S = sig type foo - type foo += B of float (* Error: foo does not have an extensible type *) + type foo += B of float end ;; +[%%expect {| +Line 4, characters 2-24: +4 | type foo += B of float + ^^^^^^^^^^^^^^^^^^^^^^ +Error: Type definition foo is not extensible +|}] (* Signatures can change the grouping of extensions *) type foo = .. ;; +[%%expect {| +type foo = .. +|}] module M = struct type foo += @@ -76,6 +128,14 @@ module M = struct | D of float end ;; +[%%expect {| +module M : + sig + type foo += A of int | B of string + type foo += C of int | D of float + + end +|}] module type S = sig type foo += @@ -87,146 +147,369 @@ module type S = sig type foo += A of int end ;; +[%%expect {| +module type S = + sig + type foo += B of string | C of int + type foo += D of float + type foo += A of int + end +|}] module M_S = (M : S) ;; +[%%expect {| +module M_S : S +|}] (* Extensions can be GADTs *) type 'a foo = .. ;; +[%%expect {| +type 'a foo = .. +|}] type _ foo += A : int -> int foo | B : int foo ;; +[%%expect {| +type _ foo += A : int -> int foo | B : int foo +|}] let get_num : type a. a foo -> a -> a option = fun f i1 -> match f with A i2 -> Some (i1 + i2) | _ -> None ;; +[%%expect {| +val get_num : 'a foo -> 'a -> 'a option = +|}] (* Extensions must obey constraints *) type 'a foo = .. constraint 'a = [> `Var ] ;; +[%%expect {| +type 'a foo = .. constraint 'a = [> `Var ] +|}] type 'a foo += A of 'a ;; +[%%expect {| +type 'a foo += A of 'a +|}] -let a = A 9 (* ERROR: Constraints not met *) +let a = A 9 ;; +[%%expect {| +Line 1, characters 10-11: +1 | let a = A 9 + ^ +Error: This expression has type int but an expression was expected of type + [> `Var ] +|}] -type 'a foo += B : int foo (* ERROR: Constraints not met *) +type 'a foo += B : int foo ;; +[%%expect {| +Line 1, characters 19-22: +1 | type 'a foo += B : int foo + ^^^ +Error: This type int should be an instance of type [> `Var ] +|}] (* Signatures can make an extension private *) type foo = .. ;; +[%%expect {| +type foo = .. +|}] module M = struct type foo += A of int end ;; +[%%expect {| +module M : sig type foo += A of int end +|}] let a1 = M.A 10 ;; +[%%expect {| +val a1 : foo = M.A 10 +|}] module type S = sig type foo += private A of int end ;; +[%%expect {| +module type S = sig type foo += private A of int end +|}] module M_S = (M : S) ;; +[%%expect {| +module M_S : S +|}] let is_s x = match x with M_S.A _ -> true | _ -> false ;; +[%%expect {| +val is_s : foo -> bool = +|}] -let a2 = M_S.A 20 (* ERROR: Cannot create a value using a private constructor *) +let a2 = M_S.A 20 ;; +[%%expect {| +Line 1, characters 9-17: +1 | let a2 = M_S.A 20 + ^^^^^^^^ +Error: Cannot use private constructor A to create values of type foo +|}] + +(* Signatures must respect the type of the constructor *) + +type ('a, 'b) bar = .. +[%%expect {| +type ('a, 'b) bar = .. +|}] + +module M : sig + type ('a, 'b) bar += A of int +end = struct + type ('a, 'b) bar += A of float +end +[%%expect {| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type ('a, 'b) bar += A of float +5 | end +Error: Signature mismatch: + Modules do not match: + sig type ('a, 'b) bar += A of float end + is not included in + sig type ('a, 'b) bar += A of int end + Extension declarations do not match: + type ('a, 'b) bar += A of float + is not included in + type ('a, 'b) bar += A of int + The types for field A are not equal. +|}] + +module M : sig + type ('a, 'b) bar += A of 'a +end = struct + type ('a, 'b) bar += A of 'b +end +[%%expect {| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type ('a, 'b) bar += A of 'b +5 | end +Error: Signature mismatch: + Modules do not match: + sig type ('a, 'b) bar += A of 'b end + is not included in + sig type ('a, 'b) bar += A of 'a end + Extension declarations do not match: + type ('a, 'b) bar += A of 'b + is not included in + type ('a, 'b) bar += A of 'a + The types for field A are not equal. +|}] + +module M : sig + type ('a, 'b) bar += A : 'c -> ('c, 'd) bar +end = struct + type ('a, 'b) bar += A : 'd -> ('c, 'd) bar +end +[%%expect {| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type ('a, 'b) bar += A : 'd -> ('c, 'd) bar +5 | end +Error: Signature mismatch: + Modules do not match: + sig type ('a, 'b) bar += A : 'd -> ('c, 'd) bar end + is not included in + sig type ('a, 'b) bar += A : 'c -> ('c, 'd) bar end + Extension declarations do not match: + type ('a, 'b) bar += A : 'd -> ('c, 'd) bar + is not included in + type ('a, 'b) bar += A : 'c -> ('c, 'd) bar + The types for field A are not equal. +|}] (* Extensions can be rebound *) type foo = .. ;; +[%%expect {| +type foo = .. +|}] module M = struct type foo += A1 of int end ;; +[%%expect {| +module M : sig type foo += A1 of int end +|}] type foo += A2 = M.A1 ;; +[%%expect {| +type foo += A2 of int +|}] type bar = .. ;; +[%%expect {| +type bar = .. +|}] -type bar += A3 = M.A1 (* Error: rebind wrong type *) +type bar += A3 = M.A1 ;; +[%%expect {| +Line 1, characters 17-21: +1 | type bar += A3 = M.A1 + ^^^^ +Error: The constructor M.A1 has type foo but was expected to be of type bar +|}] module M = struct type foo += private B1 of int end ;; +[%%expect {| +module M : sig type foo += private B1 of int end +|}] type foo += private B2 = M.B1 ;; +[%%expect {| +type foo += private B2 of int +|}] -type foo += B3 = M.B1 (* Error: rebind private extension *) +type foo += B3 = M.B1 ;; +[%%expect {| +Line 1, characters 17-21: +1 | type foo += B3 = M.B1 + ^^^^ +Error: The constructor M.B1 is private +|}] -type foo += C = Unknown (* Error: unbound extension *) +type foo += C = Unknown ;; +[%%expect {| +Line 1, characters 16-23: +1 | type foo += C = Unknown + ^^^^^^^ +Error: Unbound constructor Unknown +|}] (* Extensions can be rebound even if type is private *) module M : sig type foo = private .. type foo += A1 of int end - = struct type foo = .. type foo += A1 of int end + = struct type foo = .. type foo += A1 of int end;; +[%%expect {| +module M : sig type foo = private .. type foo += A1 of int end +|}] -type M.foo += A2 = M.A1 +type M.foo += A2 = M.A1;; +[%%expect {| +type M.foo += A2 of int +|}] (* Rebinding handles abbreviations *) type 'a foo = .. ;; +[%%expect {| +type 'a foo = .. +|}] type 'a foo1 = 'a foo = .. ;; +[%%expect {| +type 'a foo1 = 'a foo = .. +|}] type 'a foo2 = 'a foo = .. ;; +[%%expect {| +type 'a foo2 = 'a foo = .. +|}] type 'a foo1 += A of int | B of 'a | C : int foo1 ;; +[%%expect {| +type 'a foo1 += A of int | B of 'a | C : int foo1 +|}] type 'a foo2 += D = A | E = B | F = C ;; +[%%expect {| +type 'a foo2 += D of int | E of 'a | F : int foo2 +|}] (* Extensions must obey variances *) type +'a foo = .. ;; +[%%expect {| +type +'a foo = .. +|}] type 'a foo += A of (int -> 'a) ;; +[%%expect {| +type 'a foo += A of (int -> 'a) +|}] type 'a foo += B of ('a -> int) - (* ERROR: Parameter variances are not satisfied *) ;; +[%%expect {| +Line 1, characters 0-31: +1 | type 'a foo += B of ('a -> int) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: In this definition, expected parameter variances are not satisfied. + The 1st type parameter was expected to be covariant, + but it is injective contravariant. +|}] type _ foo += C : ('a -> int) -> 'a foo - (* ERROR: Parameter variances are not satisfied *) ;; +[%%expect {| +Line 1, characters 0-39: +1 | type _ foo += C : ('a -> int) -> 'a foo + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: In this definition, expected parameter variances are not satisfied. + The 1st type parameter was expected to be covariant, + but it is injective contravariant. +|}] type 'a bar = .. ;; +[%%expect {| +type 'a bar = .. +|}] -type +'a bar += D of (int -> 'a) (* ERROR: type variances do not match *) +type +'a bar += D of (int -> 'a) ;; +[%%expect {| +Line 1, characters 0-32: +1 | type +'a bar += D of (int -> 'a) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This extension does not match the definition of type bar + Their variances do not agree. +|}] (* Exceptions are compatible with extensions *) @@ -239,6 +522,9 @@ end = struct exception Foo of int * float end ;; +[%%expect {| +module M : sig type exn += Foo of int * float | Bar : 'a list -> exn end +|}] module M : sig exception Bar : 'a list -> exn @@ -249,12 +535,22 @@ end = struct | Bar : 'a list -> exn end ;; +[%%expect {| +module M : + sig exception Bar : 'a list -> exn exception Foo of int * float end +|}] exception Foo of int * float ;; +[%%expect {| +exception Foo of int * float +|}] exception Bar : 'a list -> exn ;; +[%%expect {| +exception Bar : 'a list -> exn +|}] module M : sig type exn += @@ -265,78 +561,154 @@ end = struct exception Foo = Foo end ;; +[%%expect {| +module M : sig type exn += Foo of int * float | Bar : 'a list -> exn end +|}] (* Test toplevel printing *) type foo = .. ;; +[%%expect {| +type foo = .. +|}] type foo += Foo of int * int option | Bar of int option ;; +[%%expect {| +type foo += Foo of int * int option | Bar of int option +|}] let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *) ;; +[%%expect {| +val x : foo * foo = (Foo (3, Some 4), Bar (Some 5)) +|}] type foo += Foo of string ;; +[%%expect {| +type foo += Foo of string +|}] let y = x (* Prints Bar but not Foo (which has been shadowed) *) ;; +[%%expect {| +val y : foo * foo = (, Bar (Some 5)) +|}] exception Foo of int * int option ;; +[%%expect {| +exception Foo of int * int option +|}] exception Bar of int option ;; +[%%expect {| +exception Bar of int option +|}] let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *) ;; +[%%expect {| +val x : exn * exn = (Foo (3, Some 4), Bar (Some 5)) +|}] type foo += Foo of string ;; +[%%expect {| +type foo += Foo of string +|}] let y = x (* Prints Bar and part of Foo (which has been shadowed) *) ;; +[%%expect {| +val y : exn * exn = (Foo (3, _), Bar (Some 5)) +|}] (* Test Obj functions *) type foo = .. ;; +[%%expect {| +type foo = .. +|}] type foo += Foo | Bar of int ;; +[%%expect {| +type foo += Foo | Bar of int +|}] let extension_name e = Obj.Extension_constructor.name - (Obj.Extension_constructor.of_val e);; + (Obj.Extension_constructor.of_val e) +;; +[%%expect {| +val extension_name : 'a -> string = +|}] + let extension_id e = Obj.Extension_constructor.id - (Obj.Extension_constructor.of_val e);; + (Obj.Extension_constructor.of_val e) +;; +[%%expect {| +val extension_id : 'a -> int = +|}] let n1 = extension_name Foo ;; +[%%expect {| +val n1 : string = "Foo" +|}] let n2 = extension_name (Bar 1) ;; +[%%expect {| +val n2 : string = "Bar" +|}] -let t = (extension_id (Bar 2)) = (extension_id (Bar 3)) (* true *) +let t = (extension_id (Bar 2)) = (extension_id (Bar 3)) ;; +[%%expect {| +val t : bool = true +|}] -let f = (extension_id (Bar 2)) = (extension_id Foo) (* false *) +let f = (extension_id (Bar 2)) = (extension_id Foo) ;; +[%%expect {| +val f : bool = false +|}] let is_foo x = (extension_id Foo) = (extension_id x) +;; +[%%expect {| +val is_foo : 'a -> bool = +|}] type foo += Foo ;; +[%%expect {| +type foo += Foo +|}] let f = is_foo Foo ;; +[%%expect {| +val f : bool = false +|}] -let _ = Obj.Extension_constructor.of_val 7 (* Invalid_arg *) +let _ = Obj.Extension_constructor.of_val 7 ;; +[%%expect {| +Exception: Invalid_argument "Obj.extension_constructor". +|}] -let _ = Obj.Extension_constructor.of_val (object method m = 3 end) (* Invalid_arg *) +let _ = Obj.Extension_constructor.of_val (object method m = 3 end) ;; +[%%expect {| +Exception: Invalid_argument "Obj.extension_constructor". +|}] diff --git a/testsuite/tests/typing-extensions/extensions.ocaml.reference b/testsuite/tests/typing-extensions/extensions.ocaml.reference deleted file mode 100644 index 53e30600..00000000 --- a/testsuite/tests/typing-extensions/extensions.ocaml.reference +++ /dev/null @@ -1,138 +0,0 @@ -- : unit = () -type foo = .. -type foo += A | B of int -val is_a : foo -> bool = -type foo -Line 2, characters 0-20: -2 | type foo += A of int (* Error type is not open *) - ^^^^^^^^^^^^^^^^^^^^ -Error: Type definition foo is not extensible -type foo = private .. -Line 2, characters 12-20: -2 | type foo += A of int (* Error type is private *) - ^^^^^^^^ -Error: Cannot extend private type definition foo -type 'a foo = .. -Line 2, characters 0-29: -2 | type ('a, 'b) foo += A of int (* Error: type parameter mismatch *) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This extension does not match the definition of type foo - They have different arities. -module type S = sig type foo = private .. type foo += A of float end -Line 7, characters 2-24: -7 | type foo += B of float (* Error: foo does not have an extensible type *) - ^^^^^^^^^^^^^^^^^^^^^^ -Error: Type definition foo is not extensible -type foo = .. -module M : - sig - type foo += A of int | B of string - type foo += C of int | D of float - - end -module type S = - sig - type foo += B of string | C of int - type foo += D of float - type foo += A of int - end -module M_S : S -type 'a foo = .. -type _ foo += A : int -> int foo | B : int foo -val get_num : 'a foo -> 'a -> 'a option = -type 'a foo = .. constraint 'a = [> `Var ] -type 'a foo += A of 'a -Line 2, characters 10-11: -2 | let a = A 9 (* ERROR: Constraints not met *) - ^ -Error: This expression has type int but an expression was expected of type - [> `Var ] -Line 2, characters 19-22: -2 | type 'a foo += B : int foo (* ERROR: Constraints not met *) - ^^^ -Error: This type int should be an instance of type [> `Var ] -type foo = .. -module M : sig type foo += A of int end -val a1 : foo = M.A 10 -module type S = sig type foo += private A of int end -module M_S : S -val is_s : foo -> bool = -Line 2, characters 9-17: -2 | let a2 = M_S.A 20 (* ERROR: Cannot create a value using a private constructor *) - ^^^^^^^^ -Error: Cannot create values of the private type foo -type foo = .. -module M : sig type foo += A1 of int end -type foo += A2 of int -type bar = .. -Line 2, characters 17-21: -2 | type bar += A3 = M.A1 (* Error: rebind wrong type *) - ^^^^ -Error: The constructor M.A1 has type foo but was expected to be of type bar -module M : sig type foo += private B1 of int end -type foo += private B2 of int -Line 2, characters 17-21: -2 | type foo += B3 = M.B1 (* Error: rebind private extension *) - ^^^^ -Error: The constructor M.B1 is private -Line 2, characters 16-23: -2 | type foo += C = Unknown (* Error: unbound extension *) - ^^^^^^^ -Error: Unbound constructor Unknown -module M : sig type foo = private .. type foo += A1 of int end -type M.foo += A2 of int -type 'a foo = .. -type 'a foo1 = 'a foo = .. -type 'a foo2 = 'a foo = .. -type 'a foo1 += A of int | B of 'a | C : int foo1 -type 'a foo2 += D of int | E of 'a | F : int foo2 -type +'a foo = .. -type 'a foo += A of (int -> 'a) -Line 2, characters 0-31: -2 | type 'a foo += B of ('a -> int) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: In this definition, expected parameter variances are not satisfied. - The 1st type parameter was expected to be covariant, - but it is injective contravariant. -Line 2, characters 0-39: -2 | type _ foo += C : ('a -> int) -> 'a foo - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: In this definition, expected parameter variances are not satisfied. - The 1st type parameter was expected to be covariant, - but it is injective contravariant. -type 'a bar = .. -Line 2, characters 0-32: -2 | type +'a bar += D of (int -> 'a) (* ERROR: type variances do not match *) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This extension does not match the definition of type bar - Their variances do not agree. -module M : sig type exn += Foo of int * float | Bar : 'a list -> exn end -module M : - sig exception Bar : 'a list -> exn exception Foo of int * float end -exception Foo of int * float -exception Bar : 'a list -> exn -module M : sig type exn += Foo of int * float | Bar : 'a list -> exn end -type foo = .. -type foo += Foo of int * int option | Bar of int option -val x : foo * foo = (Foo (3, Some 4), Bar (Some 5)) -type foo += Foo of string -val y : foo * foo = (, Bar (Some 5)) -exception Foo of int * int option -exception Bar of int option -val x : exn * exn = (Foo (3, Some 4), Bar (Some 5)) -type foo += Foo of string -val y : exn * exn = (Foo (3, _), Bar (Some 5)) -type foo = .. -type foo += Foo | Bar of int -val extension_name : 'a -> string = -val extension_id : 'a -> int = -val n1 : string = "Foo" -val n2 : string = "Bar" -val t : bool = true -val f : bool = false -val is_foo : 'a -> bool = -type foo += Foo -val f : bool = false -Exception: Invalid_argument "Obj.extension_constructor". -Exception: Invalid_argument "Obj.extension_constructor". - diff --git a/testsuite/tests/typing-extensions/open_types.ml b/testsuite/tests/typing-extensions/open_types.ml index d1129878..dd5ed138 100644 --- a/testsuite/tests/typing-extensions/open_types.ml +++ b/testsuite/tests/typing-extensions/open_types.ml @@ -1,134 +1,318 @@ (* TEST - * toplevel + * expect *) type foo = .. ;; +[%%expect {| +type foo = .. +|}] (* Check that abbreviations work *) type bar = foo = .. ;; +[%%expect {| +type bar = foo = .. +|}] type baz = foo = .. ;; +[%%expect {| +type baz = foo = .. +|}] type bar += Bar1 of int ;; +[%%expect {| +type bar += Bar1 of int +|}] type baz += Bar2 of int ;; +[%%expect {| +type baz += Bar2 of int +|}] module M = struct type bar += Foo of float end ;; +[%%expect {| +module M : sig type bar += Foo of float end +|}] module type S = sig type baz += Foo of float end ;; +[%%expect {| +module type S = sig type baz += Foo of float end +|}] module M_S = (M : S) ;; +[%%expect {| +module M_S : S +|}] (* Abbreviations need to be made open *) type foo = .. ;; +[%%expect {| +type foo = .. +|}] type bar = foo ;; +[%%expect {| +type bar = foo +|}] -type bar += Bar of int (* Error: type is not open *) +type bar += Bar of int ;; +[%%expect {| +Line 1, characters 0-22: +1 | type bar += Bar of int + ^^^^^^^^^^^^^^^^^^^^^^ +Error: Type definition bar is not extensible +|}] -type baz = bar = .. (* Error: type kinds don't match *) +type baz = bar = .. ;; +[%%expect {| +Line 1, characters 0-19: +1 | type baz = bar = .. + ^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type bar + Their kinds differ. +|}] (* Abbreviations need to match parameters *) type 'a foo = .. ;; +[%%expect {| +type 'a foo = .. +|}] -type ('a, 'b) bar = 'a foo = .. (* Error: arrities do not match *) +type ('a, 'b) bar = 'a foo = .. ;; +[%%expect {| +Line 1, characters 0-31: +1 | type ('a, 'b) bar = 'a foo = .. + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type 'a foo + They have different arities. +|}] type ('a, 'b) foo = .. ;; +[%%expect {| +type ('a, 'b) foo = .. +|}] -type ('a, 'b) bar = ('a, 'a) foo = .. (* Error: constraints do not match *) +type ('a, 'b) bar = ('a, 'a) foo = .. ;; +[%%expect {| +Line 1, characters 0-37: +1 | type ('a, 'b) bar = ('a, 'a) foo = .. + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type + ('a, 'a) foo + Their constraints differ. +|}] (* Check that signatures can hide exstensibility *) module M = struct type foo = .. end ;; +[%%expect {| +module M : sig type foo = .. end +|}] module type S = sig type foo end ;; +[%%expect {| +module type S = sig type foo end +|}] module M_S = (M : S) ;; +[%%expect {| +module M_S : S +|}] -type M_S.foo += Foo (* ERROR: Cannot extend a type that isn't "open" *) +type M_S.foo += Foo ;; +[%%expect {| +Line 1, characters 0-19: +1 | type M_S.foo += Foo + ^^^^^^^^^^^^^^^^^^^ +Error: Type definition M_S.foo is not extensible +|}] (* Check that signatures cannot add extensibility *) module M = struct type foo end ;; +[%%expect {| +module M : sig type foo end +|}] module type S = sig type foo = .. end ;; +[%%expect {| +module type S = sig type foo = .. end +|}] -module M_S = (M : S) (* ERROR: Signatures are not compatible *) +module M_S = (M : S) ;; +[%%expect {| +Line 1, characters 14-15: +1 | module M_S = (M : S) + ^ +Error: Signature mismatch: + Modules do not match: sig type foo = M.foo end is not included in S + Type declarations do not match: + type foo = M.foo + is not included in + type foo = .. + Their kinds differ. +|}] (* Check that signatures can make exstensibility private *) module M = struct type foo = .. end ;; +[%%expect {| +module M : sig type foo = .. end +|}] module type S = sig type foo = private .. end ;; +[%%expect {| +module type S = sig type foo = private .. end +|}] module M_S = (M : S) ;; +[%%expect {| +module M_S : S +|}] -type M_S.foo += Foo (* ERROR: Cannot extend a private extensible type *) +type M_S.foo += Foo ;; +[%%expect {| +Line 1, characters 16-19: +1 | type M_S.foo += Foo + ^^^ +Error: Cannot extend private type definition M_S.foo +|}] (* Check that signatures cannot make private extensibility public *) module M = struct type foo = private .. end ;; +[%%expect {| +module M : sig type foo = private .. end +|}] module type S = sig type foo = .. end ;; +[%%expect {| +module type S = sig type foo = .. end +|}] -module M_S = (M : S) (* ERROR: Signatures are not compatible *) +module M_S = (M : S) ;; +[%%expect {| +Line 1, characters 14-15: +1 | module M_S = (M : S) + ^ +Error: Signature mismatch: + Modules do not match: + sig type foo = M.foo = private .. end + is not included in + S + Type declarations do not match: + type foo = M.foo = private .. + is not included in + type foo = .. + A private type would be revealed. +|}] (* Check that signatures maintain variances *) module M = struct type +'a foo = .. type 'a bar = 'a foo = .. end ;; +[%%expect {| +module M : sig type +'a foo = .. type 'a bar = 'a foo = .. end +|}] module type S = sig type 'a foo = .. type 'a bar = 'a foo = .. end ;; +[%%expect {| +module type S = sig type 'a foo = .. type 'a bar = 'a foo = .. end +|}] -module M_S = (M : S) (* ERROR: Signatures are not compatible *) +module M_S = (M : S) ;; +[%%expect {| +Line 1, characters 14-15: +1 | module M_S = (M : S) + ^ +Error: Signature mismatch: + Modules do not match: + sig type 'a foo = 'a M.foo = .. type 'a bar = 'a foo = .. end + is not included in + S + Type declarations do not match: + type 'a foo = 'a M.foo = .. + is not included in + type 'a foo = .. + Their variances do not agree. +|}] (* Exn is an open type *) type exn2 = exn = .. ;; +[%%expect {| +type exn2 = exn = .. +|}] + +(* PR#8579 exceptions can be private *) + +type exn += private Foobar +let _ = raise Foobar +;; +[%%expect {| +type exn += private Foobar +Line 2, characters 14-20: +2 | let _ = raise Foobar + ^^^^^^ +Error: Cannot use private constructor Foobar to create values of type exn +|}] + (* Exhaustiveness *) type foo = .. type foo += Foo let f = function Foo -> () -;; (* warn *) +;; +[%%expect {| +type foo = .. +type foo += Foo +Line 3, characters 8-26: +3 | let f = function Foo -> () + ^^^^^^^^^^^^^^^^^^ +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a case that is not matched: +*extension* +Matching over values of extensible variant types (the *extension* above) +must include a wild card pattern in order to be exhaustive. +val f : foo -> unit = +|}] (* More complex exhaustiveness *) @@ -136,12 +320,40 @@ let f = function | [Foo] -> 1 | _::_::_ -> 3 | [] -> 2 -;; (* warn *) +;; +[%%expect {| +Lines 1-4, characters 8-11: +1 | ........function +2 | | [Foo] -> 1 +3 | | _::_::_ -> 3 +4 | | [] -> 2 +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a case that is not matched: +*extension*::[] +Matching over values of extensible variant types (the *extension* above) +must include a wild card pattern in order to be exhaustive. +val f : foo list -> int = +|}] (* PR#7330: exhaustiveness with GADTs *) type t = .. type t += IPair : (int * int) -> t ;; - -let f = function IPair (i, j) -> Format.sprintf "(%d, %d)" i j ;; (* warn *) +[%%expect {| +type t = .. +type t += IPair : (int * int) -> t +|}] + +let f = function IPair (i, j) -> Format.sprintf "(%d, %d)" i j ;; +[%%expect {| +Line 1, characters 8-62: +1 | let f = function IPair (i, j) -> Format.sprintf "(%d, %d)" i j ;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a case that is not matched: +*extension* +Matching over values of extensible variant types (the *extension* above) +must include a wild card pattern in order to be exhaustive. +val f : t -> string = +|}] diff --git a/testsuite/tests/typing-extensions/open_types.ocaml.reference b/testsuite/tests/typing-extensions/open_types.ocaml.reference deleted file mode 100644 index 2dddce7b..00000000 --- a/testsuite/tests/typing-extensions/open_types.ocaml.reference +++ /dev/null @@ -1,123 +0,0 @@ -type foo = .. -type bar = foo = .. -type baz = foo = .. -type bar += Bar1 of int -type baz += Bar2 of int -module M : sig type bar += Foo of float end -module type S = sig type baz += Foo of float end -module M_S : S -type foo = .. -type bar = foo -Line 2, characters 0-22: -2 | type bar += Bar of int (* Error: type is not open *) - ^^^^^^^^^^^^^^^^^^^^^^ -Error: Type definition bar is not extensible -Line 2, characters 0-19: -2 | type baz = bar = .. (* Error: type kinds don't match *) - ^^^^^^^^^^^^^^^^^^^ -Error: This variant or record definition does not match that of type bar - Their kinds differ. -type 'a foo = .. -Line 2, characters 0-31: -2 | type ('a, 'b) bar = 'a foo = .. (* Error: arrities do not match *) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This variant or record definition does not match that of type 'a foo - They have different arities. -type ('a, 'b) foo = .. -Line 2, characters 0-37: -2 | type ('a, 'b) bar = ('a, 'a) foo = .. (* Error: constraints do not match *) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This variant or record definition does not match that of type - ('a, 'a) foo - Their constraints differ. -module M : sig type foo = .. end -module type S = sig type foo end -module M_S : S -Line 2, characters 0-19: -2 | type M_S.foo += Foo (* ERROR: Cannot extend a type that isn't "open" *) - ^^^^^^^^^^^^^^^^^^^ -Error: Type definition M_S.foo is not extensible -module M : sig type foo end -module type S = sig type foo = .. end -Line 2, characters 14-15: -2 | module M_S = (M : S) (* ERROR: Signatures are not compatible *) - ^ -Error: Signature mismatch: - Modules do not match: sig type foo = M.foo end is not included in S - Type declarations do not match: - type foo = M.foo - is not included in - type foo = .. - Their kinds differ. -module M : sig type foo = .. end -module type S = sig type foo = private .. end -module M_S : S -Line 2, characters 16-19: -2 | type M_S.foo += Foo (* ERROR: Cannot extend a private extensible type *) - ^^^ -Error: Cannot extend private type definition M_S.foo -module M : sig type foo = private .. end -module type S = sig type foo = .. end -Line 2, characters 14-15: -2 | module M_S = (M : S) (* ERROR: Signatures are not compatible *) - ^ -Error: Signature mismatch: - Modules do not match: - sig type foo = M.foo = private .. end - is not included in - S - Type declarations do not match: - type foo = M.foo = private .. - is not included in - type foo = .. - A private type would be revealed. -module M : sig type +'a foo = .. type 'a bar = 'a foo = .. end -module type S = sig type 'a foo = .. type 'a bar = 'a foo = .. end -Line 2, characters 14-15: -2 | module M_S = (M : S) (* ERROR: Signatures are not compatible *) - ^ -Error: Signature mismatch: - Modules do not match: - sig type 'a foo = 'a M.foo = .. type 'a bar = 'a foo = .. end - is not included in - S - Type declarations do not match: - type 'a foo = 'a M.foo = .. - is not included in - type 'a foo = .. - Their variances do not agree. -type exn2 = exn = .. -Line 6, characters 8-26: -6 | let f = function Foo -> () - ^^^^^^^^^^^^^^^^^^ -Warning 8: this pattern-matching is not exhaustive. -Here is an example of a case that is not matched: -*extension* -Matching over values of extensible variant types (the *extension* above) -must include a wild card pattern in order to be exhaustive. -type foo = .. -type foo += Foo -val f : foo -> unit = -Line 4, characters 8-60: -4 | ........function -5 | | [Foo] -> 1 -6 | | _::_::_ -> 3 -7 | | [] -> 2 -Warning 8: this pattern-matching is not exhaustive. -Here is an example of a case that is not matched: -*extension*::[] -Matching over values of extensible variant types (the *extension* above) -must include a wild card pattern in order to be exhaustive. -val f : foo list -> int = -type t = .. -type t += IPair : (int * int) -> t -Line 2, characters 8-62: -2 | let f = function IPair (i, j) -> Format.sprintf "(%d, %d)" i j ;; (* warn *) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Warning 8: this pattern-matching is not exhaustive. -Here is an example of a case that is not matched: -*extension* -Matching over values of extensible variant types (the *extension* above) -must include a wild card pattern in order to be exhaustive. -val f : t -> string = - diff --git a/testsuite/tests/typing-gadts/ambiguity.ml b/testsuite/tests/typing-gadts/ambiguity.ml index ab6c97ac..b576b2bf 100644 --- a/testsuite/tests/typing-gadts/ambiguity.ml +++ b/testsuite/tests/typing-gadts/ambiguity.ml @@ -190,3 +190,78 @@ Error: This pattern matches values of type (a, b) eq * b list This instance of b is ambiguous: it would escape the scope of its equation |}] + +module T : sig + type t + type u + val eq : (t, u) eq +end = struct + type t = int + type u = int + let eq = Refl +end;; +[%%expect{| +module T : sig type t type u val eq : (t, u) eq end +|}] + +module M = struct + let r = ref [] +end + +let foo p (e : (T.t, T.u) eq) (x : T.t) (y : T.u) = + match e with + | Refl -> + let z = if p then x else y in + let module N = struct + module type S = module type of struct let r = ref [z] end + end in + let module O : N.S = M in + () + +module type S = module type of M ;; +[%%expect{| +module M : sig val r : '_weak1 list ref end +Line 12, characters 25-26: +12 | let module O : N.S = M in + ^ +Error: Signature mismatch: + Modules do not match: + sig val r : '_weak1 list ref end + is not included in + N.S + Values do not match: + val r : '_weak1 list ref + is not included in + val r : T.u list ref +|}] + +module M = struct + let r = ref [] +end + +let foo p (e : (T.u, T.t) eq) (x : T.t) (y : T.u) = + match e with + | Refl -> + let z = if p then x else y in + let module N = struct + module type S = module type of struct let r = ref [z] end + end in + let module O : N.S = M in + () + +module type S = module type of M ;; +[%%expect{| +module M : sig val r : '_weak2 list ref end +Line 12, characters 25-26: +12 | let module O : N.S = M in + ^ +Error: Signature mismatch: + Modules do not match: + sig val r : '_weak2 list ref end + is not included in + N.S + Values do not match: + val r : '_weak2 list ref + is not included in + val r : T.t list ref +|}] diff --git a/testsuite/tests/typing-gadts/didier.ml b/testsuite/tests/typing-gadts/didier.ml index 717fb945..7c13cb4f 100644 --- a/testsuite/tests/typing-gadts/didier.ml +++ b/testsuite/tests/typing-gadts/didier.ml @@ -12,13 +12,13 @@ let fbool (type t) (x : t) (tag : t ty) = ;; [%%expect{| type 'a ty = Int : int ty | Bool : bool ty -Line 6, characters 2-30: +Lines 6-7, characters 2-13: 6 | ..match tag with 7 | | Bool -> x Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: Int -val fbool : 'a -> 'a ty -> 'a = +val fbool : 't -> 't ty -> 't = |}];; (* val fbool : 'a -> 'a ty -> 'a = *) (** OK: the return value is x of type t **) @@ -28,13 +28,13 @@ let fint (type t) (x : t) (tag : t ty) = | Int -> x > 0 ;; [%%expect{| -Line 2, characters 2-33: +Lines 2-3, characters 2-16: 2 | ..match tag with 3 | | Int -> x > 0 Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: Bool -val fint : 'a -> 'a ty -> bool = +val fint : 't -> 't ty -> bool = |}];; (* val fint : 'a -> 'a ty -> bool = *) (** OK: the return value is x > 0 of type bool; @@ -47,7 +47,7 @@ let f (type t) (x : t) (tag : t ty) = | Bool -> x ;; [%%expect{| -val f : 'a -> 'a ty -> bool = +val f : 't -> 't ty -> bool = |}, Principal{| Line 4, characters 12-13: 4 | | Bool -> x @@ -84,7 +84,7 @@ let g (type t) (x : t) (tag : t ty) : bool = | Int -> x > 0 ;; [%%expect{| -val g : 'a -> 'a ty -> bool = +val g : 't -> 't ty -> bool = |}];; let id x = x;; @@ -102,7 +102,7 @@ val id : 'a -> 'a = val idb1 : bool -> bool = val idb2 : bool -> bool = val idb3 : bool -> bool = -val g : 'a -> 'a ty -> bool = +val g : 't -> 't ty -> bool = |}];; let g (type t) (x : t) (tag : t ty) = @@ -111,5 +111,5 @@ let g (type t) (x : t) (tag : t ty) = | Int -> x > 0 ;; [%%expect{| -val g : 'a -> 'a ty -> bool = +val g : 't -> 't ty -> bool = |}];; diff --git a/testsuite/tests/typing-gadts/or_patterns.ml b/testsuite/tests/typing-gadts/or_patterns.ml index c7e0b18d..1cc64034 100644 --- a/testsuite/tests/typing-gadts/or_patterns.ml +++ b/testsuite/tests/typing-gadts/or_patterns.ml @@ -240,7 +240,7 @@ let simple_merged_annotated_return_annotated (type a) (t : a t) (a : a) = ;; [%%expect{| -Line 3, characters 4-57: +Lines 3-4, characters 4-30: 3 | ....IntLit, ((3 : a) as x) 4 | | BoolLit, ((true : a) as x)............ Error: The variable x on the left-hand side of this or-pattern has type @@ -551,7 +551,7 @@ let extract_merged_annotated (type a) (t2 : a t2) : a = [%%expect{| -Line 3, characters 4-20: +Lines 3-4, characters 4-10: 3 | ....Int x 4 | | Bool x..... Error: The variable x on the left-hand side of this or-pattern has type @@ -575,7 +575,7 @@ let extract_merged_too_lightly_annotated (type a) (t2 : a t2) : a = ;; [%%expect{| -Line 3, characters 4-26: +Lines 3-4, characters 4-10: 3 | ....Int (x : a) 4 | | Bool x..... Error: The variable x on the left-hand side of this or-pattern has type @@ -731,7 +731,7 @@ let f_amb (type a) (t : a t) (a : bool ref) (b : a ref) = | _, _, _ -> () ;; [%%expect{| -Line 3, characters 4-108: +Lines 3-4, characters 4-65: 3 | ....IntLit, ({ contents = true } as x), _ 4 | | BoolLit, _, ({ contents = true} as x)............ Error: The variable x on the left-hand side of this or-pattern has type diff --git a/testsuite/tests/typing-gadts/pr5785.ml b/testsuite/tests/typing-gadts/pr5785.ml index 96eed8fd..00420834 100644 --- a/testsuite/tests/typing-gadts/pr5785.ml +++ b/testsuite/tests/typing-gadts/pr5785.ml @@ -13,7 +13,7 @@ struct | Two, Two -> "four" end;; [%%expect{| -Line 7, characters 43-100: +Lines 7-9, characters 43-24: 7 | ...........................................function 8 | | One, One -> "two" 9 | | Two, Two -> "four" diff --git a/testsuite/tests/typing-gadts/pr5906.ml b/testsuite/tests/typing-gadts/pr5906.ml index ad62ef09..c722ec27 100644 --- a/testsuite/tests/typing-gadts/pr5906.ml +++ b/testsuite/tests/typing-gadts/pr5906.ml @@ -27,7 +27,7 @@ type (_, _, _) binop = Eq : ('a, 'a, bool) binop | Leq : ('a, 'a, bool) binop | Add : (int, int, int) binop -Line 12, characters 2-195: +Lines 12-16, characters 2-36: 12 | ..match bop, x, y with 13 | | Eq, Bool x, Bool y -> Bool (if x then y else not y) 14 | | Leq, Int x, Int y -> Bool (x <= y) diff --git a/testsuite/tests/typing-gadts/pr5981.ml b/testsuite/tests/typing-gadts/pr5981.ml index ba8c7e42..9431a1ca 100644 --- a/testsuite/tests/typing-gadts/pr5981.ml +++ b/testsuite/tests/typing-gadts/pr5981.ml @@ -12,7 +12,7 @@ module F(S : sig type 'a t end) = struct | A, B -> "f A B" end;; [%%expect{| -Line 7, characters 47-84: +Lines 7-8, characters 47-21: 7 | ...............................................match l, r with 8 | | A, B -> "f A B" Warning 8: this pattern-matching is not exhaustive. @@ -39,7 +39,7 @@ module F(S : sig type 'a t end) = struct | A, B -> "f A B" end;; [%%expect{| -Line 10, characters 15-52: +Lines 10-11, characters 15-21: 10 | ...............match l, r with 11 | | A, B -> "f A B" Warning 8: this pattern-matching is not exhaustive. diff --git a/testsuite/tests/typing-gadts/pr5985.ml b/testsuite/tests/typing-gadts/pr5985.ml index 72bbd278..c8a9c6f2 100644 --- a/testsuite/tests/typing-gadts/pr5985.ml +++ b/testsuite/tests/typing-gadts/pr5985.ml @@ -37,7 +37,7 @@ module F(T:sig type 'a t end) = struct object constraint 'a = 'b T.t val x' : 'b = x method x = x' end end;; (* fail *) [%%expect{| -Line 2, characters 2-86: +Lines 2-3, characters 2-67: 2 | ..class ['a] c x = 3 | object constraint 'a = 'b T.t val x' : 'b = x method x = x' end Error: In this definition, a type variable cannot be deduced diff --git a/testsuite/tests/typing-gadts/pr5989.ml b/testsuite/tests/typing-gadts/pr5989.ml index 2c4fdc31..def3e533 100644 --- a/testsuite/tests/typing-gadts/pr5989.ml +++ b/testsuite/tests/typing-gadts/pr5989.ml @@ -25,7 +25,7 @@ let () = print_endline (f M.eq) ;; [%%expect{| type (_, _) t = Any : ('a, 'b) t | Eq : ('a, 'a) t module M : sig type s = private [> `A ] val eq : (s, [ `A | `B ]) t end -Line 16, characters 39-64: +Lines 16-17, characters 39-16: 16 | .......................................function 17 | | Any -> "Any" Warning 8: this pattern-matching is not exhaustive. @@ -55,7 +55,7 @@ module N : type s = private < a : int; .. > val eq : (s, < a : int; b : bool >) t end -Line 12, characters 49-74: +Lines 12-13, characters 49-16: 12 | .................................................function 13 | | Any -> "Any" Warning 8: this pattern-matching is not exhaustive. diff --git a/testsuite/tests/typing-gadts/pr6241.ml b/testsuite/tests/typing-gadts/pr6241.ml index aec74eb0..3a778144 100644 --- a/testsuite/tests/typing-gadts/pr6241.ml +++ b/testsuite/tests/typing-gadts/pr6241.ml @@ -21,7 +21,7 @@ let x = N.f A;; [%%expect{| type (_, _) t = A : ('a, 'a) t | B : string -> ('a, 'b) t -Line 8, characters 52-74: +Lines 8-9, characters 52-13: 8 | ....................................................function 9 | | B s -> s Warning 8: this pattern-matching is not exhaustive. diff --git a/testsuite/tests/typing-gadts/pr6690.ml b/testsuite/tests/typing-gadts/pr6690.ml index d50e3707..858547ea 100644 --- a/testsuite/tests/typing-gadts/pr6690.ml +++ b/testsuite/tests/typing-gadts/pr6690.ml @@ -80,5 +80,6 @@ let vexpr (type result) (type visit_action) | Global -> fun _ -> raise Exit ;; [%%expect{| -val vexpr : (unit, 'a, 'b) context -> unit -> 'b = +val vexpr : (unit, 'result, 'visit_action) context -> unit -> 'visit_action = + |}];; diff --git a/testsuite/tests/typing-gadts/pr7160.ml b/testsuite/tests/typing-gadts/pr7160.ml index f7b94431..8af9de8c 100644 --- a/testsuite/tests/typing-gadts/pr7160.ml +++ b/testsuite/tests/typing-gadts/pr7160.ml @@ -14,7 +14,7 @@ type _ t = | String : string -> string t | Same : 'l t -> 'l t val f : int t -> int = -Line 4, characters 0-97: +Lines 4-5, characters 0-77: 4 | type 'a tt = 'a t = 5 | Int : int -> int tt | String : string -> string tt | Same : 'l1 t -> 'l2 tt.. Error: This variant or record definition does not match that of type 'a t diff --git a/testsuite/tests/typing-gadts/pr7260.ml b/testsuite/tests/typing-gadts/pr7260.ml index c6f160f4..87e7d30e 100644 --- a/testsuite/tests/typing-gadts/pr7260.ml +++ b/testsuite/tests/typing-gadts/pr7260.ml @@ -19,7 +19,7 @@ class foo = type bar = < bar : unit > type _ ty = Int : int ty type dyn = Dyn : 'a ty -> dyn -Line 7, characters 0-108: +Lines 7-12, characters 0-5: 7 | class foo = 8 | object (this) 9 | method foo (Dyn ty) = diff --git a/testsuite/tests/typing-gadts/pr7378.ml b/testsuite/tests/typing-gadts/pr7378.ml index d7767033..956094d7 100644 --- a/testsuite/tests/typing-gadts/pr7378.ml +++ b/testsuite/tests/typing-gadts/pr7378.ml @@ -15,7 +15,7 @@ module Y = struct | A : 'a * 'b * ('b -> unit) -> t end;; (* should fail *) [%%expect{| -Line 2, characters 2-54: +Lines 2-3, characters 2-37: 2 | ..type t = X.t = 3 | | A : 'a * 'b * ('b -> unit) -> t Error: This variant or record definition does not match that of type X.t diff --git a/testsuite/tests/typing-gadts/test.ml b/testsuite/tests/typing-gadts/test.ml index 61061872..be41c367 100644 --- a/testsuite/tests/typing-gadts/test.ml +++ b/testsuite/tests/typing-gadts/test.ml @@ -103,13 +103,13 @@ module Nonexhaustive = end ;; [%%expect{| -Line 11, characters 6-34: +Lines 11-12, characters 6-19: 11 | ......function 12 | | C2 x -> x Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: C1 _ -Line 24, characters 6-77: +Lines 24-26, characters 6-30: 24 | ......function 25 | | Foo _ , Foo _ -> true 26 | | Bar _, Bar _ -> true @@ -260,7 +260,7 @@ module PR6801 = struct | String s -> print_endline s (* warn : Any *) end;; [%%expect{| -Line 8, characters 4-50: +Lines 8-9, characters 4-33: 8 | ....match x with 9 | | String s -> print_endline s................. Warning 8: this pattern-matching is not exhaustive. @@ -687,7 +687,7 @@ let f : type a b. (a,b) eq -> ( as 'c) -> ( as 'c) = ;; (* fail *) [%%expect{| type (_, _) eq = Eq : ('a, 'a) eq -Line 3, characters 4-90: +Lines 3-4, characters 4-15: 3 | ....f : type a b. (a,b) eq -> ( as 'c) -> ( as 'c) = 4 | fun Eq o -> o Error: The universal type variable 'b cannot be generalized: @@ -813,7 +813,7 @@ Error: This expression has type [> `A of a ] let f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] = fun Eq o -> o ;; (* fail *) [%%expect{| -Line 1, characters 4-84: +Lines 1-2, characters 4-15: 1 | ....f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] = 2 | fun Eq o -> o.............. Error: This definition has type @@ -915,7 +915,7 @@ let f : type a. a ty -> a t -> int = fun x y -> | TA, D z -> z ;; (* warn *) [%%expect{| -Line 2, characters 2-153: +Lines 2-8, characters 2-16: 2 | ..match x, y with 3 | | _, A z -> z 4 | | _, B z -> if z then 1 else 2 @@ -979,7 +979,7 @@ let f : type a. a ty -> a t -> int = fun x y -> ;; (* ok *) [%%expect{| type ('a, 'b) pair = { left : 'a; right : 'b; } -Line 4, characters 2-244: +Lines 4-10, characters 2-29: 4 | ..match {left=x; right=y} with 5 | | {left=_; right=A z} -> z 6 | | {left=_; right=B z} -> if z then 1 else 2 @@ -1101,7 +1101,7 @@ let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) : t = (x:) ;; [%%expect{| -val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = +val g : 't -> 't int_foo -> 't int_bar -> 't = |}];; let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) = @@ -1109,7 +1109,7 @@ let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) = x, x#foo, x#bar ;; [%%expect{| -val g : 'a -> 'a int_foo -> 'a int_bar -> 'a * int * int = +val g : 't -> 't int_foo -> 't int_bar -> 't * int * int = |}];; (* PR#5554 *) diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml b/testsuite/tests/typing-gadts/yallop_bugs.ml index 443a6526..d94e63fd 100644 --- a/testsuite/tests/typing-gadts/yallop_bugs.ml +++ b/testsuite/tests/typing-gadts/yallop_bugs.ml @@ -56,7 +56,7 @@ let check : type s . s t * s -> bool = function ;; [%%expect{| type _ t = IntLit : int t | BoolLit : bool t -Line 5, characters 39-99: +Lines 5-7, characters 39-23: 5 | .......................................function 6 | | BoolLit, false -> false 7 | | IntLit , 6 -> false @@ -74,7 +74,7 @@ let check : type s . (s t, s) pair -> bool = function ;; [%%expect{| type ('a, 'b) pair = { fst : 'a; snd : 'b; } -Line 3, characters 45-134: +Lines 3-5, characters 45-38: 3 | .............................................function 4 | | {fst = BoolLit; snd = false} -> false 5 | | {fst = IntLit ; snd = 6} -> false diff --git a/testsuite/tests/typing-immediate/immediate.ml b/testsuite/tests/typing-immediate/immediate.ml index 285d1128..c55c9374 100644 --- a/testsuite/tests/typing-immediate/immediate.ml +++ b/testsuite/tests/typing-immediate/immediate.ml @@ -131,7 +131,7 @@ module D : sig type t [@@immediate] end = struct type t = string end;; [%%expect{| -Line 1, characters 42-70: +Lines 1-3, characters 42-3: 1 | ..........................................struct 2 | type t = string 3 | end.. diff --git a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ocaml.reference b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ocaml.reference index 94f9fff8..da8efa70 100644 --- a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ocaml.reference +++ b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ocaml.reference @@ -1,6 +1,6 @@ -val sort : (module Set.S with type elt = 'a) -> 'a list -> 'a list = -val make_set : ('a -> 'a -> int) -> (module Set.S with type elt = 'a) = -val sort_cmp : ('a -> 'a -> int) -> 'a list -> 'a list = +val sort : (module Set.S with type elt = 's) -> 's list -> 's list = +val make_set : ('s -> 's -> int) -> (module Set.S with type elt = 's) = +val sort_cmp : ('s -> 's -> int) -> 's list -> 's list = module type S = sig type t val x : t end val f : (module S with type t = int) -> int = Line 1, characters 6-37: @@ -71,7 +71,7 @@ module rec Typ : end val int : int Typ.typ = Typ.Int val str : string Typ.typ = Typ.String -val pair : 'a Typ.typ -> 'b Typ.typ -> ('a * 'b) Typ.typ = +val pair : 's1 Typ.typ -> 's2 Typ.typ -> ('s1 * 's2) Typ.typ = val to_string : 'a Typ.typ -> 'a -> string = module type MapT = sig @@ -123,7 +123,7 @@ module type MapT = end type ('k, 'd, 'm) map = (module MapT with type data = 'd and type key = 'k and type map = 'm) -val add : ('a, 'b, 'c) map -> 'a -> 'b -> 'c -> 'c = +val add : ('k, 'd, 'm) map -> 'k -> 'd -> 'm -> 'm = module SSMap : sig type key = String.t diff --git a/testsuite/tests/typing-misc/disambiguate_principality.ml b/testsuite/tests/typing-misc/disambiguate_principality.ml index ed49ecbf..d1b61f03 100644 --- a/testsuite/tests/typing-misc/disambiguate_principality.ml +++ b/testsuite/tests/typing-misc/disambiguate_principality.ml @@ -494,7 +494,7 @@ let t = function x := B ;; [%%expect{| -Line 1, characters 8-70: +Lines 1-3, characters 8-10: 1 | ........function 2 | | ({ contents = M.A } : M.t ref) as x -> 3 | x := B @@ -507,7 +507,7 @@ Line 3, characters 9-10: 3 | x := B ^ Warning 18: this type-based constructor disambiguation is not principal. -Line 1, characters 8-70: +Lines 1-3, characters 8-10: 1 | ........function 2 | | ({ contents = M.A } : M.t ref) as x -> 3 | x := B diff --git a/testsuite/tests/typing-misc/gpr2277.ml b/testsuite/tests/typing-misc/gpr2277.ml new file mode 100644 index 00000000..eabd3cc0 --- /dev/null +++ b/testsuite/tests/typing-misc/gpr2277.ml @@ -0,0 +1,54 @@ +(* TEST + * expect +*) + +let f (type t) (x : t) = x + +[%%expect {| +val f : 't -> 't = +|}] + +let g (type t') (x : t') = x + +let g' (x : ' t') = x + +[%%expect {| +val g : ' t' -> ' t' = +val g' : ' t' -> ' t' = +|}] + +let h (type a'bc) (x : a'bc) = x + +let h' (x : ' a'bc) = x + +[%%expect {| +val h : ' a'bc -> ' a'bc = +val h' : ' a'bc -> ' a'bc = +|}] + +let i (type fst snd) (x : fst) (y : snd) = (x, y) + +[%%expect {| +val i : 'fst -> 'snd -> 'fst * 'snd = +|}] + +let j (type fst snd fst' snd') (x : fst) (y : snd) (a : fst') (b : snd') = + ((x, y), (a, b)) + +[%%expect {| +val j : 'fst -> 'snd -> 'fst' -> 'snd' -> ('fst * 'snd) * ('fst' * 'snd') = + +|}] + +(* Variable names starting with _ are reserved for the compiler. *) +let k (type _weak1) (x : _weak1) = x + +[%%expect {| +val k : 'a -> 'a = +|}] + +let l (type _') (x : _') = x + +[%%expect {| +val l : 'a -> 'a = +|}] diff --git a/testsuite/tests/typing-misc/is_expansive.ml b/testsuite/tests/typing-misc/is_expansive.ml new file mode 100644 index 00000000..3bab4f93 --- /dev/null +++ b/testsuite/tests/typing-misc/is_expansive.ml @@ -0,0 +1,12 @@ +(* TEST + * expect *) + +match [] with x -> (fun x -> x);; +[%%expect{| +- : 'a -> 'a = +|}];; + +match [] with x -> (fun x -> x) | _ -> .;; +[%%expect{| +- : 'a -> 'a = +|}];; diff --git a/testsuite/tests/typing-misc/ocamltests b/testsuite/tests/typing-misc/ocamltests index 1053da91..6d4e684a 100644 --- a/testsuite/tests/typing-misc/ocamltests +++ b/testsuite/tests/typing-misc/ocamltests @@ -2,6 +2,7 @@ constraints.ml disambiguate_principality.ml exotic_unifications.ml inside_out.ml +is_expansive.ml labels.ml occur_check.ml pat_type_sharing.ml @@ -14,8 +15,10 @@ pr6939-no-flat-float-array.ml pr7103.ml pr7228.ml pr7668_bad.ml +pr7937.ml pr8548.ml pr8548_split.ml +gpr2277.ml printing.ml records.ml scope_escape.ml diff --git a/testsuite/tests/typing-misc/polyvars.ml b/testsuite/tests/typing-misc/polyvars.ml index e6c88dd6..4ef27cb0 100644 --- a/testsuite/tests/typing-misc/polyvars.ml +++ b/testsuite/tests/typing-misc/polyvars.ml @@ -154,3 +154,13 @@ Here is an example of a case that is not matched: (`AnyOtherTag', `AnyOtherTag'') val f : [> `AnyOtherTag ] * [> `AnyOtherTag | `AnyOtherTag' ] -> int = |}] + +let x:(([`A] as 'a)* ([`B] as 'a)) = [`A] +[%%expect {| +Line 1, characters 22-32: +1 | let x:(([`A] as 'a)* ([`B] as 'a)) = [`A] + ^^^^^^^^^^ +Error: This alias is bound to type [ `B ] but is used as an instance of type + [ `A ] + These two variant types have no intersection +|}] diff --git a/testsuite/tests/typing-misc/pr6416.ml b/testsuite/tests/typing-misc/pr6416.ml index a3fa4eeb..4fb01c64 100644 --- a/testsuite/tests/typing-misc/pr6416.ml +++ b/testsuite/tests/typing-misc/pr6416.ml @@ -12,7 +12,7 @@ module M = struct end end;; [%%expect{| -Line 5, characters 8-52: +Lines 5-8, characters 8-5: 5 | ........struct 6 | type t = B 7 | let f B = () @@ -67,7 +67,7 @@ module K = struct end;; [%%expect{| -Line 4, characters 4-70: +Lines 4-7, characters 4-7: 4 | ....struct 5 | module type s 6 | module A(X:s) =struct end @@ -99,7 +99,7 @@ module L = struct end end;; [%%expect {| -Line 4, characters 4-77: +Lines 4-7, characters 4-7: 4 | ....struct 5 | module T = struct type t end 6 | type t = A of T.t @@ -187,7 +187,7 @@ end;; [%%expect{| -Line 4, characters 2-105: +Lines 4-7, characters 2-5: 4 | ..struct 5 | class a = object method c = let module X = struct type t end in () end 6 | class b = a @@ -219,7 +219,7 @@ module R = struct end;; [%%expect{| -Line 4, characters 2-65: +Lines 4-7, characters 2-5: 4 | ..struct 5 | class type a = object end 6 | class type b = a @@ -266,7 +266,7 @@ end = struct end;; [%%expect{| -Line 8, characters 6-141: +Lines 8-15, characters 6-3: 8 | ......struct 9 | type t 10 | class type a = object method m:t end @@ -343,7 +343,7 @@ type t = A type t = B type t = C type t = D -Line 5, characters 44-72: +Lines 5-7, characters 44-3: 5 | ............................................struct 6 | let f A B C = D 7 | end.. diff --git a/testsuite/tests/typing-misc/pr6634.ml b/testsuite/tests/typing-misc/pr6634.ml index 2faf7c98..3e1daa82 100644 --- a/testsuite/tests/typing-misc/pr6634.ml +++ b/testsuite/tests/typing-misc/pr6634.ml @@ -10,7 +10,7 @@ end;; [%%expect{| type t = int -Line 3, characters 0-31: +Lines 3-5, characters 0-3: 3 | struct 4 | type t = [`T of t] 5 | end.. diff --git a/testsuite/tests/typing-misc/pr7668_bad.ml b/testsuite/tests/typing-misc/pr7668_bad.ml index 5dccf5ac..95b64fb5 100644 --- a/testsuite/tests/typing-misc/pr7668_bad.ml +++ b/testsuite/tests/typing-misc/pr7668_bad.ml @@ -20,7 +20,7 @@ else `Right ()) xs val partition_map : ('a -> [< `Left of 'b | `Right of 'c ]) -> 'a list -> 'b list * 'c list = -Line 12, characters 35-96: +Lines 12-13, characters 35-18: 12 | ...................................partition_map (fun x -> if x then `Left () 13 | else `Right ()) xs Error: This expression has type unit list * unit list @@ -57,7 +57,7 @@ let a b = end ;; [%%expect{| -Line 8, characters 6-348: +Lines 8-27, characters 6-3: 8 | ......struct 9 | type t = [ 10 | | `A of int diff --git a/testsuite/tests/typing-misc/pr7937.ml b/testsuite/tests/typing-misc/pr7937.ml new file mode 100644 index 00000000..c4e42c7d --- /dev/null +++ b/testsuite/tests/typing-misc/pr7937.ml @@ -0,0 +1,84 @@ +(* TEST + * expect +*) + +type 'a r = [< `X of int & 'a ] as 'a + +let f: 'a. 'a r -> 'a r = fun x -> true;; +[%%expect {| +type 'a r = 'a constraint 'a = [< `X of int & 'a ] +Line 3, characters 35-39: +3 | let f: 'a. 'a r -> 'a r = fun x -> true;; + ^^^^ +Error: This expression has type bool but an expression was expected of type + ([< `X of int & 'a ] as 'a) r + Types for tag `X are incompatible +|}, Principal{| +type 'a r = 'a constraint 'a = [< `X of int & 'a ] +Line 3, characters 30-31: +3 | let f: 'a. 'a r -> 'a r = fun x -> true;; + ^ +Error: This pattern matches values of type + ([< `X of 'b & 'a & 'c & 'd & 'e ] as 'a) r + but a pattern was expected which matches values of type + ([< `X of int & 'f ] as 'f) r + Types for tag `X are incompatible +|}] + +let g: 'a. 'a r -> 'a r = fun x -> { contents = 0 };; +[%%expect {| +Line 1, characters 35-51: +1 | let g: 'a. 'a r -> 'a r = fun x -> { contents = 0 };; + ^^^^^^^^^^^^^^^^ +Error: This expression has type int ref + but an expression was expected of type ([< `X of int & 'a ] as 'a) r + Types for tag `X are incompatible +|}, Principal{| +Line 1, characters 30-31: +1 | let g: 'a. 'a r -> 'a r = fun x -> { contents = 0 };; + ^ +Error: This pattern matches values of type + ([< `X of 'b & 'a & 'c & 'd & 'e ] as 'a) r + but a pattern was expected which matches values of type + ([< `X of int & 'f ] as 'f) r + Types for tag `X are incompatible +|}] + +let h: 'a. 'a r -> _ = function true | false -> ();; +[%%expect {| +Line 1, characters 32-36: +1 | let h: 'a. 'a r -> _ = function true | false -> ();; + ^^^^ +Error: This pattern matches values of type bool + but a pattern was expected which matches values of type + ([< `X of int & 'a ] as 'a) r + Types for tag `X are incompatible +|}, Principal{| +Line 1, characters 32-36: +1 | let h: 'a. 'a r -> _ = function true | false -> ();; + ^^^^ +Error: This pattern matches values of type bool + but a pattern was expected which matches values of type + ([< `X of 'b & 'a & 'c ] as 'a) r + Types for tag `X are incompatible +|}] + + +let i: 'a. 'a r -> _ = function { contents = 0 } -> ();; +[%%expect {| +Line 1, characters 32-48: +1 | let i: 'a. 'a r -> _ = function { contents = 0 } -> ();; + ^^^^^^^^^^^^^^^^ +Error: This pattern matches values of type int ref + but a pattern was expected which matches values of type + ([< `X of int & 'a ] as 'a) r + Types for tag `X are incompatible +|}, Principal{| +Line 1, characters 32-48: +1 | let i: 'a. 'a r -> _ = function { contents = 0 } -> ();; + ^^^^^^^^^^^^^^^^ +Error: This pattern matches values of type int ref + but a pattern was expected which matches values of type + ([< `X of 'b & 'a & 'c ] as 'a) r + Types for tag `X are incompatible +|}] diff --git a/testsuite/tests/typing-misc/records.ml b/testsuite/tests/typing-misc/records.ml index 1d26860b..79f4c0af 100644 --- a/testsuite/tests/typing-misc/records.ml +++ b/testsuite/tests/typing-misc/records.ml @@ -164,3 +164,86 @@ Error: This expression has type string t but an expression was expected of type int t Type string is not compatible with type int |}] + +(* reexport *) + +type ('a,'b) def = { x:int } constraint 'b = [> `A] + +type arity = (int, [`A]) def = {x:int};; +[%%expect{| +type ('a, 'b) def = { x : int; } constraint 'b = [> `A ] +Line 3, characters 0-38: +3 | type arity = (int, [`A]) def = {x:int};; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type + (int, [ `A ]) def + They have different arities. +|}] + +type ('a,'b) ct = (int,'b) def = {x:int};; +[%%expect{| +Line 1, characters 0-40: +1 | type ('a,'b) ct = (int,'b) def = {x:int};; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type + (int, [> `A ]) def + Their constraints differ. +|}] + +type ('a,'b) kind = ('a, 'b) def = A constraint 'b = [> `A];; +[%%expect{| +Line 1, characters 0-59: +1 | type ('a,'b) kind = ('a, 'b) def = A constraint 'b = [> `A];; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type + ('a, [> `A ]) def + Their kinds differ. +|}] + +type d = { x:int; y : int } +type mut = d = {x:int; mutable y:int} +[%%expect{| +type d = { x : int; y : int; } +Line 2, characters 0-37: +2 | type mut = d = {x:int; mutable y:int} + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type d + The mutability of field y is different. +|}] + +type missing = d = { x:int } +[%%expect{| +Line 1, characters 0-28: +1 | type missing = d = { x:int } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type d + The field y is only present in the original definition. +|}] + +type wrong_type = d = {x:float} +[%%expect{| +Line 1, characters 0-31: +1 | type wrong_type = d = {x:float} + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type d + The types for field x are not equal. +|}] + +type unboxed = d = {x:float} [@@unboxed] +[%%expect{| +Line 1, characters 0-40: +1 | type unboxed = d = {x:float} [@@unboxed] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type d + Their internal representations differ: + this definition uses unboxed representation. +|}] + +type perm = d = {y:int; x:int} +[%%expect{| +Line 1, characters 0-30: +1 | type perm = d = {y:int; x:int} + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type d + Fields number 1 have different names, x and y. +|}] diff --git a/testsuite/tests/typing-misc/unique_names_in_unification.ml b/testsuite/tests/typing-misc/unique_names_in_unification.ml index 0c2d2650..ff7efe72 100644 --- a/testsuite/tests/typing-misc/unique_names_in_unification.ml +++ b/testsuite/tests/typing-misc/unique_names_in_unification.ml @@ -39,7 +39,7 @@ Line 7, characters 34-35: ^ Error: This expression has type M/2.t but an expression was expected of type M/1.t - Line 4, characters 2-41: + Lines 4-6, characters 2-5: Definition of module M/1 Line 1, characters 0-32: Definition of module M/2 @@ -54,8 +54,8 @@ type t = D Line 2, characters 25-26: 2 | let f: t -> t = fun D -> x;; ^ -Error: This expression has type t/1 but an expression was expected of type - t/2 +Error: This expression has type t/2 but an expression was expected of type + t/1 Line 1, characters 0-10: Definition of type t/1 Line 1, characters 0-10: diff --git a/testsuite/tests/typing-misc/variant.ml b/testsuite/tests/typing-misc/variant.ml index b1dfd1c0..40a4aac4 100644 --- a/testsuite/tests/typing-misc/variant.ml +++ b/testsuite/tests/typing-misc/variant.ml @@ -11,7 +11,7 @@ end = struct let f = function A | B -> 0 end;; [%%expect{| -Line 3, characters 6-61: +Lines 3-6, characters 6-3: 3 | ......struct 4 | type t = A | B 5 | let f = function A | B -> 0 @@ -42,3 +42,78 @@ module Make : val f : [ `A ] -> unit end |}] + + +(* reexport *) +type ('a,'b) def = X of int constraint 'b = [> `A] + +type arity = (int, [`A]) def = X of int;; +[%%expect{| +type ('a, 'b) def = X of int constraint 'b = [> `A ] +Line 3, characters 0-39: +3 | type arity = (int, [`A]) def = X of int;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type + (int, [ `A ]) def + They have different arities. +|}] + +type ('a,'b) ct = (int,'b) def = X of int;; +[%%expect{| +Line 1, characters 0-41: +1 | type ('a,'b) ct = (int,'b) def = X of int;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type + (int, [> `A ]) def + Their constraints differ. +|}] + +type ('a,'b) kind = ('a, 'b) def = {a:int} constraint 'b = [> `A];; +[%%expect{| +Line 1, characters 0-65: +1 | type ('a,'b) kind = ('a, 'b) def = {a:int} constraint 'b = [> `A];; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type + ('a, [> `A ]) def + Their kinds differ. +|}] + +type d = X of int | Y of int + +type missing = d = X of int +[%%expect{| +type d = X of int | Y of int +Line 3, characters 0-27: +3 | type missing = d = X of int + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type d + The field Y is only present in the original definition. +|}] + +type wrong_type = d = X of float +[%%expect{| +Line 1, characters 0-32: +1 | type wrong_type = d = X of float + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type d + The types for field X are not equal. +|}] + +type unboxed = d = X of float [@@unboxed] +[%%expect{| +Line 1, characters 0-41: +1 | type unboxed = d = X of float [@@unboxed] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type d + Their internal representations differ: + this definition uses unboxed representation. +|}] + +type perm = d = Y of int | X of int +[%%expect{| +Line 1, characters 0-35: +1 | type perm = d = Y of int | X of int + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type d + Fields number 1 have different names, X and Y. +|}] diff --git a/testsuite/tests/typing-missing-cmi-3/middle.ml b/testsuite/tests/typing-missing-cmi-3/middle.ml new file mode 100644 index 00000000..9b2bee40 --- /dev/null +++ b/testsuite/tests/typing-missing-cmi-3/middle.ml @@ -0,0 +1 @@ +type 'a t = 'a Original.t = T diff --git a/testsuite/tests/typing-missing-cmi-3/ocamltest b/testsuite/tests/typing-missing-cmi-3/ocamltest new file mode 100644 index 00000000..b38a63fe --- /dev/null +++ b/testsuite/tests/typing-missing-cmi-3/ocamltest @@ -0,0 +1 @@ +user.ml diff --git a/testsuite/tests/typing-missing-cmi-3/original.ml b/testsuite/tests/typing-missing-cmi-3/original.ml new file mode 100644 index 00000000..534a5fac --- /dev/null +++ b/testsuite/tests/typing-missing-cmi-3/original.ml @@ -0,0 +1 @@ +type 'a t = T diff --git a/testsuite/tests/typing-missing-cmi-3/user.ml b/testsuite/tests/typing-missing-cmi-3/user.ml new file mode 100644 index 00000000..c75821b5 --- /dev/null +++ b/testsuite/tests/typing-missing-cmi-3/user.ml @@ -0,0 +1,18 @@ +(* TEST + +files = "original.ml middle.ml" +* setup-ocamlc.byte-build-env +** ocamlc.byte +module = "original.ml" +*** ocamlc.byte +module = "middle.ml" +**** script +script = "rm -f original.cmi" +***** ocamlc.byte +module = "user.ml" +*) + + +let x:'a. 'a Middle.t = + let _r = ref 0 in + Middle.T diff --git a/testsuite/tests/typing-modules/Test.ml b/testsuite/tests/typing-modules/Test.ml index ad10f664..684351ea 100644 --- a/testsuite/tests/typing-modules/Test.ml +++ b/testsuite/tests/typing-modules/Test.ml @@ -180,7 +180,7 @@ end = struct type t += E of int end;; [%%expect{| -Line 3, characters 6-37: +Lines 3-5, characters 6-3: 3 | ......struct 4 | type t += E of int 5 | end.. diff --git a/testsuite/tests/typing-modules/illegal_permutation.ml b/testsuite/tests/typing-modules/illegal_permutation.ml new file mode 100644 index 00000000..12eff936 --- /dev/null +++ b/testsuite/tests/typing-modules/illegal_permutation.ml @@ -0,0 +1,656 @@ +(* TEST +* expect +*) +class type ct = object end +module type s = sig type a val one:int type b class two:ct type c type exn+=Three type d end +module type c12 = sig type a class two:ct type b val one:int type c type exn+=Three type d end +module type c123 = sig type a type exn+=Three type b class two:ct type c val one:int type d end + +module type expected = sig module type x = s end + +module A: expected = struct module type x = c12 end +[%%expect {| +class type ct = object end +module type s = + sig + type a + val one : int + type b + class two : ct + type c + type exn += Three + type d + end +module type c12 = + sig + type a + class two : ct + type b + val one : int + type c + type exn += Three + type d + end +module type c123 = + sig + type a + type exn += Three + type b + class two : ct + type c + val one : int + type d + end +module type expected = sig module type x = s end +Line 8, characters 21-51: +8 | module A: expected = struct module type x = c12 end + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Signature mismatch: + Modules do not match: + sig module type x = c12 end + is not included in + expected + Module type declarations do not match: + module type x = c12 + does not match + module type x = s + At position module type x = + Illegal permutation of runtime components in a module type. + For example, + the class "two" and the value "one" are not in the same order + in the expected and actual module types. +|}] + +module B: expected = struct module type x = c123 end +[%%expect {| +Line 1, characters 21-52: +1 | module B: expected = struct module type x = c123 end + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Signature mismatch: + Modules do not match: + sig module type x = c123 end + is not included in + expected + Module type declarations do not match: + module type x = c123 + does not match + module type x = s + At position module type x = + Illegal permutation of runtime components in a module type. + For example, + the extension constructor "Three" + and the value "one" are not in the same order + in the expected and actual module types. +|}] + + +module Far: sig + module type x = sig + val a:int + val b: int + val c: int + val d: int + val e:int + end +end = struct + module type x = sig + val a:int + val b:int + val e:int + val d:int + val c:int + end +end +[%%expect {| +Lines 9-17, characters 6-3: + 9 | ......struct +10 | module type x = sig +11 | val a:int +12 | val b:int +13 | val e:int +14 | val d:int +15 | val c:int +16 | end +17 | end +Error: Signature mismatch: + Modules do not match: + sig + module type x = + sig + val a : int + val b : int + val e : int + val d : int + val c : int + end + end + is not included in + sig + module type x = + sig + val a : int + val b : int + val c : int + val d : int + val e : int + end + end + Module type declarations do not match: + module type x = + sig + val a : int + val b : int + val e : int + val d : int + val c : int + end + does not match + module type x = + sig + val a : int + val b : int + val c : int + val d : int + val e : int + end + At position module type x = + Illegal permutation of runtime components in a module type. + For example, + the value "e" and the value "c" are not in the same order + in the expected and actual module types. +|}] + +module Confusing: sig + module type x= sig + class x:ct + val x:int + end +end = struct + module type x= sig + val x:int + class x:ct + end +end +[%%expect {| +Lines 6-11, characters 6-3: + 6 | ......struct + 7 | module type x= sig + 8 | val x:int + 9 | class x:ct +10 | end +11 | end +Error: Signature mismatch: + Modules do not match: + sig module type x = sig val x : int class x : ct end end + is not included in + sig module type x = sig class x : ct val x : int end end + Module type declarations do not match: + module type x = sig val x : int class x : ct end + does not match + module type x = sig class x : ct val x : int end + At position module type x = + Illegal permutation of runtime components in a module type. + For example, + the value "x" and the class "x" are not in the same order + in the expected and actual module types. +|}] + +module MT: sig + module type a = sig + module type b = sig + val x:int + val y:int + end + end +end = struct + module type a = sig + module type b = sig + val y:int + val x:int + end + end +end +[%%expect {| +Lines 8-15, characters 6-3: + 8 | ......struct + 9 | module type a = sig +10 | module type b = sig +11 | val y:int +12 | val x:int +13 | end +14 | end +15 | end +Error: Signature mismatch: + Modules do not match: + sig + module type a = + sig module type b = sig val y : int val x : int end end + end + is not included in + sig + module type a = + sig module type b = sig val x : int val y : int end end + end + Module type declarations do not match: + module type a = + sig module type b = sig val y : int val x : int end end + does not match + module type a = + sig module type b = sig val x : int val y : int end end + At position module type a = + Modules do not match: + sig module type b = sig val y : int val x : int end end + is not included in + sig module type b = sig val x : int val y : int end end + At position module type a = + Module type declarations do not match: + module type b = sig val y : int val x : int end + does not match + module type b = sig val x : int val y : int end + At position module type a = sig module type b = end + Illegal permutation of runtime components in a module type. + For example, + the value "y" and the value "x" are not in the same order + in the expected and actual module types. +|}] + +class type ct = object end +module Classes: sig + module type x = sig + class a: ct + class b: ct + end +end = struct + module type x = sig + class b: ct + class a: ct + end +end +[%%expect{| +class type ct = object end +Lines 7-12, characters 6-3: + 7 | ......struct + 8 | module type x = sig + 9 | class b: ct +10 | class a: ct +11 | end +12 | end +Error: Signature mismatch: + Modules do not match: + sig module type x = sig class b : ct class a : ct end end + is not included in + sig module type x = sig class a : ct class b : ct end end + Module type declarations do not match: + module type x = sig class b : ct class a : ct end + does not match + module type x = sig class a : ct class b : ct end + At position module type x = + Illegal permutation of runtime components in a module type. + For example, + the class "b" and the class "a" are not in the same order + in the expected and actual module types. +|}] + +module Ext: sig + module type x = sig + type exn+=A + type exn+=B + end +end = struct + module type x = sig + type exn+=B + type exn+=A + end +end +[%%expect{| +Lines 6-11, characters 6-3: + 6 | ......struct + 7 | module type x = sig + 8 | type exn+=B + 9 | type exn+=A +10 | end +11 | end +Error: Signature mismatch: + Modules do not match: + sig module type x = sig type exn += B type exn += A end end + is not included in + sig module type x = sig type exn += A type exn += B end end + Module type declarations do not match: + module type x = sig type exn += B type exn += A end + does not match + module type x = sig type exn += A type exn += B end + At position module type x = + Illegal permutation of runtime components in a module type. + For example, + the extension constructor "B" + and the extension constructor "A" are not in the same order + in the expected and actual module types. +|}] + + +module type w = sig + module One:s + module Two:s +end + +module type w21 = sig + module Two:s + module One:s +end + +module type wOne21 = sig + module One:c12 + module Two:s +end + +module C: sig module type x = w end = struct module type x = w21 end +[%%expect {| +module type w = sig module One : s module Two : s end +module type w21 = sig module Two : s module One : s end +module type wOne21 = sig module One : c12 module Two : s end +Line 16, characters 38-68: +16 | module C: sig module type x = w end = struct module type x = w21 end + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Signature mismatch: + Modules do not match: + sig module type x = w21 end + is not included in + sig module type x = w end + Module type declarations do not match: + module type x = w21 + does not match + module type x = w + At position module type x = + Illegal permutation of runtime components in a module type. + For example, + the module "Two" and the module "One" are not in the same order + in the expected and actual module types. +|}] + +module D: sig module type x = w end = struct module type x = wOne21 end +[%%expect {| +Line 1, characters 38-71: +1 | module D: sig module type x = w end = struct module type x = wOne21 end + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Signature mismatch: + Modules do not match: + sig module type x = wOne21 end + is not included in + sig module type x = w end + Module type declarations do not match: + module type x = wOne21 + does not match + module type x = w + At position module type x = + Illegal permutation of runtime components in a module type. + For example, in module One, + the class "two" and the value "one" are not in the same order + in the expected and actual module types. +|}] + +module F1: sig module type x = functor(X:s) -> s end = +struct + module type x = functor(X:c12) -> s +end +[%%expect {| +Lines 2-4, characters 0-3: +2 | struct +3 | module type x = functor(X:c12) -> s +4 | end +Error: Signature mismatch: + Modules do not match: + sig module type x = functor (X : c12) -> s end + is not included in + sig module type x = functor (X : s) -> s end + Module type declarations do not match: + module type x = functor (X : c12) -> s + does not match + module type x = functor (X : s) -> s + At position module type x = + Illegal permutation of runtime components in a module type. + For example, at position functor (X : ) -> ..., + the class "two" and the value "one" are not in the same order + in the expected and actual module types. +|}] + +module F2: sig module type x = functor(X:s) -> s end = +struct + module type x = functor(X:s) -> c12 +end +[%%expect {| +Lines 2-4, characters 0-3: +2 | struct +3 | module type x = functor(X:s) -> c12 +4 | end +Error: Signature mismatch: + Modules do not match: + sig module type x = functor (X : s) -> c12 end + is not included in + sig module type x = functor (X : s) -> s end + Module type declarations do not match: + module type x = functor (X : s) -> c12 + does not match + module type x = functor (X : s) -> s + At position module type x = + Illegal permutation of runtime components in a module type. + For example, at position functor (X) -> , + the class "two" and the value "one" are not in the same order + in the expected and actual module types. +|}] + +module Nested: sig + module type x = sig + module A: sig + module B: sig + module C: functor(X:sig end)(Y:sig end) + (Z: + sig + module D: sig + module E: sig + module F:functor(X:sig end) + (Arg:sig + val one:int + val two:int + end) -> sig end + end + end + end) + -> sig end + end + end + end +end=struct + module type x = sig + module A: sig + module B: sig + module C: functor(X:sig end)(Y:sig end) + (Z: + sig + module D: sig + module E: sig + module F:functor(X:sig end) + (Arg:sig + val two:int + val one:int + end) -> sig end + end + end + end) + -> sig end + end + end + end +end +[%%expect {| +Lines 22-43, characters 4-3: +22 | ....struct +23 | module type x = sig +24 | module A: sig +25 | module B: sig +26 | module C: functor(X:sig end)(Y:sig end) +... +40 | end +41 | end +42 | end +43 | end +Error: Signature mismatch: + Modules do not match: + sig + module type x = + sig + module A : + sig + module B : + sig + module C : + functor + (X : sig end) (Y : sig end) (Z : sig + module D : + sig + module E : + sig + module F : + functor + (X : + sig + + end) (Arg : + sig + val two : + int + val one : + int + end) -> + sig end + end + end + end) -> + sig end + end + end + end + end + is not included in + sig + module type x = + sig + module A : + sig + module B : + sig + module C : + functor + (X : sig end) (Y : sig end) (Z : sig + module D : + sig + module E : + sig + module F : + functor + (X : + sig + + end) (Arg : + sig + val one : + int + val two : + int + end) -> + sig end + end + end + end) -> + sig end + end + end + end + end + Module type declarations do not match: + module type x = + sig + module A : + sig + module B : + sig + module C : + functor + (X : sig end) (Y : sig end) (Z : sig + module D : + sig + module E : + sig + module F : + functor + (X : + sig + + end) (Arg : + sig + val two : + int + val one : + int + end) -> + sig end + end + end + end) -> + sig end + end + end + end + does not match + module type x = + sig + module A : + sig + module B : + sig + module C : + functor + (X : sig end) (Y : sig end) (Z : sig + module D : + sig + module E : + sig + module F : + functor + (X : + sig + + end) (Arg : + sig + val one : + int + val two : + int + end) -> + sig end + end + end + end) -> + sig end + end + end + end + At position module type x = + Illegal permutation of runtime components in a module type. + For example, + at position + module A : + sig + module B : + sig + module C(X)(Y)(Z : + sig + module D : + sig + module E : sig module F(X)(Arg : ) : ... end + end + end) : ... + end + end, + the value "two" and the value "one" are not in the same order + in the expected and actual module types. +|}] diff --git a/testsuite/tests/typing-modules/nondep_private_abbrev.ml b/testsuite/tests/typing-modules/nondep_private_abbrev.ml index f0b0ec57..886fcfc5 100644 --- a/testsuite/tests/typing-modules/nondep_private_abbrev.ml +++ b/testsuite/tests/typing-modules/nondep_private_abbrev.ml @@ -99,7 +99,7 @@ end = struct type s = t end;; [%%expect{| -Line 3, characters 6-29: +Lines 3-5, characters 6-3: 3 | ......struct 4 | type s = t 5 | end.. diff --git a/testsuite/tests/typing-modules/normalize_path.ml b/testsuite/tests/typing-modules/normalize_path.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/typing-modules/ocamltests b/testsuite/tests/typing-modules/ocamltests index 34d5fbaa..e9784a25 100644 --- a/testsuite/tests/typing-modules/ocamltests +++ b/testsuite/tests/typing-modules/ocamltests @@ -2,6 +2,7 @@ aliases.ml applicative_functor_type.ml firstclass.ml generative.ml +illegal_permutation.ml nondep.ml nondep_private_abbrev.ml normalize_path.ml @@ -13,6 +14,7 @@ pr7726.ml pr7787.ml pr7818.ml pr7851.ml +pr8810.ml printing.ml recursive.ml Test.ml diff --git a/testsuite/tests/typing-modules/pr6394.ml b/testsuite/tests/typing-modules/pr6394.ml index 3fa04735..97bbeebf 100644 --- a/testsuite/tests/typing-modules/pr6394.ml +++ b/testsuite/tests/typing-modules/pr6394.ml @@ -10,7 +10,7 @@ end = struct let f = function A | B -> 0 end;; [%%expect{| -Line 4, characters 6-63: +Lines 4-7, characters 6-3: 4 | ......struct 5 | type t = A | B 6 | let f = function A | B -> 0 diff --git a/testsuite/tests/typing-modules/pr7818.ml b/testsuite/tests/typing-modules/pr7818.ml index eec5440b..75ba000f 100644 --- a/testsuite/tests/typing-modules/pr7818.ml +++ b/testsuite/tests/typing-modules/pr7818.ml @@ -108,7 +108,7 @@ module Make2 (T' : S) : sig module Id : sig end module Id2 = Id end module Id2 = Id end;; [%%expect{| -Line 2, characters 57-107: +Lines 2-5, characters 57-3: 2 | .........................................................struct 3 | module Id = T'.T.Id 4 | module Id2 = Id diff --git a/testsuite/tests/typing-modules/pr8810.ml b/testsuite/tests/typing-modules/pr8810.ml new file mode 100644 index 00000000..57bfa17f --- /dev/null +++ b/testsuite/tests/typing-modules/pr8810.ml @@ -0,0 +1,7 @@ +(* TEST +* setup-ocamlc.byte-build-env +flags = "-no-alias-deps -w -49 -c" +** ocamlc.byte +ocamlc_byte_exit_status = "2" +*) +module Loop = Pr8810 diff --git a/testsuite/tests/typing-objects-bugs/pr3968_bad.compilers.reference b/testsuite/tests/typing-objects-bugs/pr3968_bad.compilers.reference index dc5c5312..a5685448 100644 --- a/testsuite/tests/typing-objects-bugs/pr3968_bad.compilers.reference +++ b/testsuite/tests/typing-objects-bugs/pr3968_bad.compilers.reference @@ -1,4 +1,4 @@ -File "pr3968_bad.ml", line 20, characters 0-165: +File "pr3968_bad.ml", lines 20-29, characters 0-3: 20 | object 21 | val l = e1 22 | val r = e2 diff --git a/testsuite/tests/typing-objects/Exemples.ml b/testsuite/tests/typing-objects/Exemples.ml index 4d8f62d9..00cbde53 100644 --- a/testsuite/tests/typing-objects/Exemples.ml +++ b/testsuite/tests/typing-objects/Exemples.ml @@ -95,7 +95,7 @@ class ref x_init = object method set y = x <- y end;; [%%expect{| -Line 1, characters 0-95: +Lines 1-5, characters 0-3: 1 | class ref x_init = object 2 | val mutable x = x_init 3 | method get = x diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml index 6d0d832a..b045c058 100644 --- a/testsuite/tests/typing-objects/Tests.ml +++ b/testsuite/tests/typing-objects/Tests.ml @@ -31,7 +31,7 @@ end and d () = object inherit ['a] c () end;; [%%expect{| -Line 3, characters 4-45: +Lines 3-5, characters 4-3: 3 | ....and d () = object 4 | inherit ['a] c () 5 | end.. @@ -88,7 +88,7 @@ class x () = object method virtual f : int end;; [%%expect{| -Line 1, characters 0-48: +Lines 1-3, characters 0-3: 1 | class x () = object 2 | method virtual f : int 3 | end.. @@ -116,7 +116,7 @@ class ['a] c () = object method f x = (x : bool c) end;; [%%expect{| -Line 1, characters 0-78: +Lines 1-4, characters 0-3: 1 | class ['a] c () = object 2 | constraint 'a = int 3 | method f x = (x : bool c) @@ -162,7 +162,7 @@ class ['a] c () = object method f = (x : 'a) end;; [%%expect{| -Line 1, characters 0-50: +Lines 1-3, characters 0-3: 1 | class ['a] c () = object 2 | method f = (x : 'a) 3 | end.. @@ -618,7 +618,7 @@ class virtual ['a] matrix (sz, init : int * 'a) = object method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) end;; [%%expect{| -Line 1, characters 0-153: +Lines 1-4, characters 0-3: 1 | class virtual ['a] matrix (sz, init : int * 'a) = object 2 | val m = Array.make_matrix sz sz init 3 | method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) @@ -667,7 +667,7 @@ end : sig val f : #c -> #c end);; [%%expect{| -Line 1, characters 12-43: +Lines 1-3, characters 12-3: 1 | ............struct 2 | let f (x : #c) = x 3 | end...... diff --git a/testsuite/tests/typing-objects/dummy.ml b/testsuite/tests/typing-objects/dummy.ml index 842c3bf7..3256e48a 100644 --- a/testsuite/tests/typing-objects/dummy.ml +++ b/testsuite/tests/typing-objects/dummy.ml @@ -139,7 +139,7 @@ class leading_up_to = object(self : 'a) end end;; [%%expect{| -Line 4, characters 4-65: +Lines 4-7, characters 4-7: 4 | ....object 5 | inherit child1 self 6 | inherit child2 @@ -162,7 +162,7 @@ class assertion_failure = object(self : 'a) end end;; [%%expect{| -Line 4, characters 4-129: +Lines 4-10, characters 4-7: 4 | ....object 5 | inherit child1 self 6 | inherit child2 diff --git a/testsuite/tests/typing-objects/pr5619_bad.ml b/testsuite/tests/typing-objects/pr5619_bad.ml index 8cfa9066..bfbf6dd8 100644 --- a/testsuite/tests/typing-objects/pr5619_bad.ml +++ b/testsuite/tests/typing-objects/pr5619_bad.ml @@ -40,7 +40,7 @@ class foo: foo_t = end ;; [%%expect{| -Line 2, characters 2-156: +Lines 2-8, characters 2-5: 2 | ..object(self) 3 | method foo = "foo" 4 | method cast: type a. a name -> a = diff --git a/testsuite/tests/typing-ocamlc-i/pervasives_leitmotiv.compilers.reference b/testsuite/tests/typing-ocamlc-i/pervasives_leitmotiv.compilers.reference index 358391a3..def5d748 100644 --- a/testsuite/tests/typing-ocamlc-i/pervasives_leitmotiv.compilers.reference +++ b/testsuite/tests/typing-ocamlc-i/pervasives_leitmotiv.compilers.reference @@ -2,7 +2,7 @@ File "pervasives_leitmotiv.ml", line 1: Warning 63: The printed interface differs from the inferred interface. The inferred interface contained items which could not be printed properly due to name collisions between identifiers. -File "pervasives_leitmotiv.ml", line 10, characters 0-45: +File "pervasives_leitmotiv.ml", lines 10-12, characters 0-3: Definition of module Stdlib/1 File "_none_", line 1: Definition of module Stdlib/2 diff --git a/testsuite/tests/typing-ocamlc-i/pr7402.compilers.reference b/testsuite/tests/typing-ocamlc-i/pr7402.compilers.reference index 08c87199..46811961 100644 --- a/testsuite/tests/typing-ocamlc-i/pr7402.compilers.reference +++ b/testsuite/tests/typing-ocamlc-i/pr7402.compilers.reference @@ -2,9 +2,9 @@ File "pr7402.ml", line 1: Warning 63: The printed interface differs from the inferred interface. The inferred interface contained items which could not be printed properly due to name collisions between identifiers. -File "pr7402.ml", line 14, characters 0-39: +File "pr7402.ml", lines 14-16, characters 0-5: Definition of module M/1 -File "pr7402.ml", line 8, characters 0-70: +File "pr7402.ml", lines 8-11, characters 0-3: Definition of module M/2 Beware that this warning is purely informational and will not catch all instances of erroneous printed interface. diff --git a/testsuite/tests/typing-poly/error_messages.ml b/testsuite/tests/typing-poly/error_messages.ml index 0f22bccc..989c6ceb 100644 --- a/testsuite/tests/typing-poly/error_messages.ml +++ b/testsuite/tests/typing-poly/error_messages.ml @@ -54,7 +54,7 @@ let _ = f (object [%%expect {| class type t_a = object method f : 'a -> int end val f : t_a -> int = -Line 5, characters 10-42: +Lines 5-7, characters 10-5: 5 | ..........(object 6 | method f _ = 0 7 | end).. diff --git a/testsuite/tests/typing-poly/poly.ml b/testsuite/tests/typing-poly/poly.ml index c8f050c1..36002adc 100644 --- a/testsuite/tests/typing-poly/poly.ml +++ b/testsuite/tests/typing-poly/poly.ml @@ -47,7 +47,7 @@ match px with | {pv=true::_} -> "bool" ;; [%%expect {| -Line 1, characters 0-77: +Lines 1-4, characters 0-24: 1 | match px with 2 | | {pv=[]} -> "OK" 3 | | {pv=5::_} -> "int" @@ -64,7 +64,7 @@ match px with | {pv=5::_} -> "int" ;; [%%expect {| -Line 1, characters 0-77: +Lines 1-4, characters 0-20: 1 | match px with 2 | | {pv=[]} -> "OK" 3 | | {pv=true::_} -> "bool" @@ -555,7 +555,7 @@ class id4 () = object end ;; [%%expect {| -Line 4, characters 12-79: +Lines 4-7, characters 12-17: 4 | ............x = 5 | match r with 6 | None -> r <- Some x; x @@ -845,7 +845,7 @@ val f : (< p : int * 'c > as 'c) -> unit = |}];; -(* PR#1374 *) +(* PR#3643 *) type 'a t= [`A of 'a];; class c = object (self) @@ -893,7 +893,7 @@ type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a > type 'b alist = < visit : 'a. ('a, 'b) list_visitor -> 'a > |}];; -(* PR#1607 *) +(* PR#8074 *) class type ct = object ('s) method fold : ('b -> 's -> 'b) -> 'b -> 'b end @@ -903,7 +903,7 @@ class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; } |}];; -(* PR#1663 *) +(* PR#8124 *) type t = u and u = t;; [%%expect {| Line 1, characters 0-10: @@ -913,7 +913,7 @@ Error: The definition of t contains a cycle: u |}];; -(* PR#1731 *) +(* PR#8188 *) class ['t] a = object constraint 't = [> `A of 't a] end type t = [ `A of t a ];; [%%expect {| @@ -975,7 +975,7 @@ Line 1, characters 0-24: Error: In the definition of v, type 'a list u should be 'a u |}];; -(* PR#1744: Ctype.matches *) +(* PR#8198: Ctype.matches *) type 'a t = 'a type 'a u = A of 'a t;; [%%expect {| @@ -1008,7 +1008,7 @@ Error: The definition of a contains a cycle: [> `B of ('a, 'b) b as 'b ] as 'a |}];; -(* PR#1917: expanding may change original in Ctype.unify2 *) +(* PR#8359: expanding may change original in Ctype.unify2 *) (* Note: since 3.11, the abbreviations are not used when printing a type where they occur recursively inside. *) class type ['a, 'b] a = object @@ -1222,7 +1222,7 @@ let f5 x = let f6 x = (x : ] as 'a> :> ] as 'a>);; [%%expect {| -Line 2, characters 2-88: +Lines 2-3, characters 2-47: 2 | ..(x : as 'a) -> int> 3 | :> as 'b) -> int>).. Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of @@ -1734,3 +1734,22 @@ Error: The type of this class, object constraint 'a = '_weak2 list ref method get : 'a end, contains type variables that cannot be generalized |}] + +(* #8701 *) +type 'a t = 'a constraint 'a = 'b list;; +type 'a s = 'a list;; +let id x = x;; +[%%expect{| +type 'a t = 'a constraint 'a = 'b list +type 'a s = 'a list +val id : 'a -> 'a = +|}] + +let x : [ `Foo of _ s | `Foo of 'a t ] = id (`Foo []);; +[%%expect{| +val x : [ `Foo of 'a s ] = `Foo [] +|}] +let x : [ `Foo of 'a t | `Foo of _ s ] = id (`Foo []);; +[%%expect{| +val x : [ `Foo of 'a list t ] = `Foo [] +|}] diff --git a/testsuite/tests/typing-polyvariants-bugs/pr7824.ml b/testsuite/tests/typing-polyvariants-bugs/pr7824.ml index 59ffd96f..a4484494 100644 --- a/testsuite/tests/typing-polyvariants-bugs/pr7824.ml +++ b/testsuite/tests/typing-polyvariants-bugs/pr7824.ml @@ -37,7 +37,7 @@ let f x = | _::_ -> (x :> [`A | `C] Element.t) ;; [%%expect{| -Line 4, characters 2-54: +Lines 4-5, characters 2-38: 4 | ..match [] with 5 | | _::_ -> (x :> [`A | `C] Element.t) Warning 8: this pattern-matching is not exhaustive. diff --git a/testsuite/tests/typing-recmod/t12bad.compilers.reference b/testsuite/tests/typing-recmod/t12bad.compilers.reference index b83fdc6d..6b531a1b 100644 --- a/testsuite/tests/typing-recmod/t12bad.compilers.reference +++ b/testsuite/tests/typing-recmod/t12bad.compilers.reference @@ -1,4 +1,4 @@ -File "t12bad.ml", line 11, characters 4-101: +File "t12bad.ml", lines 11-15, characters 4-7: 11 | ....sig 12 | class ['a] c : 'a -> object 13 | method map : ('a -> 'b) -> 'b M.c diff --git a/testsuite/tests/typing-safe-linking/b_bad.compilers.reference b/testsuite/tests/typing-safe-linking/b_bad.compilers.reference index 46124ba4..4f9cd7e5 100644 --- a/testsuite/tests/typing-safe-linking/b_bad.compilers.reference +++ b/testsuite/tests/typing-safe-linking/b_bad.compilers.reference @@ -1,4 +1,4 @@ -File "b_bad.ml", line 13, characters 29-66: +File "b_bad.ml", lines 13-14, characters 29-28: 13 | .............................function 14 | A.X s -> print_endline s Error (warning 8): this pattern-matching is not exhaustive. diff --git a/testsuite/tests/typing-sigsubst/sig_local_aliases.ml b/testsuite/tests/typing-sigsubst/sig_local_aliases.ml index 8bae4467..0427ad25 100644 --- a/testsuite/tests/typing-sigsubst/sig_local_aliases.ml +++ b/testsuite/tests/typing-sigsubst/sig_local_aliases.ml @@ -101,20 +101,3 @@ Line 3, characters 11-12: ^ Error: Unbound type constructor t |}] - -(** MPR7905, PR2231: - We want to reject invalid right-hand side - before typing the type declaration. -*) -module type Rejected = sig - type cycle = A of cycle - type t := cycle = A of t - (** this type declaration is purposefully erroneous *) -end - -[%%expect{| -Line 3, characters 2-26: -3 | type t := cycle = A of t - ^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Only type synonyms are allowed on the right of := -|}] diff --git a/testsuite/tests/typing-sigsubst/sigsubst.ml b/testsuite/tests/typing-sigsubst/sigsubst.ml index 140acb49..1e333a05 100644 --- a/testsuite/tests/typing-sigsubst/sigsubst.ml +++ b/testsuite/tests/typing-sigsubst/sigsubst.ml @@ -47,7 +47,7 @@ module type S0 = sig and M2 : sig type t = int end end with type M.t = int [%%expect {| -Line 1, characters 17-115: +Lines 1-4, characters 17-23: 1 | .................sig 2 | module rec M : sig type t = M2.t end 3 | and M2 : sig type t = int end @@ -162,7 +162,7 @@ module type S = sig end with type 'a t2 := 'a t * bool [%%expect {| type 'a t constraint 'a = 'b list -Line 2, characters 16-142: +Lines 2-6, characters 16-34: 2 | ................sig 3 | type 'a t2 constraint 'a = 'b list 4 | type 'a mylist = 'a list @@ -267,7 +267,7 @@ module type S = sig module A = M end with type M.t := float [%%expect {| -Line 1, characters 16-89: +Lines 1-4, characters 16-26: 1 | ................sig 2 | module M : sig type t end 3 | module A = M @@ -329,7 +329,7 @@ module type S3 = sig end with type M2.t := int [%%expect {| module Id : functor (X : sig type t end) -> sig type t = X.t end -Line 2, characters 17-120: +Lines 2-5, characters 17-25: 2 | .................sig 3 | module rec M : sig type t = A of Id(M2).t end 4 | and M2 : sig type t end @@ -372,7 +372,7 @@ module type S = sig module Alias = M end with module M.N := A [%%expect {| -Line 1, characters 16-159: +Lines 1-10, characters 16-24: 1 | ................sig 2 | module M : sig 3 | module N : sig diff --git a/testsuite/tests/typing-typeparam/newtype.ocaml.reference b/testsuite/tests/typing-typeparam/newtype.ocaml.reference index 5b1a6039..911fb8a5 100644 --- a/testsuite/tests/typing-typeparam/newtype.ocaml.reference +++ b/testsuite/tests/typing-typeparam/newtype.ocaml.reference @@ -1,9 +1,9 @@ -val property : unit -> ('a -> exn) * (exn -> 'a option) = +val property : unit -> ('t -> exn) * (exn -> 't option) = false true true false -val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list = +val sort_uniq : ('s -> 's -> int) -> 's list -> 's list = abc,xyz Line 2, characters 32-33: 2 | let f x (type a) (y : a) = (x = y);; (* Fails *) diff --git a/testsuite/tests/typing-unboxed-types/test.ml b/testsuite/tests/typing-unboxed-types/test.ml index 8ee1588c..ce79acd4 100644 --- a/testsuite/tests/typing-unboxed-types/test.ml +++ b/testsuite/tests/typing-unboxed-types/test.ml @@ -111,7 +111,7 @@ end = struct type t = A of string [@@ocaml.unboxed] end;; [%%expect{| -Line 3, characters 6-57: +Lines 3-5, characters 6-3: 3 | ......struct 4 | type t = A of string [@@ocaml.unboxed] 5 | end.. @@ -134,7 +134,7 @@ end = struct type t = A of string end;; [%%expect{| -Line 3, characters 6-39: +Lines 3-5, characters 6-3: 3 | ......struct 4 | type t = A of string 5 | end.. @@ -157,7 +157,7 @@ end = struct type t = { f : string } [@@ocaml.unboxed] end;; [%%expect{| -Line 3, characters 6-60: +Lines 3-5, characters 6-3: 3 | ......struct 4 | type t = { f : string } [@@ocaml.unboxed] 5 | end.. @@ -180,7 +180,7 @@ end = struct type t = { f : string } end;; [%%expect{| -Line 3, characters 6-42: +Lines 3-5, characters 6-3: 3 | ......struct 4 | type t = { f : string } 5 | end.. @@ -203,7 +203,7 @@ end = struct type t = A of { f : string } [@@ocaml.unboxed] end;; [%%expect{| -Line 3, characters 6-65: +Lines 3-5, characters 6-3: 3 | ......struct 4 | type t = A of { f : string } [@@ocaml.unboxed] 5 | end.. @@ -226,7 +226,7 @@ end = struct type t = A of { f : string } end;; [%%expect{| -Line 3, characters 6-47: +Lines 3-5, characters 6-3: 3 | ......struct 4 | type t = A of { f : string } 5 | end.. @@ -292,7 +292,7 @@ end = struct type u = { f1 : t; f2 : t } end;; [%%expect{| -Line 4, characters 6-86: +Lines 4-7, characters 6-3: 4 | ......struct 5 | type t = A of float [@@ocaml.unboxed] 6 | type u = { f1 : t; f2 : t } diff --git a/testsuite/tests/typing-unboxed/test.ml b/testsuite/tests/typing-unboxed/test.ml index 4dff4e46..3ac3e27a 100644 --- a/testsuite/tests/typing-unboxed/test.ml +++ b/testsuite/tests/typing-unboxed/test.ml @@ -106,7 +106,7 @@ end = struct end;; [%%expect{| -Line 3, characters 6-70: +Lines 3-5, characters 6-3: 3 | ......struct 4 | external f : int -> (int [@untagged]) = "f" "f_nat" 5 | end.. @@ -128,7 +128,7 @@ end = struct end;; [%%expect{| -Line 3, characters 6-70: +Lines 3-5, characters 6-3: 3 | ......struct 4 | external f : (int [@untagged]) -> int = "f" "f_nat" 5 | end.. @@ -150,7 +150,7 @@ end = struct end;; [%%expect{| -Line 3, characters 6-73: +Lines 3-5, characters 6-3: 3 | ......struct 4 | external f : float -> (float [@unboxed]) = "f" "f_nat" 5 | end.. @@ -172,7 +172,7 @@ end = struct end;; [%%expect{| -Line 3, characters 6-73: +Lines 3-5, characters 6-3: 3 | ......struct 4 | external f : (float [@unboxed]) -> float = "f" "f_nat" 5 | end.. @@ -196,7 +196,7 @@ end = struct end;; [%%expect{| -Line 3, characters 6-56: +Lines 3-5, characters 6-3: 3 | ......struct 4 | external f : int -> int = "f" "f_nat" 5 | end.. @@ -218,7 +218,7 @@ end = struct end;; [%%expect{| -Line 3, characters 6-56: +Lines 3-5, characters 6-3: 3 | ......struct 4 | external f : int -> int = "a" "a_nat" 5 | end.. @@ -240,7 +240,7 @@ end = struct end;; [%%expect{| -Line 3, characters 6-60: +Lines 3-5, characters 6-3: 3 | ......struct 4 | external f : float -> float = "f" "f_nat" 5 | end.. @@ -262,7 +262,7 @@ end = struct end;; [%%expect{| -Line 3, characters 6-60: +Lines 3-5, characters 6-3: 3 | ......struct 4 | external f : float -> float = "a" "a_nat" 5 | end.. diff --git a/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml b/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml index 3a8d5a01..66c6f389 100644 --- a/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml +++ b/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml @@ -197,7 +197,7 @@ let ambiguous__first_orpat = function | _ -> () ;; [%%expect {| -Line 2, characters 4-101: +Lines 2-3, characters 4-58: 2 | ....`A ((`B (Some x, _) | `B (_, Some x)), 3 | (`C (Some y, Some _, _) | `C (Some y, _, Some _)))................. Warning 57: Ambiguous or-pattern variables under guard; @@ -215,7 +215,7 @@ let ambiguous__second_orpat = function | _ -> () ;; [%%expect {| -Line 2, characters 4-101: +Lines 2-3, characters 4-42: 2 | ....`A ((`B (Some x, Some _, _) | `B (Some x, _, Some _)), 3 | (`C (Some y, _) | `C (_, Some y)))................. Warning 57: Ambiguous or-pattern variables under guard; @@ -308,7 +308,7 @@ let ambiguous__amoi a = match a with | X _|Y _|Z _ -> 1 ;; [%%expect {| -Line 2, characters 2-35: +Lines 2-3, characters 2-17: 2 | ..X (Z x,Y (y,0)) 3 | | X (Z y,Y (x,_)) Warning 57: Ambiguous or-pattern variables under guard; @@ -328,7 +328,7 @@ let ambiguous__module_variable x b = match x with | _ -> 2 ;; [%%expect {| -Line 2, characters 4-49: +Lines 2-3, characters 4-24: 2 | ....(module M:S),_,(1,_) 3 | | _,(module M:S),(_,1)................... Warning 57: Ambiguous or-pattern variables under guard; @@ -365,7 +365,7 @@ Line 2, characters 4-5: ^ Warning 41: A belongs to several types: t2 t The first one was selected. Please disambiguate if this is wrong. -Line 1, characters 41-137: +Lines 1-3, characters 41-10: 1 | .........................................function 2 | | A (x as z,(0 as y))|A (0 as y as z,x)|B (x,(y as z)) when g x (y+z) -> 1 3 | | _ -> 2 diff --git a/testsuite/tests/typing-warnings/exhaustiveness.ml b/testsuite/tests/typing-warnings/exhaustiveness.ml index 35b10046..e2eaeb11 100644 --- a/testsuite/tests/typing-warnings/exhaustiveness.ml +++ b/testsuite/tests/typing-warnings/exhaustiveness.ml @@ -8,7 +8,7 @@ let f = function None, None -> 1 | Some _, Some _ -> 2;; [%%expect {| -Line 1, characters 8-60: +Lines 1-3, characters 8-23: 1 | ........function 2 | None, None -> 1 3 | | Some _, Some _ -> 2.. @@ -38,7 +38,7 @@ let f : type a b c d e f g. (*| _ -> _ *) ;; [%%expect {| -Line 4, characters 1-82: +Lines 4-5, characters 1-38: 4 | .function A, A, A, A, A, A, A, _, U, U -> 1 5 | | _, _, _, _, _, _, _, G, _, _ -> 1 Warning 8: this pattern-matching is not exhaustive. @@ -358,7 +358,7 @@ let f = function | Some x when x <= 0 -> () ;; [%%expect {| -Line 1, characters 8-88: +Lines 1-4, characters 8-28: 1 | ........function 2 | | None -> () 3 | | Some x when x > 0 -> () diff --git a/testsuite/tests/typing-warnings/open_warnings.ml b/testsuite/tests/typing-warnings/open_warnings.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/typing-warnings/pr6587.ml b/testsuite/tests/typing-warnings/pr6587.ml index ed7ade44..665f6ed7 100644 --- a/testsuite/tests/typing-warnings/pr6587.ml +++ b/testsuite/tests/typing-warnings/pr6587.ml @@ -23,7 +23,7 @@ module B: sig val f: fpclass -> fpclass end = end ;; [%%expect {| -Line 2, characters 2-38: +Lines 2-4, characters 2-5: 2 | ..struct 3 | let f A = FP_normal 4 | end diff --git a/testsuite/tests/warnings/deprecated_module.ml b/testsuite/tests/warnings/deprecated_module.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/warnings/deprecated_module.mli b/testsuite/tests/warnings/deprecated_module.mli old mode 100755 new mode 100644 diff --git a/testsuite/tests/warnings/deprecated_module_assigment.ml b/testsuite/tests/warnings/deprecated_module_assigment.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/warnings/deprecated_module_use.ml b/testsuite/tests/warnings/deprecated_module_use.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/warnings/w04.compilers.reference b/testsuite/tests/warnings/w04.compilers.reference index 3f091a39..bb39fb4d 100644 --- a/testsuite/tests/warnings/w04.compilers.reference +++ b/testsuite/tests/warnings/w04.compilers.reference @@ -1,4 +1,4 @@ -File "w04.ml", line 21, characters 10-40: +File "w04.ml", lines 21-23, characters 10-8: 21 | ..........match x with 22 | | A -> 0 23 | | _ -> 1 diff --git a/testsuite/tests/warnings/w04_failure.compilers.reference b/testsuite/tests/warnings/w04_failure.compilers.reference index e833d2bb..d0fac4da 100644 --- a/testsuite/tests/warnings/w04_failure.compilers.reference +++ b/testsuite/tests/warnings/w04_failure.compilers.reference @@ -1,18 +1,18 @@ -File "w04_failure.ml", line 20, characters 2-78: +File "w04_failure.ml", lines 20-23, characters 2-17: 20 | ..match r1, r2, t with 21 | | AB, _, A -> () 22 | | _, XY, X -> () 23 | | _, _, _ -> () Warning 4: this pattern-matching is fragile. It will remain exhaustive when constructors are added to type repr. -File "w04_failure.ml", line 20, characters 2-78: +File "w04_failure.ml", lines 20-23, characters 2-17: 20 | ..match r1, r2, t with 21 | | AB, _, A -> () 22 | | _, XY, X -> () 23 | | _, _, _ -> () Warning 4: this pattern-matching is fragile. It will remain exhaustive when constructors are added to type ab. -File "w04_failure.ml", line 20, characters 2-78: +File "w04_failure.ml", lines 20-23, characters 2-17: 20 | ..match r1, r2, t with 21 | | AB, _, A -> () 22 | | _, XY, X -> () diff --git a/testsuite/tests/warnings/w32.compilers.reference b/testsuite/tests/warnings/w32.compilers.reference index e1d5fdbd..6b4abe2b 100644 --- a/testsuite/tests/warnings/w32.compilers.reference +++ b/testsuite/tests/warnings/w32.compilers.reference @@ -46,7 +46,7 @@ File "w32.ml", line 59, characters 22-23: 59 | and[@warning "+32"] k x = x ^ Warning 32: unused value k. -File "w32.ml", line 52, characters 0-174: +File "w32.ml", lines 52-60, characters 0-3: 52 | module M = struct 53 | [@@@warning "-32"] 54 | let f x = x diff --git a/testsuite/tests/warnings/w45.ml b/testsuite/tests/warnings/w45.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/warnings/w50.ml b/testsuite/tests/warnings/w50.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/warnings/w60.ml b/testsuite/tests/warnings/w60.ml old mode 100755 new mode 100644 diff --git a/testsuite/tests/warnings/w60.mli b/testsuite/tests/warnings/w60.mli old mode 100755 new mode 100644 diff --git a/testsuite/tests/win-unicode/mltest.compilers.reference b/testsuite/tests/win-unicode/mltest.compilers.reference old mode 100755 new mode 100644 diff --git a/testsuite/tools/Makefile b/testsuite/tools/Makefile index 9027bf61..6e6370d7 100644 --- a/testsuite/tools/Makefile +++ b/testsuite/tools/Makefile @@ -30,6 +30,7 @@ codegen_INCLUDES=\ -I $(OTOPDIR)/typing \ -I $(OTOPDIR)/middle_end \ -I $(OTOPDIR)/bytecomp \ + -I $(OTOPDIR)/lambda \ -I $(OTOPDIR)/asmcomp codegen_OTHEROBJECTS=\ diff --git a/testsuite/tools/expect_test.ml b/testsuite/tools/expect_test.ml index 73941acc..84813889 100644 --- a/testsuite/tools/expect_test.ml +++ b/testsuite/tools/expect_test.ml @@ -334,7 +334,7 @@ let main fname = Clflags.no_std_include := true; Compenv.last_include_dirs := [Filename.concat dir "stdlib"] end; - Compmisc.init_path false; + Compmisc.init_path (); Toploop.initialize_toplevel_env (); Sys.interactive := false; process_expect_file fname; diff --git a/testsuite/tools/parsecmm.mly b/testsuite/tools/parsecmm.mly index 673ded99..d85cb59a 100644 --- a/testsuite/tools/parsecmm.mly +++ b/testsuite/tools/parsecmm.mly @@ -29,22 +29,27 @@ let rec make_letdef def body = let make_switch n selector caselist = let index = Array.make n 0 in let casev = Array.of_list caselist in - let actv = Array.make (Array.length casev) (Cexit(0,[])) in + let dbg = Debuginfo.none in + let actv = Array.make (Array.length casev) (Cexit(0,[]), dbg) in for i = 0 to Array.length casev - 1 do let (posl, e) = casev.(i) in List.iter (fun pos -> index.(pos) <- i) posl; - actv.(i) <- e + actv.(i) <- (e, dbg) done; - Cswitch(selector, index, actv, Debuginfo.none) + Cswitch(selector, index, actv, dbg) let access_array base numelt size = match numelt with - Cconst_int 0 -> base - | Cconst_int n -> Cop(Cadda, [base; Cconst_int(n * size)], Debuginfo.none) - | _ -> Cop(Cadda, [base; - Cop(Clsl, [numelt; Cconst_int(Misc.log2 size)], - Debuginfo.none)], - Debuginfo.none) + Cconst_int (0, _) -> base + | Cconst_int (n, _) -> + let dbg = Debuginfo.none in + Cop(Cadda, [base; Cconst_int(n * size, dbg)], dbg) + | _ -> + let dbg = Debuginfo.none in + Cop(Cadda, [base; + Cop(Clsl, [numelt; Cconst_int(Misc.log2 size, dbg)], + dbg)], + dbg) %} @@ -195,10 +200,10 @@ componentlist: | componentlist STAR component { $3 :: $1 } ; expr: - INTCONST { Cconst_int $1 } - | FLOATCONST { Cconst_float (float_of_string $1) } - | STRING { Cconst_symbol $1 } - | POINTER { Cconst_pointer $1 } + INTCONST { Cconst_int ($1, debuginfo ()) } + | FLOATCONST { Cconst_float (float_of_string $1, debuginfo ()) } + | STRING { Cconst_symbol ($1, debuginfo ()) } + | POINTER { Cconst_pointer ($1, debuginfo ()) } | IDENT { Cvar(find_ident $1) } | LBRACKET RBRACKET { Ctuple [] } | LPAREN LET letdef sequence RPAREN { make_letdef $3 $4 } @@ -213,24 +218,29 @@ expr: | LPAREN unaryop expr RPAREN { Cop($2, [$3], debuginfo ()) } | LPAREN binaryop expr expr RPAREN { Cop($2, [$3; $4], debuginfo ()) } | LPAREN SEQ sequence RPAREN { $3 } - | LPAREN IF expr expr expr RPAREN { Cifthenelse($3, $4, $5) } + | LPAREN IF expr expr expr RPAREN + { Cifthenelse($3, debuginfo (), $4, debuginfo (), $5, debuginfo ()) } | LPAREN SWITCH INTCONST expr caselist RPAREN { make_switch $3 $4 $5 } | LPAREN WHILE expr sequence RPAREN { let body = match $3 with - Cconst_int x when x <> 0 -> $4 - | _ -> Cifthenelse($3, $4, (Cexit(0,[]))) in - Ccatch(Recursive, [0, [], Cloop body], Ctuple []) } + Cconst_int (x, _) when x <> 0 -> $4 + | _ -> Cifthenelse($3, debuginfo (), $4, debuginfo (), (Cexit(0,[])), + debuginfo ()) in + Ccatch(Nonrecursive, [0, [], + Ccatch(Recursive, + [1, [], Csequence(body, Cexit(1, [])), debuginfo ()], + Cexit(1, [])), debuginfo ()], Ctuple []) } | LPAREN EXIT IDENT exprlist RPAREN { Cexit(find_label $3, List.rev $4) } | LPAREN CATCH sequence WITH catch_handlers RPAREN { let handlers = $5 in - List.iter (fun (_, l, _) -> + List.iter (fun (_, l, _, _) -> List.iter (fun (x, _) -> unbind_ident x) l) handlers; Ccatch(Recursive, handlers, $3) } | EXIT { Cexit(0,[]) } | LPAREN TRY sequence WITH bind_ident sequence RPAREN - { unbind_ident $5; Ctrywith($3, $5, $6) } + { unbind_ident $5; Ctrywith($3, $5, $6, debuginfo ()) } | LPAREN VAL expr expr RPAREN { Cop(Cload (Word_val, Mutable), [access_array $3 $4 Arch.size_addr], debuginfo ()) } @@ -376,9 +386,9 @@ catch_handlers: catch_handler: | sequence - { 0, [], $1 } + { 0, [], $1, debuginfo () } | LPAREN IDENT params RPAREN sequence - { find_label $2, $3, $5 } + { find_label $2, $3, $5, debuginfo () } location: /**/ { None } diff --git a/tools/.depend b/tools/.depend index c96026b9..0a471a1b 100644 --- a/tools/.depend +++ b/tools/.depend @@ -54,7 +54,7 @@ cmt2annot.cmo : \ ../typing/ident.cmi \ ../typing/envaux.cmi \ ../typing/env.cmi \ - ../typing/cmt_format.cmi \ + ../file_formats/cmt_format.cmi \ ../parsing/asttypes.cmi \ ../typing/annot.cmi cmt2annot.cmx : \ @@ -71,7 +71,7 @@ cmt2annot.cmx : \ ../typing/ident.cmx \ ../typing/envaux.cmx \ ../typing/env.cmx \ - ../typing/cmt_format.cmx \ + ../file_formats/cmt_format.cmx \ ../parsing/asttypes.cmi \ ../typing/annot.cmi cvt_emit.cmo : @@ -79,13 +79,13 @@ cvt_emit.cmx : dumpobj.cmo : \ ../bytecomp/symtable.cmi \ opnames.cmo \ - ../bytecomp/opcodes.cmo \ + ../bytecomp/opcodes.cmi \ ../parsing/location.cmi \ - ../bytecomp/lambda.cmi \ + ../lambda/lambda.cmi \ ../bytecomp/instruct.cmi \ ../typing/ident.cmi \ ../utils/config.cmi \ - ../bytecomp/cmo_format.cmi \ + ../file_formats/cmo_format.cmi \ ../bytecomp/bytesections.cmi \ ../parsing/asttypes.cmi dumpobj.cmx : \ @@ -93,11 +93,11 @@ dumpobj.cmx : \ opnames.cmx \ ../bytecomp/opcodes.cmx \ ../parsing/location.cmx \ - ../bytecomp/lambda.cmx \ + ../lambda/lambda.cmx \ ../bytecomp/instruct.cmx \ ../typing/ident.cmx \ ../utils/config.cmx \ - ../bytecomp/cmo_format.cmi \ + ../file_formats/cmo_format.cmi \ ../bytecomp/bytesections.cmx \ ../parsing/asttypes.cmi eqparsetree.cmo : \ @@ -132,33 +132,35 @@ make_opcodes.cmo : make_opcodes.cmx : objinfo.cmo : \ ../bytecomp/symtable.cmi \ - ../middle_end/base_types/symbol.cmi \ - ../asmcomp/printclambda.cmi \ + ../middle_end/symbol.cmi \ + ../middle_end/printclambda.cmi \ ../utils/misc.cmi \ - ../middle_end/base_types/linkage_name.cmi \ + ../middle_end/linkage_name.cmi \ ../typing/ident.cmi \ - ../asmcomp/export_info.cmi \ + ../middle_end/flambda/export_info.cmi \ ../utils/config.cmi \ - ../middle_end/base_types/compilation_unit.cmi \ - ../asmcomp/cmx_format.cmi \ - ../typing/cmt_format.cmi \ - ../bytecomp/cmo_format.cmi \ - ../typing/cmi_format.cmi \ + ../middle_end/compilation_unit.cmi \ + ../file_formats/cmxs_format.cmi \ + ../file_formats/cmx_format.cmi \ + ../file_formats/cmt_format.cmi \ + ../file_formats/cmo_format.cmi \ + ../file_formats/cmi_format.cmi \ ../bytecomp/bytesections.cmi objinfo.cmx : \ ../bytecomp/symtable.cmx \ - ../middle_end/base_types/symbol.cmx \ - ../asmcomp/printclambda.cmx \ + ../middle_end/symbol.cmx \ + ../middle_end/printclambda.cmx \ ../utils/misc.cmx \ - ../middle_end/base_types/linkage_name.cmx \ + ../middle_end/linkage_name.cmx \ ../typing/ident.cmx \ - ../asmcomp/export_info.cmx \ + ../middle_end/flambda/export_info.cmx \ ../utils/config.cmx \ - ../middle_end/base_types/compilation_unit.cmx \ - ../asmcomp/cmx_format.cmi \ - ../typing/cmt_format.cmx \ - ../bytecomp/cmo_format.cmi \ - ../typing/cmi_format.cmx \ + ../middle_end/compilation_unit.cmx \ + ../file_formats/cmxs_format.cmi \ + ../file_formats/cmx_format.cmi \ + ../file_formats/cmt_format.cmx \ + ../file_formats/cmo_format.cmi \ + ../file_formats/cmi_format.cmx \ ../bytecomp/bytesections.cmx ocaml299to3.cmo : ocaml299to3.cmx : @@ -203,11 +205,11 @@ opnames.cmx : primreq.cmo : \ ../utils/misc.cmi \ ../utils/config.cmi \ - ../bytecomp/cmo_format.cmi + ../file_formats/cmo_format.cmi primreq.cmx : \ ../utils/misc.cmx \ ../utils/config.cmx \ - ../bytecomp/cmo_format.cmi + ../file_formats/cmo_format.cmi profiling.cmo : \ profiling.cmi profiling.cmx : \ @@ -216,13 +218,13 @@ profiling.cmi : read_cmt.cmo : \ ../parsing/location.cmi \ ../driver/compmisc.cmi \ - ../typing/cmt_format.cmi \ + ../file_formats/cmt_format.cmi \ cmt2annot.cmo \ ../utils/clflags.cmi read_cmt.cmx : \ ../parsing/location.cmx \ ../driver/compmisc.cmx \ - ../typing/cmt_format.cmx \ + ../file_formats/cmt_format.cmx \ cmt2annot.cmx \ ../utils/clflags.cmx scrapelabels.cmo : diff --git a/tools/Makefile b/tools/Makefile index ee0e0be4..afefc4d8 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -26,12 +26,11 @@ endef $(foreach i,BINDIR LIBDIR STUBLIBDIR MANDIR,$(eval $(shellquote))) endif -CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun DESTDIR ?= # Setup GNU make variables storing per-target source and target, # a list of installed tools, and a function to quote a filename for # the shell. -override installed_tools := ocamldep ocamlprof ocamlcp ocamloptp \ +override installed_tools := ocamldep ocamlprof ocamlcp \ ocamlmktop ocamlmklib ocamlobjinfo install_files := @@ -73,12 +72,14 @@ $(eval $(call \ byte_and_opt_,$(subst $$,$$$$,$1),$(subst $$,$$$$,$2),$(subst $$,$$$$,$3))) endef -CAMLC = $(CAMLRUN) $(ROOTDIR)/boot/ocamlc -g -nostdlib -I $(ROOTDIR)/boot \ +CAMLC = $(BOOT_OCAMLC) -g -nostdlib -I $(ROOTDIR)/boot \ -use-prims $(ROOTDIR)/runtime/primitives -I $(ROOTDIR) CAMLOPT = $(CAMLRUN) $(ROOTDIR)/ocamlopt -g -nostdlib -I $(ROOTDIR)/stdlib CAMLLEX = $(CAMLRUN) $(ROOTDIR)/boot/ocamllex -INCLUDES = $(addprefix -I $(ROOTDIR)/,utils parsing typing bytecomp asmcomp \ - middle_end middle_end/base_types driver toplevel) +INCLUDES = $(addprefix -I $(ROOTDIR)/,utils parsing typing bytecomp \ + middle_end middle_end/closure middle_end/flambda \ + middle_end/flambda/base_types driver toplevel \ + file_formats lambda) COMPFLAGS = -absname -w +a-4-9-41-42-44-45-48 -strict-sequence -warn-error A \ -safe-string -strict-formats -bin-annot $(INCLUDES) LINKFLAGS = $(INCLUDES) @@ -125,7 +126,6 @@ ocamlcp_cmos = config.cmo build_path_prefix_map.cmo misc.cmo profile.cmo \ clflags.cmo main_args.cmo $(call byte_and_opt,ocamlcp,$(ocamlcp_cmos) ocamlcp.cmo,) -$(call byte_and_opt,ocamloptp,$(ocamlcp_cmos) ocamloptp.cmo,) opt:: profiling.cmx @@ -328,9 +328,6 @@ objinfo_helper$(EXE): objinfo_helper.c $(ROOTDIR)/runtime/caml/s.h OBJINFO=$(ROOTDIR)/compilerlibs/ocamlcommon.cma \ $(ROOTDIR)/compilerlibs/ocamlbytecomp.cma \ $(ROOTDIR)/compilerlibs/ocamlmiddleend.cma \ - $(ROOTDIR)/asmcomp/backend_var.cmo \ - $(ROOTDIR)/asmcomp/printclambda.cmo \ - $(ROOTDIR)/asmcomp/export_info.cmo \ objinfo.cmo $(call byte_and_opt,ocamlobjinfo,$(OBJINFO),objinfo_helper$(EXE)) @@ -349,9 +346,6 @@ $(call byte_and_opt,primreq,$(primreq),) LINTAPIDIFF=$(ROOTDIR)/compilerlibs/ocamlcommon.cmxa \ $(ROOTDIR)/compilerlibs/ocamlbytecomp.cmxa \ $(ROOTDIR)/compilerlibs/ocamlmiddleend.cmxa \ - $(ROOTDIR)/asmcomp/backend_var.cmx \ - $(ROOTDIR)/asmcomp/printclambda.cmx \ - $(ROOTDIR)/asmcomp/export_info.cmx \ $(ROOTDIR)/otherlibs/str/str.cmxa \ lintapidiff.cmx @@ -428,7 +422,7 @@ clean:: clean:: rm -f *.cmo *.cmi *.cma *.dll *.so *.lib *.a -CAMLDEP=$(CAMLRUN) $(ROOTDIR)/boot/ocamlc -depend +CAMLDEP=$(BOOT_OCAMLC) -depend DEPFLAGS=-slash DEPINCLUDES=$(INCLUDES) depend: beforedepend diff --git a/tools/caml_tex.ml b/tools/caml_tex.ml index 108a0f66..d003171d 100644 --- a/tools/caml_tex.ml +++ b/tools/caml_tex.ml @@ -132,10 +132,23 @@ module Toplevel = struct if startchar >= 0 then locs := (startchar, endchar) :: !locs - (** Record the main location instead of printing it *) + (** Record locations in the main error and suberrors without printing them *) let printer_register_locs = - { Location.batch_mode_printer with - pp_main_loc = (fun _ _ _ loc -> register_loc loc) } + let base = Location.batch_mode_printer in + { Location.pp_main_loc = (fun _ _ _ loc -> register_loc loc); + pp_submsg_loc = (fun _ _ _ loc -> register_loc loc); + + (* The following fields are kept identical to [base], + listed explicitly so that future field additions result in an error + -- using (Location.batch_mode_printer with ...) would be the symmetric + problem to a fragile pattern-matching. *) + pp = base.pp; + pp_report_kind = base.pp_report_kind; + pp_main_txt = base.pp_main_txt; + pp_submsgs = base.pp_submsgs; + pp_submsg = base.pp_submsg; + pp_submsg_txt = base.pp_submsg_txt; + } (** Capture warnings and keep them in a list *) let warnings = ref [] @@ -162,7 +175,7 @@ module Toplevel = struct Clflags.color := Some Misc.Color.Never; Clflags.no_std_include := true; Compenv.last_include_dirs := [Filename.concat !repo_root "stdlib"]; - Compmisc.init_path false; + Compmisc.init_path (); try Toploop.initialize_toplevel_env (); Sys.interactive := false diff --git a/tools/check-typo b/tools/check-typo index caeb4bc2..6da3c3e6 100755 --- a/tools/check-typo +++ b/tools/check-typo @@ -130,6 +130,25 @@ usage () { exit 2 } +check_script () { + if [ "$($OCAML_CT_CAT "$OCAML_CT_PREFIX$1" \ + | sed -ne '1s/^#!.*/#!/p')" != '#!' ] ; then + # These files are listed manually, rather than via gitattributes, + # because the list should never expand, and it should not be trivial to + # expand (the unix-execvpe test is an ultra-special-case!) + f=${1#./} + if [ "$f" != "boot/ocamlc" ] && [ "$f" != "boot/ocamllex" ] && \ + [ "$f" != "testsuite/tests/lib-unix/unix-execvpe/subdir/script2" ] ; then + echo "$1 shouldn't be executable; either:" + echo " - Add a #! line" + echo " - Run chmod -x $1 (on Unix)" + echo " - Run git update-index --chmod=-x $1 (on Windows)" + echo "You may wish to check your core.fileMode setting" + EXIT_CODE=1 + fi + fi +} + userrules='' while : ; do @@ -151,6 +170,18 @@ IGNORE_DIRS=" # is faster to optimistically run check-typo on them (and maybe get # out in the middle) than to first check then run. +TEST_AWK='BEGIN {if ("a{1}" ~ /a{1}/) exit 0}' +if $OCAML_CT_AWK "$TEST_AWK" ; then + TEST_AWK='BEGIN {if ("a" ~ /a{1}/) exit 0}' + if $OCAML_CT_AWK --re-interval "$TEST_AWK" 2>/dev/null ; then + OCAML_CT_AWK="$OCAML_CT_AWK --re-interval" + else + echo "This script requires interval support in regexes ({m} notation)">&2 + echo "Please install a version of awk (e.g. gawk) which supports this">&2 + exit 2 + fi +fi + EXIT_CODE=0 ( case $# in 0) find . $IGNORE_DIRS -type f -print;; @@ -159,6 +190,7 @@ EXIT_CODE=0 ) | ( while read f; do if test -n "$(check_prune "$f")"; then continue; fi + if $(git check-ignore -q "$f"); then continue; fi case `$OCAML_CT_LS_FILES "$f" 2>&1` in "") path_in_index=false;; *) path_in_index=true;; @@ -167,6 +199,15 @@ EXIT_CODE=0 *$f*) is_cmd_line=true;; *) is_cmd_line=false;; esac + if [ -z "$OCAML_CT_PREFIX" ] ; then + if [ -x "$f" ] ; then + check_script "$f" + fi + else + if git ls-files -s "$f" | grep -q "^100755" ; then + check_script "$f" + fi + fi if $path_in_index || $is_cmd_line; then :; else continue; fi attr_rules='' if $path_in_index; then diff --git a/tools/ci/inria/bootstrap b/tools/ci/inria/bootstrap index a77c1ed1..a33b6b3a 100755 --- a/tools/ci/inria/bootstrap +++ b/tools/ci/inria/bootstrap @@ -18,7 +18,7 @@ # it is possible to bootstrap the compiler. # To know the slave's architecture, this script looks at the OCAML_ARCH -# environment variable. For a given node NODe, this variable can be defined +# environment variable. For a given node NODE, this variable can be defined # in Jenkins at the following address: # https://ci.inria.fr/ocaml/computer/NODE/configure diff --git a/tools/ci/inria/remove-sinh-primitive.patch b/tools/ci/inria/remove-sinh-primitive.patch index c6a21157..db9dfe83 100644 --- a/tools/ci/inria/remove-sinh-primitive.patch +++ b/tools/ci/inria/remove-sinh-primitive.patch @@ -3,19 +3,6 @@ and standard library. It is used on Inria's CI to make sure the bootstrap procedure works. -diff --git a/otherlibs/threads/stdlib.ml b/otherlibs/threads/stdlib.ml -index 27cb01e54..eea32ee94 100644 ---- a/otherlibs/threads/stdlib.ml -+++ b/otherlibs/threads/stdlib.ml -@@ -152,8 +152,6 @@ external log10 : float -> float = "caml_log10_float" "log10" - external log1p : float -> float = "caml_log1p_float" "caml_log1p" - [@@unboxed] [@@noalloc] - external sin : float -> float = "caml_sin_float" "sin" [@@unboxed] [@@noalloc] --external sinh : float -> float = "caml_sinh_float" "sinh" -- [@@unboxed] [@@noalloc] - external sqrt : float -> float = "caml_sqrt_float" "sqrt" - [@@unboxed] [@@noalloc] - external tan : float -> float = "caml_tan_float" "tan" [@@unboxed] [@@noalloc] diff --git a/runtime/floats.c b/runtime/floats.c index b93f6a409..6edbed9c6 100644 --- a/runtime/floats.c diff --git a/tools/ci/travis/travis-ci.sh b/tools/ci/travis/travis-ci.sh index da7259c2..d0d9098f 100755 --- a/tools/ci/travis/travis-ci.sh +++ b/tools/ci/travis/travis-ci.sh @@ -223,8 +223,25 @@ CheckTypoTree () { else echo "NOT checking $1: $path (typo.prune)" fi + case "$path" in + configure|configure.ac|VERSION|tools/ci/travis/travis-ci.sh) + touch CHECK_CONFIGURE;; + esac done) rm -f tmp-index + if [ -e CHECK_CONFIGURE ] ; then + rm -f CHECK_CONFIGURE + echo "configure generation altered in $1" + echo "Verifying that configure.ac generates configure" + git checkout "$1" + mv configure configure.ref + ./autogen + if ! diff -q configure configure.ref >/dev/null ; then + echo "configure.ac no longer generates configure, \ +please run ./autogen and commit" + exit 1 + fi + fi } CHECK_ALL_COMMITS=0 @@ -234,7 +251,6 @@ CheckTypo () { export OCAML_CT_CA_FLAG="--cached" # Work around an apparent bug in Ubuntu 12.4.5 # See https://bugs.launchpad.net/ubuntu/+source/gawk/+bug/1647879 - export OCAML_CT_AWK="awk --re-interval" rm -f check-typo-failed if test -z "$TRAVIS_COMMIT_RANGE" then CheckTypoTree $TRAVIS_COMMIT $TRAVIS_COMMIT diff --git a/tools/mantis2gh_stripped.csv b/tools/mantis2gh_stripped.csv new file mode 100644 index 00000000..f075e829 --- /dev/null +++ b/tools/mantis2gh_stripped.csv @@ -0,0 +1,1512 @@ +3,2325 +4,2327 +5,2329 +6,2330 +7,2332 +8,2333 +9,2337 +10,2338 +11,2339 +12,2340 +13,2341 +14,2342 +15,2343 +16,2345 +17,2346 +18,2348 +19,2350 +20,2351 +21,2354 +22,2355 +23,2356 +24,2358 +25,2359 +26,2360 +28,2361 +29,2362 +32,2363 +33,2364 +34,2365 +35,2366 +36,2367 +37,2369 +38,2371 +39,2373 +40,2374 +41,2376 +42,2377 +43,2378 +44,2380 +45,2381 +46,2382 +47,2383 +48,2385 +49,2386 +50,2387 +51,2388 +52,2389 +53,2390 +54,2391 +55,2392 +56,2393 +57,2394 +58,2396 +59,2397 +60,2399 +61,2400 +62,2401 +63,2402 +64,2404 +65,2405 +66,2406 +67,2407 +68,2408 +70,2409 +73,2410 +75,2411 +76,2412 +77,2414 +78,2416 +79,2417 +80,2418 +83,2419 +84,2420 +85,2421 +86,2423 +87,2424 +88,2425 +89,2426 +90,2427 +91,2428 +92,2429 +93,2431 +94,2432 +95,2433 +96,2434 +97,2435 +98,2436 +99,2437 +100,2438 +101,2439 +102,2440 +103,2441 +104,2442 +105,2443 +106,2444 +107,2445 +108,2447 +109,2448 +110,2451 +111,2452 +112,2453 +113,2454 +114,2456 +115,2457 +116,2459 +117,2460 +118,2461 +119,2462 +122,2463 +123,2464 +124,2465 +125,2466 +126,2467 +127,2468 +128,2469 +129,2471 +130,2472 +131,2474 +132,2477 +133,2478 +135,2479 +136,2481 +137,2483 +138,2484 +139,2489 +140,2492 +141,2493 +142,2495 +143,2499 +144,2502 +145,2504 +146,2506 +147,2507 +148,2508 +149,2509 +150,2510 +151,2511 +152,2513 +153,2516 +154,2517 +155,2519 +156,2520 +157,2521 +158,2523 +159,2524 +160,2527 +161,2528 +162,2530 +163,2531 +164,2532 +165,2534 +166,2535 +167,2536 +168,2537 +169,2538 +170,2539 +172,2540 +173,2541 +174,2542 +175,2543 +176,2545 +177,2546 +178,2548 +179,2551 +181,2554 +182,2556 +184,2559 +185,2563 +186,2565 +187,2566 +188,2567 +189,2568 +190,2569 +191,2570 +192,2571 +193,2574 +195,2576 +196,2577 +197,2579 +198,2580 +199,2581 +200,2582 +201,2583 +202,2584 +203,2587 +204,2588 +205,2590 +206,2591 +207,2592 +208,2593 +209,2594 +210,2596 +211,2597 +212,2598 +213,2599 +214,2600 +215,2603 +216,2604 +217,2605 +218,2606 +219,2607 +220,2608 +221,2609 +222,2613 +223,2615 +224,2616 +225,2617 +226,2619 +227,2620 +230,2621 +231,2622 +232,2623 +233,2624 +235,2625 +236,2626 +237,2627 +238,2628 +239,2630 +240,2631 +241,2632 +242,2633 +243,2635 +244,2636 +245,2638 +246,2640 +247,2641 +248,2642 +250,2643 +251,2645 +253,2646 +254,2647 +255,2648 +256,2650 +257,2651 +258,2653 +259,2656 +260,2657 +261,2658 +262,2659 +263,2664 +264,2665 +265,2666 +266,2668 +267,2669 +268,2670 +269,2671 +270,2672 +272,2673 +273,2674 +275,2675 +276,2676 +277,2677 +278,2678 +279,2679 +280,2680 +282,2681 +283,2682 +284,2683 +286,2684 +287,2685 +288,2686 +289,2687 +290,2688 +292,2689 +293,2690 +294,2691 +295,2692 +296,2693 +297,2694 +298,2695 +299,2696 +300,2697 +301,2698 +302,2699 +303,2700 +304,2701 +305,2702 +306,2703 +307,2704 +308,2705 +309,2706 +310,2707 +311,2708 +312,2709 +313,2710 +314,2711 +315,2712 +316,2713 +317,2716 +319,2721 +320,2724 +321,2726 +322,2728 +323,2729 +324,2730 +325,2731 +326,2733 +327,2734 +328,2735 +330,2736 +331,2738 +332,2740 +333,2741 +334,2742 +335,2743 +336,2744 +337,2745 +338,2746 +339,2747 +340,2748 +341,2749 +342,2750 +344,2751 +345,2752 +346,2753 +348,2754 +349,2755 +350,2756 +352,2757 +353,2758 +354,2759 +355,2760 +356,2761 +357,2762 +358,2763 +359,2764 +360,2765 +363,2766 +364,2767 +369,2768 +370,2769 +371,2770 +372,2771 +373,2772 +374,2773 +375,2774 +376,2775 +377,2776 +378,2777 +379,2778 +380,2779 +381,2780 +382,2781 +383,2782 +384,2783 +385,2784 +386,2789 +387,2790 +388,2791 +390,2793 +391,2794 +393,2795 +394,2796 +395,2797 +396,2803 +397,2805 +402,2806 +403,2807 +404,2808 +405,2809 +406,2810 +407,2811 +408,2812 +409,2813 +410,2814 +411,2815 +412,2816 +413,2817 +414,2818 +415,2819 +416,2820 +417,2821 +419,2822 +420,2823 +421,2824 +422,2825 +423,2826 +424,2827 +425,2828 +426,2829 +427,2830 +428,2831 +429,2832 +431,2833 +432,2834 +433,2835 +434,2836 +436,2837 +437,2838 +438,2839 +439,2840 +440,2841 +443,2842 +444,2843 +445,2844 +446,2845 +447,2846 +448,2847 +449,2850 +450,2851 +451,2852 +452,2853 +453,2856 +454,2862 +455,2863 +456,2864 +457,2867 +458,2869 +459,2870 +460,2871 +461,2872 +462,2874 +463,2875 +464,2876 +465,2877 +466,2878 +467,2884 +468,2885 +470,2887 +471,2888 +472,2892 +473,2894 +476,2895 +477,2897 +478,2898 +479,2899 +480,2900 +484,2901 +485,2902 +486,2905 +487,2907 +488,2908 +489,2913 +490,2914 +491,2917 +492,2924 +493,2925 +494,2926 +495,2929 +496,2930 +497,2933 +499,2934 +502,2936 +503,2938 +504,2940 +505,2941 +506,2943 +508,2945 +509,2948 +511,2951 +512,2956 +515,2957 +517,2958 +525,2959 +529,2960 +531,2961 +533,2962 +534,2963 +535,2965 +536,2966 +539,2967 +543,2968 +544,2970 +545,2972 +546,2973 +547,2974 +548,2975 +554,2976 +555,2977 +556,2978 +557,2979 +558,2983 +560,2984 +562,2985 +564,2986 +568,2987 +570,2988 +572,2989 +573,2990 +576,2991 +577,2992 +578,2993 +581,2995 +583,2996 +584,2997 +587,2998 +590,3000 +594,3001 +596,3003 +601,3004 +604,3005 +605,3006 +606,3007 +607,3008 +609,3009 +610,3014 +611,3016 +612,3017 +613,3018 +614,3020 +615,3022 +625,3024 +626,3025 +627,3026 +629,3027 +630,3029 +631,3030 +632,3031 +633,3032 +635,3035 +636,3037 +637,3038 +638,3039 +640,3041 +641,3042 +643,3043 +644,3044 +647,3045 +648,3049 +649,3050 +651,3051 +652,3053 +654,3054 +661,3055 +663,3058 +672,3059 +673,3060 +674,3061 +675,3062 +680,3063 +681,3064 +685,3065 +686,3066 +689,3067 +691,3068 +696,3070 +697,3071 +706,3073 +712,3076 +713,3078 +716,3081 +717,3082 +718,3083 +722,3084 +723,3086 +725,3087 +727,3090 +728,3091 +729,3092 +731,3093 +732,3094 +734,3095 +736,3096 +738,3097 +739,3098 +743,3099 +744,3101 +749,3102 +750,3103 +752,3105 +754,3106 +755,3107 +762,3109 +763,3110 +765,3111 +766,3112 +769,3116 +770,3117 +771,3118 +772,3119 +774,3120 +775,3122 +776,3125 +778,3126 +780,3127 +781,3128 +782,3129 +783,3130 +784,3131 +785,3132 +786,3133 +787,3134 +789,3135 +790,3136 +791,3137 +793,3138 +794,3139 +796,3144 +797,3145 +801,3146 +802,3147 +804,3148 +807,3149 +809,3151 +811,3152 +812,3153 +813,3155 +814,3156 +816,3158 +817,3159 +818,3160 +819,3163 +820,3164 +825,3165 +826,3167 +828,3168 +829,3169 +834,3170 +836,3171 +837,3172 +839,3174 +840,3175 +841,3176 +848,3180 +849,3181 +851,3183 +856,3184 +857,3185 +864,3186 +869,3187 +872,3189 +873,3192 +875,3193 +881,3197 +883,3199 +884,3200 +886,3201 +887,3202 +888,3203 +889,3204 +892,3205 +896,3207 +897,3208 +898,3210 +900,3211 +905,3212 +907,3215 +908,3216 +911,3217 +923,3218 +924,3219 +925,3220 +928,3221 +930,3223 +931,3225 +934,3226 +937,3227 +938,3228 +943,3229 +947,3230 +952,3233 +956,3234 +957,3235 +959,3237 +961,3240 +963,3241 +972,3245 +973,3246 +974,3250 +975,3251 +986,3253 +991,3255 +1001,3256 +1008,3257 +1013,3260 +1014,3261 +1015,3262 +1016,3264 +1017,3266 +1018,3268 +1019,3269 +1020,3271 +1023,3272 +1024,3275 +1025,3277 +1031,3278 +1035,3279 +1036,3282 +1037,3283 +1038,3284 +1039,3285 +1049,3287 +1055,3288 +1064,3289 +1065,3290 +1068,3291 +1069,3292 +1073,3293 +1085,3296 +1087,3297 +1097,3298 +1110,3301 +1111,3305 +1116,3306 +1117,3307 +1118,3308 +1120,3309 +1121,3313 +1122,3314 +1124,3315 +1125,3316 +1126,3317 +1127,3318 +1130,3319 +1131,3321 +1132,3323 +1133,3325 +1134,3326 +1135,3327 +1137,3332 +1139,3335 +1141,3336 +1142,3337 +1143,3338 +1144,3339 +1145,3340 +1147,3344 +1148,3347 +1149,3348 +1151,3350 +1153,3351 +1154,3352 +1156,3353 +1157,3354 +1158,3355 +1159,3356 +1160,3357 +1164,3358 +1165,3359 +1166,3360 +1167,3361 +1170,3362 +1172,3363 +1174,3364 +1176,3365 +1177,3366 +1178,3367 +1179,3368 +1180,3372 +1181,3373 +1183,3374 +1184,3375 +1185,3376 +1186,3377 +1187,3379 +1188,3380 +1189,3381 +1190,3383 +1191,3384 +1192,3385 +1193,3386 +1194,3387 +1196,3388 +1198,3390 +1199,3391 +1200,3393 +1202,3397 +1204,3398 +1205,3399 +1208,3402 +1213,3403 +1214,3405 +1216,3408 +1217,3410 +1222,3411 +1224,3413 +1225,3415 +1226,3417 +1227,3418 +1228,3419 +1229,3420 +1231,3421 +1234,3425 +1235,3426 +1236,3427 +1237,3434 +1241,3435 +1242,3436 +1244,3438 +1245,3440 +1248,3441 +1249,3442 +1250,3443 +1252,3445 +1253,3448 +1254,3449 +1255,3452 +1259,3453 +1260,3459 +1262,3460 +1263,3461 +1264,3466 +1269,3467 +1270,3470 +1272,3471 +1273,3472 +1274,3477 +1275,3478 +1276,3480 +1277,3481 +1278,3482 +1279,3484 +1280,3486 +1281,3487 +1282,3489 +1283,3491 +1284,3492 +1285,3493 +1287,3494 +1288,3496 +1289,3497 +1292,3498 +1293,3499 +1296,3500 +1297,3501 +1298,3502 +1299,3503 +1301,3505 +1303,3507 +1305,3513 +1306,3514 +1307,3515 +1309,3516 +1310,3517 +1311,3518 +1313,3519 +1314,3521 +1316,3522 +1317,3523 +1320,3524 +1321,3525 +1322,3527 +1323,3528 +1324,3529 +1325,3532 +1326,3533 +1333,3534 +1335,3535 +1336,3537 +1337,3538 +1341,3543 +1342,3547 +1343,3550 +1344,3551 +1346,3554 +1347,3557 +1349,3581 +1350,3583 +1351,3585 +1354,3588 +1355,3594 +1356,3596 +1357,3597 +1358,3598 +1359,3605 +1360,3611 +1361,3613 +1362,3614 +1363,3617 +1364,3618 +1365,3627 +1366,3629 +1367,3630 +1368,3631 +1369,3632 +1370,3633 +1371,3634 +1372,3639 +1373,3641 +1374,3643 +1375,3644 +1376,3645 +1377,3646 +1378,3648 +1379,3649 +1380,3650 +1381,3652 +1382,3653 +1383,3655 +1384,3656 +1386,3657 +1388,3661 +1389,3690 +1390,3696 +1391,3697 +1392,3706 +1393,3710 +1394,3711 +1395,3713 +1396,3717 +1397,3724 +1398,3734 +1399,3753 +1400,3754 +1401,3762 +1402,3779 +1403,3781 +1404,3782 +1405,3796 +1407,3808 +1408,3813 +1409,3814 +1410,3815 +1411,3834 +1412,3837 +1413,3840 +1414,3841 +1415,3843 +1416,3845 +1417,3846 +1418,3852 +1420,3854 +1421,3859 +1422,3865 +1423,3867 +1424,3872 +1425,3970 +1426,4291 +1427,4293 +1428,4294 +1431,5431 +1432,5909 +1433,5968 +1434,5969 +1435,5970 +1436,6247 +1437,6248 +1438,6249 +1439,6250 +1440,6251 +1441,6252 +1443,6255 +1444,6487 +1445,6783 +1446,7734 +1448,7736 +1449,7749 +1450,7761 +1451,7762 +1453,7763 +1454,7775 +1456,7801 +1457,7805 +1458,7806 +1459,7840 +1460,7848 +1461,7855 +1462,7871 +1463,7872 +1464,7934 +1465,7941 +1466,7942 +1467,7943 +1468,7944 +1469,7945 +1470,7946 +1471,7947 +1472,7948 +1473,7949 +1474,7950 +1475,7951 +1476,7952 +1477,7953 +1478,7954 +1479,7955 +1480,7956 +1481,7957 +1482,7958 +1484,7959 +1485,7960 +1486,7961 +1487,7962 +1488,7963 +1489,7964 +1490,7965 +1491,7966 +1492,7967 +1493,7968 +1494,7969 +1495,7970 +1496,7971 +1497,7972 +1498,7973 +1499,7974 +1500,7975 +1501,7976 +1502,7977 +1505,7978 +1506,7979 +1507,7980 +1508,7981 +1509,7982 +1510,7983 +1511,7984 +1512,7985 +1513,7986 +1514,7987 +1515,7988 +1516,7989 +1517,7990 +1518,7991 +1519,7992 +1520,7993 +1521,7994 +1522,7995 +1523,7996 +1524,7997 +1525,7998 +1526,7999 +1527,8000 +1528,8001 +1530,8002 +1531,8003 +1532,8004 +1533,8005 +1534,8006 +1535,8007 +1536,8008 +1537,8009 +1538,8010 +1539,8011 +1540,8012 +1541,8013 +1542,8014 +1543,8015 +1544,8016 +1545,8017 +1546,8018 +1547,8019 +1548,8020 +1549,8021 +1550,8022 +1551,8023 +1552,8024 +1553,8025 +1554,8026 +1555,8027 +1557,8028 +1558,8029 +1559,8030 +1560,8031 +1561,8032 +1562,8033 +1563,8034 +1564,8035 +1565,8036 +1566,8037 +1567,8038 +1568,8039 +1569,8040 +1570,8041 +1571,8042 +1572,8043 +1573,8044 +1574,8045 +1575,8046 +1576,8047 +1577,8048 +1578,8049 +1579,8050 +1580,8051 +1581,8052 +1582,8053 +1583,8054 +1584,8055 +1586,8056 +1587,8057 +1588,8058 +1590,8059 +1591,8060 +1592,8061 +1593,8062 +1594,8063 +1595,8064 +1596,8065 +1597,8066 +1598,8067 +1599,8068 +1600,8069 +1601,8070 +1602,8071 +1605,8072 +1606,8073 +1607,8074 +1608,8075 +1609,8076 +1610,8077 +1611,8078 +1613,8079 +1614,8080 +1615,8081 +1616,8082 +1617,8083 +1618,8084 +1619,8085 +1620,8086 +1621,8087 +1622,8088 +1623,8089 +1624,8090 +1625,8091 +1626,8092 +1627,8093 +1628,8094 +1629,8095 +1630,8096 +1631,8097 +1632,8098 +1633,8099 +1634,8100 +1635,8101 +1636,8102 +1637,8103 +1638,8104 +1639,8105 +1640,8106 +1641,8107 +1642,8108 +1643,8109 +1644,8110 +1645,8111 +1646,8112 +1647,8113 +1648,8114 +1649,8115 +1650,8116 +1651,8117 +1652,8118 +1654,8119 +1656,8120 +1657,8121 +1660,8122 +1662,8123 +1663,8124 +1664,8125 +1665,8126 +1666,8127 +1667,8128 +1668,8129 +1669,8130 +1670,8131 +1671,8132 +1672,8133 +1673,8134 +1674,8135 +1675,8136 +1676,8137 +1677,8138 +1678,8139 +1679,8140 +1680,8141 +1681,8142 +1682,8143 +1683,8144 +1686,8145 +1687,8146 +1688,8147 +1689,8148 +1690,8149 +1691,8150 +1692,8151 +1693,8152 +1694,8153 +1695,8154 +1696,8155 +1697,8156 +1698,8157 +1699,8158 +1700,8159 +1701,8160 +1702,8161 +1703,8162 +1704,8163 +1705,8164 +1706,8165 +1707,8166 +1708,8167 +1709,8168 +1710,8169 +1711,8170 +1712,8171 +1713,8172 +1714,8173 +1715,8174 +1716,8175 +1717,8176 +1720,8177 +1721,8178 +1722,8179 +1723,8180 +1724,8181 +1725,8182 +1726,8183 +1727,8184 +1728,8185 +1729,8186 +1730,8187 +1731,8188 +1732,8189 +1733,8190 +1734,8191 +1735,8192 +1736,8193 +1739,8194 +1741,8195 +1742,8196 +1743,8197 +1744,8198 +1745,8199 +1746,8200 +1747,8201 +1750,8202 +1751,8203 +1752,8204 +1753,8205 +1754,8206 +1755,8207 +1756,8208 +1757,8209 +1758,8210 +1759,8211 +1760,8212 +1761,8213 +1762,8214 +1763,8215 +1764,8216 +1765,8217 +1766,8218 +1767,8219 +1768,8220 +1769,8221 +1770,8222 +1771,8223 +1772,8224 +1773,8225 +1774,8226 +1775,8227 +1776,8228 +1777,8229 +1778,8230 +1779,8231 +1780,8232 +1781,8233 +1782,8234 +1783,8235 +1784,8236 +1785,8237 +1786,8238 +1787,8239 +1788,8240 +1789,8241 +1790,8242 +1791,8243 +1792,8244 +1793,8245 +1794,8246 +1795,8247 +1796,8248 +1798,8249 +1799,8250 +1800,8251 +1801,8252 +1802,8253 +1803,8254 +1804,8255 +1805,8256 +1806,8257 +1807,8258 +1808,8259 +1809,8260 +1810,8261 +1811,8262 +1813,8263 +1814,8264 +1815,8265 +1816,8266 +1817,8267 +1818,8268 +1819,8269 +1820,8270 +1821,8271 +1822,8272 +1823,8273 +1824,8274 +1825,8275 +1826,8276 +1827,8277 +1828,8278 +1829,8279 +1830,8280 +1831,8281 +1832,8282 +1833,8283 +1834,8284 +1835,8285 +1836,8286 +1837,8287 +1839,8288 +1840,8289 +1841,8290 +1842,8291 +1843,8292 +1844,8293 +1845,8294 +1846,8295 +1847,8296 +1848,8297 +1849,8298 +1850,8299 +1851,8300 +1852,8301 +1853,8302 +1856,8303 +1857,8304 +1858,8305 +1859,8306 +1860,8307 +1861,8308 +1862,8309 +1863,8310 +1864,8311 +1865,8312 +1866,8313 +1867,8314 +1868,8315 +1869,8316 +1870,8317 +1871,8318 +1872,8319 +1873,8320 +1876,8321 +1877,8322 +1878,8323 +1880,8324 +1881,8325 +1882,8326 +1883,8327 +1884,8328 +1885,8329 +1886,8330 +1887,8331 +1888,8332 +1890,8333 +1891,8334 +1892,8335 +1893,8336 +1894,8337 +1895,8338 +1896,8339 +1897,8340 +1898,8341 +1899,8342 +1900,8343 +1901,8344 +1902,8345 +1903,8346 +1904,8347 +1905,8348 +1906,8349 +1907,8350 +1908,8351 +1909,8352 +1910,8353 +1911,8354 +1913,8355 +1914,8356 +1915,8357 +1916,8358 +1917,8359 +1918,8360 +1919,8361 +1921,8362 +1922,8363 +1923,8364 +1924,8365 +1925,8366 +1926,8367 +1927,8368 +1928,8369 +1929,8370 +1930,8371 +1931,8372 +1932,8373 +1933,8374 +1934,8375 +1935,8376 +1936,8377 +1937,8378 +1938,8379 +1939,8380 +1940,8381 +1941,8382 +1942,8383 +1943,8384 +1944,8385 +1945,8386 +1946,8387 +1947,8388 +1948,8389 +1949,8390 +1952,8391 +1953,8392 +1954,8393 +1955,8394 +1956,8395 +1957,8396 +1959,8397 +1960,8398 +1961,8399 +1963,8400 +1964,8401 +1965,8402 +1967,8403 +1968,8404 +1969,8405 +1970,8406 +1971,8407 +1972,8408 +1973,8409 +1974,8410 +1975,8411 +1976,8412 +1977,8413 +1978,8414 +1979,8415 +1981,8416 +1982,8417 +1983,8418 +1984,8419 +1986,8420 +1987,8421 +1988,8422 +1989,8423 +1990,8424 +1991,8425 +1994,8426 +1996,8427 +1997,8428 +2008,8429 +2016,8430 +2017,8431 +2018,8432 +2019,8433 +2020,8434 +2021,8435 +2022,8436 +2024,8437 +2025,8438 +2026,8439 +2027,8440 +2029,8441 +2030,8442 +2031,8443 +2032,8444 +2035,8445 +2036,8446 +2045,8447 +2046,8448 +2047,8449 +2048,8450 +2049,8451 +2050,8452 +2051,8453 +2052,8454 +2053,8455 +2056,8456 +2058,8457 +2059,8458 +2060,8459 +2061,8460 +2074,8461 +2104,8462 +2106,8463 +2107,8464 +2117,8465 +2121,8466 +2122,8467 +2123,8468 +2124,8469 +2149,8470 +2154,8471 +2160,8472 +2166,8473 +2167,8474 +2170,8475 +2172,8476 +2173,8477 +2181,8478 +2187,8479 +2188,8480 +2198,8481 +2226,8482 +2230,8483 +2235,8484 +2262,8485 +2267,8486 +2269,8487 +2270,8488 +2271,8489 +2272,8490 +2273,8491 +2275,8492 +2278,8493 +2279,8494 +2285,8495 +2297,8496 +2301,8497 +2306,8498 +2309,8499 +2310,8500 +2311,8501 +2321,8502 diff --git a/tools/objinfo.ml b/tools/objinfo.ml index adb54538..40826f48 100644 --- a/tools/objinfo.ml +++ b/tools/objinfo.ml @@ -132,6 +132,7 @@ let print_global_table table = table open Cmx_format +open Cmxs_format let print_cmx_infos (ui, crc) = print_general_infos diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml index 3c2edfcc..c72a2127 100644 --- a/tools/ocamlcp.ml +++ b/tools/ocamlcp.ml @@ -15,18 +15,6 @@ open Printf -let compargs = ref ([] : string list) -let profargs = ref ([] : string list) -let toremove = ref ([] : string list) - -let option opt () = compargs := opt :: !compargs -let option_with_arg opt arg = - compargs := (Filename.quote arg) :: opt :: !compargs -;; -let option_with_int opt arg = - compargs := (Int.to_string arg) :: opt :: !compargs -;; - let make_archive = ref false;; let with_impl = ref false;; let with_intf = ref false;; @@ -36,7 +24,6 @@ let with_ml = ref false;; let process_file filename = if Filename.check_suffix filename ".ml" then with_ml := true; if Filename.check_suffix filename ".mli" then with_mli := true; - compargs := (Filename.quote filename) :: !compargs ;; let usage = "Usage: ocamlcp \noptions are:" @@ -46,106 +33,116 @@ let incompatible o = exit 2 module Options = Main_args.Make_bytecomp_options (struct - let _a () = make_archive := true; option "-a" () - let _absname = option "-absname" - let _alert = option_with_arg "-alert" - let _annot = option "-annot" - let _binannot = option "-bin-annot" - let _c = option "-c" - let _cc s = option_with_arg "-cc" s - let _cclib s = option_with_arg "-cclib" s - let _ccopt s = option_with_arg "-ccopt" s - let _config = option "-config" - let _config_var s = option_with_arg "-config-var" s - let _compat_32 = option "-compat-32" - let _custom = option "-custom" - let _dllib = option_with_arg "-dllib" - let _dllpath = option_with_arg "-dllpath" - let _dtypes = option "-dtypes" - let _for_pack = option_with_arg "-for-pack" - let _g = option "-g" - let _stop_after = option_with_arg "-stop-after" - let _i = option "-i" - let _I s = option_with_arg "-I" s - let _impl s = with_impl := true; option_with_arg "-impl" s - let _intf s = with_intf := true; option_with_arg "-intf" s - let _intf_suffix s = option_with_arg "-intf-suffix" s - let _keep_docs = option "-keep-docs" - let _no_keep_docs = option "-no-keep-docs" - let _keep_locs = option "-keep-locs" - let _no_keep_locs = option "-no-keep-locs" - let _labels = option "-labels" - let _linkall = option "-linkall" - let _make_runtime = option "-make-runtime" - let _alias_deps = option "-alias-deps" - let _no_alias_deps = option "-no-alias-deps" - let _app_funct = option "-app-funct" - let _no_app_funct = option "-no-app-funct" - let _no_check_prims = option "-no-check-prims" - let _noassert = option "-noassert" - let _nolabels = option "-nolabels" - let _noautolink = option "-noautolink" - let _nostdlib = option "-nostdlib" - let _o s = option_with_arg "-o" s - let _opaque = option "-opaque" - let _open s = option_with_arg "-open" s - let _output_obj = option "-output-obj" - let _output_complete_obj = option "-output-complete-obj" - let _pack = option "-pack" - let _plugin = option_with_arg "-plugin" - let _pp _s = incompatible "-pp" - let _ppx _s = incompatible "-ppx" - let _principal = option "-principal" - let _no_principal = option "-no-principal" - let _rectypes = option "-rectypes" - let _no_rectypes = option "-no-rectypes" - let _runtime_variant s = option_with_arg "-runtime-variant" s - let _safe_string = option "-safe-string" - let _short_paths = option "-short-paths" - let _strict_sequence = option "-strict-sequence" - let _no_strict_sequence = option "-no-strict-sequence" - let _strict_formats = option "-strict-formats" - let _no_strict_formats = option "-no-strict-formats" - let _thread () = option "-thread" () - let _vmthread () = option "-vmthread" () - let _unboxed_types = option "-unboxed-types" - let _no_unboxed_types = option "-no-unboxed-types" - let _unsafe = option "-unsafe" - let _unsafe_string = option "-unsafe-string" - let _use_prims s = option_with_arg "-use-prims" s - let _use_runtime s = option_with_arg "-use-runtime" s - let _v = option "-v" - let _version = option "-version" - let _vnum = option "-vnum" - let _verbose = option "-verbose" - let _w = option_with_arg "-w" - let _warn_error = option_with_arg "-warn-error" - let _warn_help = option "-warn-help" - let _color s = option_with_arg "-color" s - let _error_style s = option_with_arg "-error-style" s - let _where = option "-where" - let _nopervasives = option "-nopervasives" - let _match_context_rows n = option_with_int "-match-context-rows" n - let _dump_into_file = option "-dump-into-file" - let _dno_unique_ids = option "-dno-unique-ids" - let _dunique_ids = option "-dunique-ids" - let _dsource = option "-dsource" - let _dparsetree = option "-dparsetree" - let _dtypedtree = option "-dtypedtree" - let _drawlambda = option "-drawlambda" - let _dlambda = option "-dlambda" - let _dflambda = option "-dflambda" - let _dinstr = option "-dinstr" - let _dcamlprimc = option "-dcamlprimc" - let _dtimings = option "-dtimings" - let _dprofile = option "-dprofile" + let _a () = make_archive := true + let _absname = ignore + let _alert = ignore + let _annot = ignore + let _binannot = ignore + let _c = ignore + let _cc = ignore + let _cclib = ignore + let _ccopt = ignore + let _config = ignore + let _config_var = ignore + let _compat_32 = ignore + let _custom = ignore + let _dllib = ignore + let _dllpath = ignore + let _dtypes = ignore + let _for_pack = ignore + let _g = ignore + let _stop_after = ignore + let _i = ignore + let _I = ignore + let _impl _ = with_impl := true + let _intf _ = with_intf := true + let _intf_suffix = ignore + let _keep_docs = ignore + let _no_keep_docs = ignore + let _keep_locs = ignore + let _no_keep_locs = ignore + let _labels = ignore + let _linkall = ignore + let _make_runtime = ignore + let _alias_deps = ignore + let _no_alias_deps = ignore + let _app_funct = ignore + let _no_app_funct = ignore + let _no_check_prims = ignore + let _noassert = ignore + let _nolabels = ignore + let _noautolink = ignore + let _nostdlib = ignore + let _o = ignore + let _opaque = ignore + let _open = ignore + let _output_obj = ignore + let _output_complete_obj = ignore + let _pack = ignore + let _plugin = ignore + let _pp _ = incompatible "-pp" + let _ppx _ = incompatible "-ppx" + let _principal = ignore + let _no_principal = ignore + let _rectypes = ignore + let _no_rectypes = ignore + let _runtime_variant = ignore + let _with_runtime = ignore + let _without_runtime = ignore + let _safe_string = ignore + let _short_paths = ignore + let _strict_sequence = ignore + let _no_strict_sequence = ignore + let _strict_formats = ignore + let _no_strict_formats = ignore + let _thread = ignore + let _vmthread = ignore + let _unboxed_types = ignore + let _no_unboxed_types = ignore + let _unsafe = ignore + let _unsafe_string = ignore + let _use_prims = ignore + let _use_runtime = ignore + let _v = ignore + let _version = ignore + let _vnum = ignore + let _verbose = ignore + let _w = ignore + let _warn_error = ignore + let _warn_help = ignore + let _color = ignore + let _error_style = ignore + let _where = ignore + let _nopervasives = ignore + let _match_context_rows = ignore + let _dump_into_file = ignore + let _dno_unique_ids = ignore + let _dunique_ids = ignore + let _dsource = ignore + let _dparsetree = ignore + let _dtypedtree = ignore + let _drawlambda = ignore + let _dlambda = ignore + let _dflambda = ignore + let _dinstr = ignore + let _dcamlprimc = ignore + let _dtimings = ignore + let _dprofile = ignore let _args = Arg.read_arg let _args0 = Arg.read_arg0 let anonymous = process_file end);; +let rev_compargs = ref ([] : string list) +let rev_profargs = ref ([] : string list) + let add_profarg s = - profargs := (Filename.quote s) :: "-m" :: !profargs + rev_profargs := (Filename.quote s) :: "-m" :: !rev_profargs +;; + +let anon filename = + process_file filename; + rev_compargs := Filename.quote filename :: !rev_compargs ;; let optlist = @@ -158,9 +155,9 @@ let optlist = \032 m match ... with\n\ \032 t try ... with") :: ("-p", Arg.String add_profarg, "[afilmt] Same as option -P") - :: Options.list + :: Main_args.options_with_command_line_syntax Options.list rev_compargs in -Arg.parse_expand optlist process_file usage; +Arg.parse_expand optlist anon usage; if !with_impl && !with_intf then begin fprintf stderr "ocamlcp cannot deal with both \"-impl\" and \"-intf\"\n"; fprintf stderr "please compile interfaces and implementations separately\n"; @@ -174,14 +171,14 @@ end else if !with_intf && !with_ml then begin fprintf stderr "please compile interfaces and implementations separately\n"; exit 2; end; -if !with_impl then profargs := "-impl" :: !profargs; -if !with_intf then profargs := "-intf" :: !profargs; +if !with_impl then rev_profargs := "-impl" :: !rev_profargs; +if !with_intf then rev_profargs := "-intf" :: !rev_profargs; let status = Sys.command (Printf.sprintf "ocamlc -pp \"ocamlprof -instrument %s\" %s %s" - (String.concat " " (List.rev !profargs)) + (String.concat " " (List.rev !rev_profargs)) (if !make_archive then "" else "profiling.cmo") - (String.concat " " (List.rev !compargs))) + (String.concat " " (List.rev !rev_compargs))) in exit status ;; diff --git a/tools/ocamlmklib.ml b/tools/ocamlmklib.ml index b5c0aee5..d5bb84ca 100644 --- a/tools/ocamlmklib.ml +++ b/tools/ocamlmklib.ml @@ -37,7 +37,7 @@ let compiler_path name = if Sys.os_type = "Win32" then name else Filename.concat bindir name let bytecode_objs = ref [] (* .cmo,.cma,.ml,.mli files to pass to ocamlc *) -and native_objs = ref [] (* .cmx,.cmxa,.ml,.mli files to pass to ocamlopt *) +and native_objs = ref [] (* .cmx,.ml,.mli files to pass to ocamlopt *) and c_objs = ref [] (* .o, .a, .obj, .lib, .dll, .dylib, .so files to pass to mksharedlib and ar *) and caml_libs = ref [] (* -cclib to pass to ocamlc, ocamlopt *) @@ -99,7 +99,7 @@ let parse_arguments argv = push_args ~first:0 (Arg.read_arg0 (next_arg s)) else if ends_with s ".cmo" || ends_with s ".cma" then bytecode_objs := s :: !bytecode_objs - else if ends_with s ".cmx" || ends_with s ".cmxa" then + else if ends_with s ".cmx" then native_objs := s :: !native_objs else if ends_with s ".ml" || ends_with s ".mli" then (bytecode_objs := s :: !bytecode_objs; @@ -188,7 +188,7 @@ let parse_arguments argv = if !output_c = "" then output_c := !output let usage = "\ -Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|\ +Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.ml|.mli|.o|.a|.obj|.lib|\ .dll|.dylib files>\ \nOptions are:\ \n -args Read additional newline-terminated command line arguments\ diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml index 480480d7..888dbf5b 100644 --- a/tools/ocamloptp.ml +++ b/tools/ocamloptp.ml @@ -15,21 +15,6 @@ open Printf -let compargs = ref ([] : string list) -let profargs = ref ([] : string list) -let toremove = ref ([] : string list) - -let option opt () = compargs := opt :: !compargs -let option_with_arg opt arg = - compargs := (Filename.quote arg) :: opt :: !compargs -;; -let option_with_int opt arg = - compargs := (Int.to_string arg) :: opt :: !compargs -;; -let option_with_float opt arg = - compargs := (string_of_float arg) :: opt :: !compargs -;; - let make_archive = ref false;; let with_impl = ref false;; let with_intf = ref false;; @@ -39,7 +24,6 @@ let with_ml = ref false;; let process_file filename = if Filename.check_suffix filename ".ml" then with_ml := true; if Filename.check_suffix filename ".mli" then with_mli := true; - compargs := (Filename.quote filename) :: !compargs ;; let usage = "Usage: ocamloptp \noptions are:" @@ -49,152 +33,164 @@ let incompatible o = exit 2 module Options = Main_args.Make_optcomp_options (struct - let _a () = make_archive := true; option "-a" () - let _absname = option "-absname" - let _afl_instrument = option "-afl-instrument" - let _afl_inst_ratio n = option_with_int "-afl-inst-ratio" n - let _alert = option_with_arg "-alert" - let _annot = option "-annot" - let _binannot = option "-bin-annot" - let _c = option "-c" - let _cc s = option_with_arg "-cc" s - let _cclib s = option_with_arg "-cclib" s - let _ccopt s = option_with_arg "-ccopt" s - let _clambda_checks = option "-clambda-checks" - let _compact = option "-compact" - let _config = option "-config" - let _config_var s = option_with_arg "-config-var" s - let _for_pack s = option_with_arg "-for-pack" s - let _g = option "-g" - let _stop_after = option_with_arg "-stop-after" - let _i = option "-i" - let _I s = option_with_arg "-I" s - let _impl s = with_impl := true; option_with_arg "-impl" s - let _inline s = option_with_arg "-inline" s - let _inline_toplevel n = option_with_arg "-inline-toplevel" n - let _inlining_report = option "-inlining-report" - let _dump_pass = option_with_arg "-dump-pass" - let _inline_max_depth n = option_with_arg "-inline-max-depth" n - let _rounds n = option_with_int "-rounds" n - let _inline_max_unroll n = option_with_arg "-inline-max-unroll" n - let _inline_call_cost n = option_with_arg "-inline-call-cost" n - let _inline_alloc_cost n = option_with_arg "-inline-alloc-cost" n - let _inline_prim_cost n = option_with_arg "-inline-prim-cost" n - let _inline_branch_cost n = option_with_arg "-inline-branch-cost" n - let _inline_indirect_cost n = option_with_arg "-inline-indirect-cost" n - let _inline_lifting_benefit n = option_with_arg "-inline-lifting-benefit" n - let _inline_branch_factor n = option_with_arg "-inline-branch-factor" n - let _classic_inlining = option "-Oclassic" - let _intf s = with_intf := true; option_with_arg "-intf" s - let _intf_suffix s = option_with_arg "-intf-suffix" s - let _keep_docs = option "-keep-docs" - let _no_keep_docs = option "-no-keep-docs" - let _keep_locs = option "-keep-locs" - let _no_keep_locs = option "-no-keep-locs" - let _labels = option "-labels" - let _linkall = option "-linkall" - let _alias_deps = option "-alias-deps" - let _no_alias_deps = option "-no-alias-deps" - let _app_funct = option "-app-funct" - let _no_app_funct = option "-no-app-funct" - let _no_float_const_prop = option "-no-float-const-prop" - let _noassert = option "-noassert" - let _noautolink = option "-noautolink" - let _nodynlink = option "-nodynlink" - let _nolabels = option "-nolabels" - let _nostdlib = option "-nostdlib" - let _no_unbox_free_vars_of_closures = option "-no-unbox-free-vars-of-closures" - let _no_unbox_specialised_args = option "-no-unbox-specialised-args" - let _o s = option_with_arg "-o" s - let _o2 = option "-O2" - let _o3 = option "-O3" - let _open s = option_with_arg "-open" s - let _output_obj = option "-output-obj" - let _output_complete_obj = option "-output-complete-obj" - let _p = option "-p" - let _pack = option "-pack" - let _plugin = option_with_arg "-plugin" + let _a () = make_archive := true + let _absname = ignore + let _afl_instrument = ignore + let _afl_inst_ratio = ignore + let _alert = ignore + let _annot = ignore + let _binannot = ignore + let _c = ignore + let _cc = ignore + let _cclib = ignore + let _ccopt = ignore + let _clambda_checks = ignore + let _compact = ignore + let _config = ignore + let _config_var = ignore + let _for_pack = ignore + let _g = ignore + let _stop_after = ignore + let _i = ignore + let _I = ignore + let _impl _ = with_impl := true + let _inline = ignore + let _inline_toplevel = ignore + let _inlining_report = ignore + let _dump_pass = ignore + let _inline_max_depth = ignore + let _rounds = ignore + let _inline_max_unroll = ignore + let _inline_call_cost = ignore + let _inline_alloc_cost = ignore + let _inline_prim_cost = ignore + let _inline_branch_cost = ignore + let _inline_indirect_cost = ignore + let _inline_lifting_benefit = ignore + let _inline_branch_factor = ignore + let _classic_inlining = ignore + let _insn_sched = ignore + let _intf _ = with_intf := true + let _intf_suffix = ignore + let _keep_docs = ignore + let _no_keep_docs = ignore + let _keep_locs = ignore + let _no_keep_locs = ignore + let _labels = ignore + let _linkall = ignore + let _alias_deps = ignore + let _no_alias_deps = ignore + let _app_funct = ignore + let _no_app_funct = ignore + let _no_float_const_prop = ignore + let _noassert = ignore + let _noautolink = ignore + let _nodynlink = ignore + let _no_insn_sched = ignore + let _nolabels = ignore + let _nostdlib = ignore + let _no_unbox_free_vars_of_closures = ignore + let _no_unbox_specialised_args = ignore + let _o = ignore + let _o2 = ignore + let _o3 = ignore + let _open = ignore + let _output_obj = ignore + let _output_complete_obj = ignore + let _p = ignore + let _pack = ignore + let _plugin = ignore let _pp _s = incompatible "-pp" let _ppx _s = incompatible "-ppx" - let _principal = option "-principal" - let _no_principal = option "-no-principal" - let _rectypes = option "-rectypes" - let _no_rectypes = option "-no-rectypes" - let _remove_unused_arguments = option "-remove-unused-arguments" - let _runtime_variant s = option_with_arg "-runtime-variant" s - let _S = option "-S" - let _safe_string = option "-safe-string" - let _short_paths = option "-short-paths" - let _strict_sequence = option "-strict-sequence" - let _no_strict_sequence = option "-no-strict-sequence" - let _strict_formats = option "-strict-formats" - let _no_strict_formats = option "-no-strict-formats" - let _shared = option "-shared" - let _thread = option "-thread" - let _unbox_closures = option "-unbox-closures" - let _unbox_closures_factor = option_with_int "-unbox-closures" - let _unboxed_types = option "-unboxed-types" - let _no_unboxed_types = option "-no-unboxed-types" - let _unsafe = option "-unsafe" - let _unsafe_string = option "-unsafe-string" - let _v = option "-v" - let _version = option "-version" - let _vnum = option "-vnum" - let _verbose = option "-verbose" - let _w = option_with_arg "-w" - let _warn_error = option_with_arg "-warn-error" - let _warn_help = option "-warn-help" - let _color s = option_with_arg "-color" s - let _error_style s = option_with_arg "-error-style" s - let _where = option "-where" + let _principal = ignore + let _no_principal = ignore + let _rectypes = ignore + let _no_rectypes = ignore + let _remove_unused_arguments = ignore + let _runtime_variant = ignore + let _with_runtime = ignore + let _without_runtime = ignore + let _S = ignore + let _safe_string = ignore + let _short_paths = ignore + let _strict_sequence = ignore + let _no_strict_sequence = ignore + let _strict_formats = ignore + let _no_strict_formats = ignore + let _shared = ignore + let _thread = ignore + let _unbox_closures = ignore + let _unbox_closures_factor = ignore + let _unboxed_types = ignore + let _no_unboxed_types = ignore + let _unsafe = ignore + let _unsafe_string = ignore + let _v = ignore + let _version = ignore + let _vnum = ignore + let _verbose = ignore + let _w = ignore + let _warn_error = ignore + let _warn_help = ignore + let _color = ignore + let _error_style = ignore + let _where = ignore - let _linscan = option "-linscan" - let _nopervasives = option "-nopervasives" - let _match_context_rows n = option_with_int "-match-context-rows" n - let _dump_into_file = option "-dump-into-file" - let _dno_unique_ids = option "-dno-unique_ids" - let _dunique_ids = option "-dunique_ids" - let _dsource = option "-dsource" - let _dparsetree = option "-dparsetree" - let _dtypedtree = option "-dtypedtree" - let _drawlambda = option "-drawlambda" - let _dlambda = option "-dlambda" - let _drawclambda = option "-drawclambda" - let _dclambda = option "-dclambda" - let _drawflambda = option "-drawflambda" - let _dflambda = option "-dflambda" - let _dflambda_invariants = option "-dflambda-invariants" - let _dflambda_no_invariants = option "-dflambda-no-invariants" - let _dflambda_let stamp = option_with_int "-dflambda-let" stamp - let _dflambda_verbose = option "-dflambda-verbose" - let _dcmm = option "-dcmm" - let _dsel = option "-dsel" - let _dcombine = option "-dcombine" - let _dcse = option "-dcse" - let _dlive = option "-dlive" - let _davail = option "-davail" - let _drunavail = option "-drunavail" - let _dspill = option "-dspill" - let _dsplit = option "-dsplit" - let _dinterf = option "-dinterf" - let _dprefer = option "-dprefer" - let _dalloc = option "-dalloc" - let _dreload = option "-dreload" - let _dscheduling = option "-dscheduling" - let _dlinear = option "-dlinear" - let _dstartup = option "-dstartup" - let _dinterval = option "-dinterval" - let _dtimings = option "-dtimings" - let _dprofile = option "-dprofile" - let _opaque = option "-opaque" + let _linscan = ignore + let _nopervasives = ignore + let _match_context_rows = ignore + let _dump_into_file = ignore + let _dno_unique_ids = ignore + let _dunique_ids = ignore + let _dsource = ignore + let _dparsetree = ignore + let _dtypedtree = ignore + let _drawlambda = ignore + let _dlambda = ignore + let _drawclambda = ignore + let _dclambda = ignore + let _drawflambda = ignore + let _dflambda = ignore + let _dflambda_invariants = ignore + let _dflambda_no_invariants = ignore + let _dflambda_let = ignore + let _dflambda_verbose = ignore + let _dcmm = ignore + let _dsel = ignore + let _dcombine = ignore + let _dcse = ignore + let _dlive = ignore + let _davail = ignore + let _drunavail = ignore + let _dspill = ignore + let _dsplit = ignore + let _dinterf = ignore + let _dprefer = ignore + let _dalloc = ignore + let _dreload = ignore + let _dscheduling = ignore + let _dlinear = ignore + let _dstartup = ignore + let _dinterval = ignore + let _dtimings = ignore + let _dprofile = ignore + let _opaque = ignore let _args = Arg.read_arg let _args0 = Arg.read_arg0 let anonymous = process_file end);; +let rev_compargs = ref ([] : string list) +let rev_profargs = ref ([] : string list) + let add_profarg s = - profargs := (Filename.quote s) :: "-m" :: !profargs + rev_profargs := (Filename.quote s) :: "-m" :: !rev_profargs +;; + +let anon filename = + process_file filename; + rev_compargs := Filename.quote filename :: !rev_compargs ;; let optlist = @@ -206,9 +202,9 @@ let optlist = \032 l while and for loops\n\ \032 m match ... with\n\ \032 t try ... with") - :: Options.list + :: Main_args.options_with_command_line_syntax Options.list rev_compargs in -Arg.parse_expand optlist process_file usage; +Arg.parse_expand optlist anon usage; if !with_impl && !with_intf then begin fprintf stderr "ocamloptp cannot deal with both \"-impl\" and \"-intf\"\n"; fprintf stderr "please compile interfaces and implementations separately\n"; @@ -222,14 +218,14 @@ end else if !with_intf && !with_ml then begin fprintf stderr "please compile interfaces and implementations separately\n"; exit 2; end; -if !with_impl then profargs := "-impl" :: !profargs; -if !with_intf then profargs := "-intf" :: !profargs; +if !with_impl then rev_profargs := "-impl" :: !rev_profargs; +if !with_intf then rev_profargs := "-intf" :: !rev_profargs; let status = Sys.command (Printf.sprintf "ocamlopt -pp \"ocamlprof -instrument %s\" %s %s" - (String.concat " " (List.rev !profargs)) + (String.concat " " (List.rev !rev_profargs)) (if !make_archive then "" else "profiling.cmx") - (String.concat " " (List.rev !compargs))) + (String.concat " " (List.rev !rev_compargs))) in exit status ;; diff --git a/tools/pre-commit-githook b/tools/pre-commit-githook index 4a846f1a..dcb6f90f 100755 --- a/tools/pre-commit-githook +++ b/tools/pre-commit-githook @@ -15,7 +15,7 @@ # Bump this on any changes. It's vital that HOOK_VERSION followed by equals # appears nowhere else in these sources! -HOOK_VERSION=3 +HOOK_VERSION=4 # For what it's worth, allow for empty trees! if git rev-parse --verify HEAD >/dev/null 2>&1 @@ -66,7 +66,7 @@ not_pruned () { ;; *) - not_pruned $DIR + not_pruned "$DIR" return $? esac fi @@ -79,7 +79,7 @@ export OCAML_CT_CAT="git cat-file --textconv" export OCAML_CT_CA_FLAG=--cached git diff --diff-filter=d --staged --name-only | (while IFS= read -r path do - if not_pruned $path && ! tools/check-typo ./$path ; then + if not_pruned "$path" && ! tools/check-typo "./$path" ; then ERRORS=1 fi done; exit $ERRORS) diff --git a/tools/read_cmt.ml b/tools/read_cmt.ml index 1e221339..0e3cfbc2 100644 --- a/tools/read_cmt.ml +++ b/tools/read_cmt.ml @@ -105,7 +105,7 @@ let main () = Filename.check_suffix filename ".cmt" || Filename.check_suffix filename ".cmti" then begin - Compmisc.init_path false; + Compmisc.init_path (); let cmt = Cmt_format.read_cmt filename in if !gen_annot then Cmt2annot.gen_annot ~save_cmt_info: !save_cmt_info diff --git a/tools/release-checklist b/tools/release-checklist index 0dd02095..2a9911bd 100644 --- a/tools/release-checklist +++ b/tools/release-checklist @@ -22,10 +22,14 @@ and the OCamlLabs folks (for OPAM testing). ``` rm -f /tmp/env-$USER.sh cat >/tmp/env-$USER.sh <ocaml-$VERSION.tar.gz xz ocaml-$VERSION.tar.xz @@ -195,6 +199,13 @@ xz ocaml-$VERSION.tar.xz ## 8: upload the archives and compute checksums +For the first beta of a major version, create the distribution directory on +the server: +``` +ssh $ARCHIVE_HOST "mkdir -p $DIST" +``` + +Upload the archives: ``` scp ocaml-$VERSION.tar.{xz,gz} $ARCHIVE_HOST:$DIST ``` @@ -250,6 +261,7 @@ $MAJOR.$MINOR ($BRANCH) value and the exact same manual -- this is frequent if it was a release candidate. ``` +cd $WORKTREE make world.opt make install export PATH="$INSTDIR/bin:$PATH" @@ -258,7 +270,8 @@ make clean make rm -rf /tmp/release mkdir -p /tmp/release -RELEASENAME="ocaml-$BRANCH-" RELEASE=/tmp/release/$RELEASENAME make release +RELEASENAME="ocaml-$BRANCH-" +make -C manual release RELEASE=/tmp/release/$RELEASENAME scp /tmp/release/* $ARCHIVE_HOST:$DIST/ @@ -268,13 +281,15 @@ ssh $ARCHIVE_HOST "cd $DIST; sha512sum ocaml-$BRANCH-refman* >>SHA512SUM" ``` Releasing the manual online happens on another machine: +Do this ONLY FOR A PRODUCTION RELEASE ``` +scp /tmp/env-$USER.sh $ARCHIVE_HOST:/tmp/env-$USER.sh ssh $ARCHIVE_HOST -source /tmp/env.sh -scp /tmp/env.sh $WEB_HOST:/tmp +source /tmp/env-$USER.sh +scp /tmp/env-$USER.sh $WEB_HOST:/tmp ssh $WEB_HOST -source /tmp/env.sh +source /tmp/env-$USER.sh cd $WEB_PATH/caml/pub/docs mkdir -p manual-ocaml-$BRANCH @@ -299,17 +314,7 @@ organize the webpage for the new release. See ## 12: update Mantis -Update Mantis by adding $MAJOR.$MINOR.$BUGFIX as a version number for reports. - -Provided you have a sufficient Mantis privilege level, this is done from - - https://caml.inria.fr/mantis/manage_proj_edit_page.php?project_id=1 - -after login, by scrolling down to "Versions". - -(If you don't have the necessary Mantis rights, you need to ask -someone else to do this.) - +(this section intentionally left blank) ## 13: announce the release on caml-list and caml-announce @@ -367,18 +372,33 @@ Happy hacking, ``` Dear OCaml users, -The release of OCaml $BRANCH.$BUGFIX is approaching. We have created +The release of OCaml 4.08.0 is approaching. We have created a beta version to help you adapt your software to the new features ahead of the release. -The source code is available at this address: +The source code is available at these addresses: + + https://github.com/ocaml/ocaml/archive/4.08.0+beta1.tar.gz + https://caml.inria.fr/pub/distrib/ocaml-4.08/ocaml-4.08.0+beta1.tar.gz + +The compiler can also be installed as an OPAM switch with one of the +following commands. + +opam switch create ocaml-variants.4.08.0+beta1 --repositories=default,beta=git+https://github.com/ocaml/ocaml-beta-repository.git + +or - https://github.com/ocaml/ocaml/archive/$VERSION.tar.gz +opam switch create ocaml-variants.4.08.0+beta1+ --repositories=default,beta=git+https://github.com/ocaml/ocaml-beta-repository.git -and the compiler is also available as a set of OPAM switches. + where you replace with one of these: + afl + default_unsafe_string + flambda + fp + fp+flambda We want to know about all bugs. Please report them here: - https://github.com/ocaml/ocaml/issues + https://github.com/ocaml/ocaml/issues Happy hacking, diff --git a/tools/scrapelabels.ml b/tools/scrapelabels.ml index 9a20e07a..1c600414 100644 --- a/tools/scrapelabels.ml +++ b/tools/scrapelabels.ml @@ -28,7 +28,7 @@ let modified = ref false let modules = ref [ "Arg"; "BigArray"; "Buffer"; "Condition"; "Dbm"; "Digest"; "Dynlink"; - "Event"; "Filename"; "Format"; "Gc"; "Genlex"; "Graphics"; + "Event"; "Filename"; "Format"; "Gc"; "Genlex"; "Lexing"; "Marshal"; "Mutex"; "Parsing"; "Pervasives"; "Queue"; "Stack"; "Str"; "Stream"; "Sys"; "Thread"; "ThreadUnix"; "Weak" ] diff --git a/toplevel/opttopdirs.ml b/toplevel/opttopdirs.ml index 9170cb62..5dfe97d0 100644 --- a/toplevel/opttopdirs.ml +++ b/toplevel/opttopdirs.ml @@ -94,11 +94,11 @@ let load_file ppf name0 = (* The Dynlink interface does not allow us to distinguish between a Dynlink.Error exceptions raised in the loaded modules or a genuine error during dynlink... *) - try Compdynlink.loadfile fn; true + try Dynlink.loadfile fn; true with - | Compdynlink.Error err -> + | Dynlink.Error err -> fprintf ppf "Error while loading %s: %s.@." - name (Compdynlink.error_message err); + name (Dynlink.error_message err); false | exn -> print_exception_outcome ppf exn; diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml index 45918317..0d1f7392 100644 --- a/toplevel/opttoploop.ml +++ b/toplevel/opttoploop.ml @@ -31,16 +31,16 @@ let _dummy = (Ok (Obj.magic 0), Err "") external ndl_run_toplevel: string -> string -> res = "caml_natdynlink_run_toplevel" -external ndl_loadsym: string -> Obj.t = "caml_natdynlink_loadsym" let global_symbol id = let sym = Compilenv.symbol_for_global id in - try ndl_loadsym sym - with _ -> fatal_error ("Opttoploop.global_symbol " ^ (Ident.unique_name id)) + match Dynlink.unsafe_get_global_value ~bytecode_or_asm_symbol:sym with + | None -> + fatal_error ("Opttoploop.global_symbol " ^ (Ident.unique_name id)) + | Some obj -> obj let need_symbol sym = - try ignore (ndl_loadsym sym); false - with _ -> true + Option.is_none (Dynlink.unsafe_get_global_value ~bytecode_or_asm_symbol:sym) let dll_run dll entry = match (try Result (Obj.magic (ndl_run_toplevel dll entry)) @@ -241,7 +241,7 @@ let backend = (module Backend : Backend_intf.S) let load_lambda ppf ~module_ident ~required_globals lam size = if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam; - let slam = Simplif.simplify_lambda "//toplevel//" lam in + let slam = Simplif.simplify_lambda lam in if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam; let dll = @@ -251,13 +251,13 @@ let load_lambda ppf ~module_ident ~required_globals lam size = let fn = Filename.chop_extension dll in if not Config.flambda then Asmgen.compile_implementation_clambda - ~toplevel:need_symbol fn ~ppf_dump:ppf + ~toplevel:need_symbol fn ~backend ~ppf_dump:ppf { Lambda.code=slam ; main_module_block_size=size; module_ident; required_globals } else Asmgen.compile_implementation_flambda ~required_globals ~backend ~toplevel:need_symbol fn ~ppf_dump:ppf - (Middle_end.middle_end ~ppf_dump:ppf ~prefixname:"" ~backend ~size + (Flambda_middle_end.middle_end ~ppf_dump:ppf ~prefixname:"" ~backend ~size ~module_ident ~module_initializer:slam ~filename:"toplevel"); Asmlink.call_linker_shared [fn ^ ext_obj] dll; Sys.remove (fn ^ ext_obj); @@ -437,9 +437,6 @@ let preprocess_phrase ppf phr = let str = Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str in - let str = - Pparse.ImplementationHooks.apply_hooks - { Misc.sourcefile = "//toplevel//" } str in Ptop_def str | phr -> phr in @@ -538,7 +535,7 @@ let refill_lexbuf buffer len = let _ = Sys.interactive := true; - Compmisc.init_path true; + Compmisc.init_path (); Clflags.dlcode := true; () @@ -610,22 +607,18 @@ let loop ppf = | x -> Location.report_exception ppf x; Btype.backtrack snap done -(* Execute a script. If [name] is "", read the script from stdin. *) +external caml_sys_modify_argv : string array -> unit = + "caml_sys_modify_argv" -let override_sys_argv args = - let len = Array.length args in - if Array.length Sys.argv < len then invalid_arg "Toploop.override_sys_argv"; - Array.blit args 0 Sys.argv 0 len; - Obj.truncate (Obj.repr Sys.argv) len; +let override_sys_argv new_argv = + caml_sys_modify_argv new_argv; Arg.current := 0 +(* Execute a script. If [name] is "", read the script from stdin. *) + let run_script ppf name args = - let len = Array.length args in - if Array.length Sys.argv < len then invalid_arg "Toploop.run_script"; - Array.blit args 0 Sys.argv 0 len; - Obj.truncate (Obj.repr Sys.argv) len; - Arg.current := 0; - Compmisc.init_path ~dir:(Filename.dirname name) true; + override_sys_argv args; + Compmisc.init_path ~dir:(Filename.dirname name) (); (* Note: would use [Filename.abspath] here, if we had it. *) toplevel_env := Compmisc.initial_env(); Sys.interactive := false; diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml index cbc0fd56..0a96b579 100644 --- a/toplevel/opttopmain.ml +++ b/toplevel/opttopmain.ml @@ -153,6 +153,8 @@ module Options = Main_args.Make_opttop_options (struct Int_arg_helper.parse spec "Syntax: -inline-max-depth | =[,...]" inline_max_depth + let _insn_sched = set insn_sched + let _no_insn_sched = clear insn_sched let _no_unbox_free_vars_of_closures = clear unbox_free_vars_of_closures let _no_unbox_specialised_args = clear unbox_specialised_args let _o s = output_name := Some s @@ -272,5 +274,5 @@ let main () = end; Compmisc.read_clflags_from_env (); if not (prepare Format.err_formatter) then exit 2; - Compmisc.init_path true; + Compmisc.init_path (); Opttoploop.loop Format.std_formatter diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index c4518bcf..8469d84b 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -118,16 +118,8 @@ let _ = add_directive "cd" (Directive_string dir_cd) exception Load_failed let check_consistency ppf filename cu = - try - List.iter - (fun (name, crco) -> - Env.add_import name; - match crco with - None -> () - | Some crc-> - Consistbl.check Env.crc_units name crc filename) - cu.cu_imports - with Consistbl.Inconsistency(name, user, auth) -> + try Env.import_crcs ~source:filename cu.cu_imports + with Persistent_env.Consistbl.Inconsistency(name, user, auth) -> fprintf ppf "@[The files %s@ and %s@ \ disagree over interface %s@]@." user auth name; diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 1326d060..b1226b92 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -186,7 +186,7 @@ let record_backtrace () = let load_lambda ppf lam = if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam; - let slam = Simplif.simplify_lambda "//toplevel//" lam in + let slam = Simplif.simplify_lambda lam in if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam; let (init_code, fun_code) = Bytegen.compile_phrase slam in if !Clflags.dump_instr then @@ -383,9 +383,6 @@ let preprocess_phrase ppf phr = let str = Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str in - let str = - Pparse.ImplementationHooks.apply_hooks - { Misc.sourcefile = "//toplevel//" } str in Ptop_def str | phr -> phr in @@ -491,15 +488,9 @@ let _ = cannot be loaded inside the OCaml toplevel"; Sys.interactive := true; let crc_intfs = Symtable.init_toplevel() in - Compmisc.init_path false; - List.iter - (fun (name, crco) -> - Env.add_import name; - match crco with - None -> () - | Some crc-> - Consistbl.set Env.crc_units name crc Sys.executable_name) - crc_intfs + Compmisc.init_path (); + Env.import_crcs ~source:Sys.executable_name crc_intfs; + () let load_ocamlinit ppf = if !Clflags.noinit then () @@ -574,18 +565,18 @@ let loop ppf = | x -> Location.report_exception ppf x; Btype.backtrack snap done -(* Execute a script. If [name] is "", read the script from stdin. *) +external caml_sys_modify_argv : string array -> unit = + "caml_sys_modify_argv" -let override_sys_argv args = - let len = Array.length args in - if Array.length Sys.argv < len then invalid_arg "Toploop.override_sys_argv"; - Array.blit args 0 Sys.argv 0 len; - Obj.truncate (Obj.repr Sys.argv) len; +let override_sys_argv new_argv = + caml_sys_modify_argv new_argv; Arg.current := 0 +(* Execute a script. If [name] is "", read the script from stdin. *) + let run_script ppf name args = override_sys_argv args; - Compmisc.init_path ~dir:(Filename.dirname name) true; + Compmisc.init_path ~dir:(Filename.dirname name) (); (* Note: would use [Filename.abspath] here, if we had it. *) begin try toplevel_env := Compmisc.initial_env() diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml index ebe47cb8..735baebb 100644 --- a/toplevel/topmain.ml +++ b/toplevel/topmain.ml @@ -182,5 +182,5 @@ let main () = Compenv.readenv ppf Before_link; Compmisc.read_clflags_from_env (); if not (prepare ppf) then exit 2; - Compmisc.init_path false; + Compmisc.init_path (); Toploop.loop Format.std_formatter diff --git a/typing/TODO.md b/typing/TODO.md old mode 100755 new mode 100644 diff --git a/typing/cmi_format.ml b/typing/cmi_format.ml deleted file mode 100644 index 2c85a9b7..00000000 --- a/typing/cmi_format.ml +++ /dev/null @@ -1,109 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type pers_flags = - | Rectypes - | Alerts of string Misc.Stdlib.String.Map.t - | Opaque - | Unsafe_string - -type error = - Not_an_interface of string - | Wrong_version_interface of string * string - | Corrupted_interface of string - -exception Error of error - -type cmi_infos = { - cmi_name : string; - cmi_sign : Types.signature_item list; - cmi_crcs : (string * Digest.t option) list; - cmi_flags : pers_flags list; -} - -let input_cmi ic = - let (name, sign) = input_value ic in - let crcs = input_value ic in - let flags = input_value ic in - { - cmi_name = name; - cmi_sign = sign; - cmi_crcs = crcs; - cmi_flags = flags; - } - -let read_cmi filename = - let ic = open_in_bin filename in - try - let buffer = - really_input_string ic (String.length Config.cmi_magic_number) - in - if buffer <> Config.cmi_magic_number then begin - close_in ic; - let pre_len = String.length Config.cmi_magic_number - 3 in - if String.sub buffer 0 pre_len - = String.sub Config.cmi_magic_number 0 pre_len then - begin - let msg = - if buffer < Config.cmi_magic_number then "an older" else "a newer" in - raise (Error (Wrong_version_interface (filename, msg))) - end else begin - raise(Error(Not_an_interface filename)) - end - end; - let cmi = input_cmi ic in - close_in ic; - cmi - with End_of_file | Failure _ -> - close_in ic; - raise(Error(Corrupted_interface(filename))) - | Error e -> - close_in ic; - raise (Error e) - -let output_cmi filename oc cmi = -(* beware: the provided signature must have been substituted for saving *) - output_string oc Config.cmi_magic_number; - output_value oc (cmi.cmi_name, cmi.cmi_sign); - flush oc; - let crc = Digest.file filename in - let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in - output_value oc crcs; - output_value oc cmi.cmi_flags; - crc - -(* Error report *) - -open Format - -let report_error ppf = function - | Not_an_interface filename -> - fprintf ppf "%a@ is not a compiled interface" - Location.print_filename filename - | Wrong_version_interface (filename, older_newer) -> - fprintf ppf - "%a@ is not a compiled interface for this version of OCaml.@.\ - It seems to be for %s version of OCaml." - Location.print_filename filename older_newer - | Corrupted_interface filename -> - fprintf ppf "Corrupted compiled interface@ %a" - Location.print_filename filename - -let () = - Location.register_error_of_exn - (function - | Error err -> Some (Location.error_of_printer_file report_error err) - | _ -> None - ) diff --git a/typing/cmi_format.mli b/typing/cmi_format.mli deleted file mode 100644 index b42dc9c2..00000000 --- a/typing/cmi_format.mli +++ /dev/null @@ -1,49 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type pers_flags = - | Rectypes - | Alerts of string Misc.Stdlib.String.Map.t - | Opaque - | Unsafe_string - -type cmi_infos = { - cmi_name : string; - cmi_sign : Types.signature_item list; - cmi_crcs : (string * Digest.t option) list; - cmi_flags : pers_flags list; -} - -(* write the magic + the cmi information *) -val output_cmi : string -> out_channel -> cmi_infos -> Digest.t - -(* read the cmi information (the magic is supposed to have already been read) *) -val input_cmi : in_channel -> cmi_infos - -(* read a cmi from a filename, checking the magic *) -val read_cmi : string -> cmi_infos - -(* Error report *) - -type error = - Not_an_interface of string - | Wrong_version_interface of string * string - | Corrupted_interface of string - -exception Error of error - -open Format - -val report_error: formatter -> error -> unit diff --git a/typing/cmt_format.ml b/typing/cmt_format.ml deleted file mode 100644 index 09c787d9..00000000 --- a/typing/cmt_format.ml +++ /dev/null @@ -1,194 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Cmi_format -open Typedtree - -(* Note that in Typerex, there is an awful hack to save a cmt file - together with the interface file that was generated by ocaml (this - is because the installed version of ocaml might differ from the one - integrated in Typerex). -*) - - - -let read_magic_number ic = - let len_magic_number = String.length Config.cmt_magic_number in - really_input_string ic len_magic_number - -type binary_annots = - | Packed of Types.signature * string list - | Implementation of structure - | Interface of signature - | Partial_implementation of binary_part array - | Partial_interface of binary_part array - -and binary_part = -| Partial_structure of structure -| Partial_structure_item of structure_item -| Partial_expression of expression -| Partial_pattern of pattern -| Partial_class_expr of class_expr -| Partial_signature of signature -| Partial_signature_item of signature_item -| Partial_module_type of module_type - -type cmt_infos = { - cmt_modname : string; - cmt_annots : binary_annots; - cmt_value_dependencies : - (Types.value_description * Types.value_description) list; - cmt_comments : (string * Location.t) list; - cmt_args : string array; - cmt_sourcefile : string option; - cmt_builddir : string; - cmt_loadpath : string list; - cmt_source_digest : Digest.t option; - cmt_initial_env : Env.t; - cmt_imports : (string * Digest.t option) list; - cmt_interface_digest : Digest.t option; - cmt_use_summaries : bool; -} - -type error = - Not_a_typedtree of string - -let need_to_clear_env = - try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false - with Not_found -> true - -let keep_only_summary = Env.keep_only_summary - -open Tast_mapper - -let cenv = - {Tast_mapper.default with env = fun _sub env -> keep_only_summary env} - -let clear_part = function - | Partial_structure s -> Partial_structure (cenv.structure cenv s) - | Partial_structure_item s -> - Partial_structure_item (cenv.structure_item cenv s) - | Partial_expression e -> Partial_expression (cenv.expr cenv e) - | Partial_pattern p -> Partial_pattern (cenv.pat cenv p) - | Partial_class_expr ce -> Partial_class_expr (cenv.class_expr cenv ce) - | Partial_signature s -> Partial_signature (cenv.signature cenv s) - | Partial_signature_item s -> - Partial_signature_item (cenv.signature_item cenv s) - | Partial_module_type s -> Partial_module_type (cenv.module_type cenv s) - -let clear_env binary_annots = - if need_to_clear_env then - match binary_annots with - | Implementation s -> Implementation (cenv.structure cenv s) - | Interface s -> Interface (cenv.signature cenv s) - | Packed _ -> binary_annots - | Partial_implementation array -> - Partial_implementation (Array.map clear_part array) - | Partial_interface array -> - Partial_interface (Array.map clear_part array) - - else binary_annots - -exception Error of error - -let input_cmt ic = (input_value ic : cmt_infos) - -let output_cmt oc cmt = - output_string oc Config.cmt_magic_number; - output_value oc (cmt : cmt_infos) - -let read filename = -(* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *) - let ic = open_in_bin filename in - Misc.try_finally - ~always:(fun () -> close_in ic) - (fun () -> - let magic_number = read_magic_number ic in - let cmi, cmt = - if magic_number = Config.cmt_magic_number then - None, Some (input_cmt ic) - else if magic_number = Config.cmi_magic_number then - let cmi = Cmi_format.input_cmi ic in - let cmt = try - let magic_number = read_magic_number ic in - if magic_number = Config.cmt_magic_number then - let cmt = input_cmt ic in - Some cmt - else None - with _ -> None - in - Some cmi, cmt - else - raise(Cmi_format.Error(Cmi_format.Not_an_interface filename)) - in - cmi, cmt - ) - -let read_cmt filename = - match read filename with - _, None -> raise (Error (Not_a_typedtree filename)) - | _, Some cmt -> cmt - -let read_cmi filename = - match read filename with - None, _ -> - raise (Cmi_format.Error (Cmi_format.Not_an_interface filename)) - | Some cmi, _ -> cmi - -let saved_types = ref [] -let value_deps = ref [] - -let clear () = - saved_types := []; - value_deps := [] - -let add_saved_type b = saved_types := b :: !saved_types -let get_saved_types () = !saved_types -let set_saved_types l = saved_types := l - -let record_value_dependency vd1 vd2 = - if vd1.Types.val_loc <> vd2.Types.val_loc then - value_deps := (vd1, vd2) :: !value_deps - -let save_cmt filename modname binary_annots sourcefile initial_env cmi = - if !Clflags.binary_annotations && not !Clflags.print_types then begin - Misc.output_to_file_via_temporary - ~mode:[Open_binary] filename - (fun temp_file_name oc -> - let this_crc = - match cmi with - | None -> None - | Some cmi -> Some (output_cmi temp_file_name oc cmi) - in - let source_digest = Misc.may_map Digest.file sourcefile in - let cmt = { - cmt_modname = modname; - cmt_annots = clear_env binary_annots; - cmt_value_dependencies = !value_deps; - cmt_comments = Lexer.comments (); - cmt_args = Sys.argv; - cmt_sourcefile = sourcefile; - cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ()); - cmt_loadpath = Load_path.get_paths (); - cmt_source_digest = source_digest; - cmt_initial_env = if need_to_clear_env then - keep_only_summary initial_env else initial_env; - cmt_imports = List.sort compare (Env.imports ()); - cmt_interface_digest = this_crc; - cmt_use_summaries = need_to_clear_env; - } in - output_cmt oc cmt) - end; - clear () diff --git a/typing/cmt_format.mli b/typing/cmt_format.mli deleted file mode 100644 index 617bc1ed..00000000 --- a/typing/cmt_format.mli +++ /dev/null @@ -1,121 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** cmt and cmti files format. *) - -(** The layout of a cmt file is as follows: - := \{\} \{cmt infos\} \{\} - where is the cmi file format: - := . - More precisely, the optional part must be present if and only if - the file is: - - a cmti, or - - a cmt, for a ml file which has no corresponding mli (hence no - corresponding cmti). - - Thus, we provide a common reading function for cmi and cmt(i) - files which returns an option for each of the three parts: cmi - info, cmt info, source info. *) - -open Typedtree - -type binary_annots = - | Packed of Types.signature * string list - | Implementation of structure - | Interface of signature - | Partial_implementation of binary_part array - | Partial_interface of binary_part array - -and binary_part = - | Partial_structure of structure - | Partial_structure_item of structure_item - | Partial_expression of expression - | Partial_pattern of pattern - | Partial_class_expr of class_expr - | Partial_signature of signature - | Partial_signature_item of signature_item - | Partial_module_type of module_type - -type cmt_infos = { - cmt_modname : string; - cmt_annots : binary_annots; - cmt_value_dependencies : - (Types.value_description * Types.value_description) list; - cmt_comments : (string * Location.t) list; - cmt_args : string array; - cmt_sourcefile : string option; - cmt_builddir : string; - cmt_loadpath : string list; - cmt_source_digest : string option; - cmt_initial_env : Env.t; - cmt_imports : (string * Digest.t option) list; - cmt_interface_digest : Digest.t option; - cmt_use_summaries : bool; -} - -type error = - Not_a_typedtree of string - -exception Error of error - -(** [read filename] opens filename, and extract both the cmi_infos, if - it exists, and the cmt_infos, if it exists. Thus, it can be used - with .cmi, .cmt and .cmti files. - - .cmti files always contain a cmi_infos at the beginning. .cmt files - only contain a cmi_infos at the beginning if there is no associated - .cmti file. -*) -val read : string -> Cmi_format.cmi_infos option * cmt_infos option - -val read_cmt : string -> cmt_infos -val read_cmi : string -> Cmi_format.cmi_infos - -(** [save_cmt filename modname binary_annots sourcefile initial_env cmi] - writes a cmt(i) file. *) -val save_cmt : - string -> (* filename.cmt to generate *) - string -> (* module name *) - binary_annots -> - string option -> (* source file *) - Env.t -> (* initial env *) - Cmi_format.cmi_infos option -> (* if a .cmi was generated *) - unit - -(* Miscellaneous functions *) - -val read_magic_number : in_channel -> string - -val clear: unit -> unit - -val add_saved_type : binary_part -> unit -val get_saved_types : unit -> binary_part list -val set_saved_types : binary_part list -> unit - -val record_value_dependency: - Types.value_description -> Types.value_description -> unit - - -(* - - val is_magic_number : string -> bool - val read : in_channel -> Env.cmi_infos option * t - val write_magic_number : out_channel -> unit - val write : out_channel -> t -> unit - - val find : string list -> string -> string - val read_signature : 'a -> string -> Types.signature * 'b list * 'c list - -*) diff --git a/typing/ctype.ml b/typing/ctype.ml index fb8f4c10..a6189ad4 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -124,6 +124,7 @@ module Unification_trace = struct Incompatible_fields { name; diff = swap_diff diff} | Obj (Missing_field(pos,s)) -> Obj(Missing_field(swap_position pos,s)) | Obj (Abstract_row pos) -> Obj(Abstract_row (swap_position pos)) + | Variant (No_tags(pos,f)) -> Variant (No_tags(swap_position pos,f)) | x -> x let swap x = List.map swap_elt x @@ -135,6 +136,16 @@ module Unification_trace = struct let incompatible_fields name got expected = Incompatible_fields {name; diff={got; expected} } + let explain trace f = + let rec explain = function + | [] -> None + | [h] -> f ~prev:None h + | h :: (prev :: _ as rem) -> + match f ~prev:(Some prev) h with + | Some _ as m -> m + | None -> explain rem in + explain (List.rev trace) + end module Trace = Unification_trace @@ -880,30 +891,42 @@ let rec lower_contravariant env var_level visited contra ty = in if must_visit then begin Hashtbl.add visited ty.id contra; - let generalize_rec = lower_contravariant env var_level visited in + let lower_rec = lower_contravariant env var_level visited in match ty.desc with Tvar _ -> if contra then set_level ty var_level - | Tconstr (path, tyl, abbrev) -> - let variance = - try (Env.find_type path env).type_variance + | Tconstr (_, [], _) -> () + | Tconstr (path, tyl, _abbrev) -> + let variance, maybe_expand = + try + let typ = Env.find_type path env in + typ.type_variance, + typ.type_kind = Type_abstract with Not_found -> (* See testsuite/tests/typing-missing-cmi-2 for an example *) - List.map (fun _ -> Variance.may_inv) tyl + List.map (fun _ -> Variance.may_inv) tyl, + false in - abbrev := Mnil; - List.iter2 - (fun v t -> - if Variance.(mem May_weak v) - then generalize_rec true t - else generalize_rec contra t) - variance tyl + if List.for_all ((=) Variance.null) variance then () else + let not_expanded () = + List.iter2 + (fun v t -> + if v = Variance.null then () else + if Variance.(mem May_weak v) + then lower_rec true t + else lower_rec contra t) + variance tyl in + if maybe_expand then (* we expand cautiously to avoid missing cmis *) + match !forward_try_expand_once env ty with + | ty -> lower_rec contra ty + | exception Cannot_expand -> not_expanded () + else not_expanded () | Tpackage (_, _, tyl) -> - List.iter (generalize_rec true) tyl + List.iter (lower_rec true) tyl | Tarrow (_, t1, t2, _) -> - generalize_rec true t1; - generalize_rec contra t2 + lower_rec true t1; + lower_rec contra t2 | _ -> - iter_type_expr (generalize_rec contra) ty + iter_type_expr (lower_rec contra) ty end let lower_contravariant env ty = @@ -1589,7 +1612,10 @@ let expand_head env ty = let _ = forward_try_expand_once := try_expand_safe -(* Expand until we find a non-abstract type declaration *) +(* Expand until we find a non-abstract type declaration, + use try_expand_safe to avoid raising "Unify _" when + called on recursive types + *) let rec extract_concrete_typedecl env ty = let ty = repr ty in @@ -1598,7 +1624,7 @@ let rec extract_concrete_typedecl env ty = let decl = Env.find_type p env in if decl.type_kind <> Type_abstract then (p, p, decl) else let ty = - try try_expand_once env ty with Cannot_expand -> raise Not_found + try try_expand_safe env ty with Cannot_expand -> raise Not_found in let (_, p', decl) = extract_concrete_typedecl env ty in (p, p', decl) diff --git a/typing/ctype.mli b/typing/ctype.mli index 15e70c99..450a5ec2 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -70,6 +70,14 @@ module Unification_trace: sig (** Switch [expected] and [got] *) val swap: t -> t + (** [explain trace f] calls [f] on trace elements starting from the end + until [f ~prev elt] is [Some _], returns that + or [None] if the end of the trace is reached. *) + val explain: + 'a elt list -> + (prev:'a elt option -> 'a elt -> 'b option) -> + 'b option + end exception Unify of Unification_trace.t diff --git a/typing/env.ml b/typing/env.ml index 3a544a3f..c807269d 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -57,10 +57,6 @@ let used_constructors : = Hashtbl.create 16 type error = - | Illegal_renaming of string * string * string - | Inconsistent_import of string * string * string - | Need_recursive_types of string * string - | Depend_on_unsafe_string_unit of string * string | Missing_module of Location.t * Path.t * Path.t | Illegal_value_name of Location.t * string @@ -68,95 +64,6 @@ exception Error of error let error err = raise (Error err) -module EnvLazy : sig - type ('a,'b) t - - type log - - val force : ('a -> 'b) -> ('a,'b) t -> 'b - val create : 'a -> ('a,'b) t - val get_arg : ('a,'b) t -> 'a option - val create_forced : 'b -> ('a, 'b) t - val create_failed : exn -> ('a, 'b) t - - (* [force_logged log f t] is equivalent to [force f t] but if [f] returns - [None] then [t] is recorded in [log]. [backtrack log] will then reset all - the recorded [t]s back to their original state. *) - val log : unit -> log - val force_logged : log -> ('a -> 'b option) -> ('a,'b option) t -> 'b option - val backtrack : log -> unit - -end = struct - - type ('a,'b) t = ('a,'b) eval ref - - and ('a,'b) eval = - | Done of 'b - | Raise of exn - | Thunk of 'a - - type undo = - | Nil - | Cons : ('a, 'b) t * 'a * undo -> undo - - type log = undo ref - - let force f x = - match !x with - | Done x -> x - | Raise e -> raise e - | Thunk e -> - match f e with - | y -> - x := Done y; - y - | exception e -> - x := Raise e; - raise e - - let get_arg x = - match !x with Thunk a -> Some a | _ -> None - - let create x = - ref (Thunk x) - - let create_forced y = - ref (Done y) - - let create_failed e = - ref (Raise e) - - let log () = - ref Nil - - let force_logged log f x = - match !x with - | Done x -> x - | Raise e -> raise e - | Thunk e -> - match f e with - | None -> - x := Done None; - log := Cons(x, e, !log); - None - | Some _ as y -> - x := Done y; - y - | exception e -> - x := Raise e; - raise e - - let backtrack log = - let rec loop = function - | Nil -> () - | Cons(x, e, rest) -> - x := Thunk e; - loop rest - in - loop !log - -end - (** Map indexed by the name of module components. *) module NameMap = String.Map @@ -488,7 +395,7 @@ and module_declaration_lazy = and module_components = { - alerts: string Misc.Stdlib.String.Map.t; + alerts: alerts; loc: Location.t; comps: (components_maker, module_components_repr option) EnvLazy.t; } @@ -533,6 +440,15 @@ and address_unforced = and address_lazy = (address_unforced, address) EnvLazy.t +let empty_structure = + Structure_comps { + comp_values = NameMap.empty; + comp_constrs = NameMap.empty; + comp_labels = NameMap.empty; + comp_types = NameMap.empty; + comp_modules = NameMap.empty; comp_modtypes = NameMap.empty; + comp_components = NameMap.empty; comp_classes = NameMap.empty; + comp_cltypes = NameMap.empty } let copy_local ~from env = { env with @@ -605,27 +521,11 @@ let diff env1 env2 = IdTbl.diff_keys env1.modules env2.modules @ IdTbl.diff_keys env1.classes env2.classes -type can_load_cmis = - | Can_load_cmis - | Cannot_load_cmis of EnvLazy.log - -let can_load_cmis = ref Can_load_cmis - -let without_cmis f x = - let log = EnvLazy.log () in - let res = - Misc.(protect_refs - [R (can_load_cmis, Cannot_load_cmis log)] - (fun () -> f x)) - in - EnvLazy.backtrack log; - res - (* Forward declarations *) let components_of_module' = - ref ((fun ~alerts:_ ~loc:_ _env _sub _path _addr _mty -> assert false) : - alerts:string Misc.Stdlib.String.Map.t -> loc:Location.t -> t -> + ref ((fun ~alerts:_ ~loc:_ _env _fsub _psub _path _addr _mty -> assert false): + alerts:alerts -> loc:Location.t -> t -> Subst.t option -> Subst.t -> Path.t -> address_lazy -> module_type -> module_components) let components_of_module_maker' = @@ -646,28 +546,6 @@ let strengthen = let md md_type = {md_type; md_attributes=[]; md_loc=Location.none} -let get_components_opt c = - match !can_load_cmis with - | Can_load_cmis -> - EnvLazy.force !components_of_module_maker' c.comps - | Cannot_load_cmis log -> - EnvLazy.force_logged log !components_of_module_maker' c.comps - -let empty_structure = - Structure_comps { - comp_values = NameMap.empty; - comp_constrs = NameMap.empty; - comp_labels = NameMap.empty; - comp_types = NameMap.empty; - comp_modules = NameMap.empty; comp_modtypes = NameMap.empty; - comp_components = NameMap.empty; comp_classes = NameMap.empty; - comp_cltypes = NameMap.empty } - -let get_components c = - match get_components_opt c with - | None -> empty_structure - | Some c -> c - (* Print addresses *) let rec print_address ppf = function @@ -676,90 +554,43 @@ let rec print_address ppf = function (* The name of the compilation unit currently compiled. "" if outside a compilation unit. *) +module Current_unit_name : sig + val get : unit -> modname + val set : modname -> unit + val is : modname -> bool + val is_name_of : Ident.t -> bool +end = struct + let current_unit = + ref "" + let get () = + !current_unit + let set name = + current_unit := name + let is name = + !current_unit = name + let is_name_of id = + is (Ident.name id) +end -let current_unit = ref "" +let set_unit_name = Current_unit_name.set +let get_unit_name = Current_unit_name.get let find_same_module id tbl = match IdTbl.find_same id tbl with | x -> x | exception Not_found - when Ident.persistent id && not (Ident.name id = !current_unit) -> + when Ident.persistent id && not (Current_unit_name.is_name_of id) -> Persistent -(* Persistent structure descriptions *) - -type pers_struct = - { ps_name: string; - ps_sig: signature Lazy.t; - ps_comps: module_components; - ps_crcs: (string * Digest.t option) list; - ps_filename: string; - ps_flags: pers_flags list } - -let persistent_structures = - (Hashtbl.create 17 : (string, pers_struct option) Hashtbl.t) - -(* Consistency between persistent structures *) - -let crc_units = Consistbl.create() - -let imported_units = ref String.Set.empty - -let add_import s = - imported_units := String.Set.add s !imported_units - -let imported_opaque_units = ref String.Set.empty - -let add_imported_opaque s = - imported_opaque_units := String.Set.add s !imported_opaque_units - -let clear_imports () = - Consistbl.clear crc_units; - imported_units := String.Set.empty; - imported_opaque_units := String.Set.empty - -let check_consistency ps = - try - List.iter - (fun (name, crco) -> - match crco with - None -> () - | Some crc -> - add_import name; - Consistbl.check crc_units name crc ps.ps_filename) - ps.ps_crcs; - with Consistbl.Inconsistency(name, source, auth) -> - error (Inconsistent_import(name, auth, source)) - -(* Reading persistent structures from .cmi files *) - -let save_pers_struct crc ps = - let modname = ps.ps_name in - Hashtbl.add persistent_structures modname (Some ps); - List.iter - (function - | Rectypes -> () - | Alerts _ -> () - | Unsafe_string -> () - | Opaque -> add_imported_opaque modname) - ps.ps_flags; - Consistbl.set crc_units modname crc ps.ps_filename; - add_import modname - -module Persistent_signature = struct - type t = - { filename : string; - cmi : Cmi_format.cmi_infos } - - let load = ref (fun ~unit_name -> - match Load_path.find_uncap (unit_name ^ ".cmi") with - | filename -> Some { filename; cmi = read_cmi filename } - | exception Not_found -> None) -end +(* signature of persistent compilation units *) +type persistent_module = { + pm_signature: signature Lazy.t; + pm_components: module_components; +} let add_persistent_structure id env = if not (Ident.persistent id) then invalid_arg "Env.add_persistent_structure"; - if Ident.name id <> !current_unit then + if not (Current_unit_name.is_name_of id) then { env with modules = IdTbl.add id Persistent env.modules; components = IdTbl.add id Persistent env.components; @@ -768,154 +599,91 @@ let add_persistent_structure id env = else env -let acknowledge_pers_struct check modname - { Persistent_signature.filename; cmi } = +let sign_of_cmi ~freshen { Persistent_env.Persistent_signature.cmi; _ } = let name = cmi.cmi_name in let sign = cmi.cmi_sign in - let crcs = cmi.cmi_crcs in let flags = cmi.cmi_flags in + let id = Ident.create_persistent name in + let path = Pident id in + let addr = EnvLazy.create_forced (Aident id) in let alerts = List.fold_left (fun acc -> function Alerts s -> s | _ -> acc) Misc.Stdlib.String.Map.empty flags in - let id = Ident.create_persistent name in - let path = Pident id in - let addr = EnvLazy.create_forced (Aident id) in - let comps = - !components_of_module' ~alerts ~loc:Location.none - empty (Some Subst.identity) Subst.identity path addr - (Mty_signature sign) - in - let ps = { ps_name = name; - ps_sig = lazy (Subst.signature Make_local Subst.identity sign); - ps_comps = comps; - ps_crcs = crcs; - ps_filename = filename; - ps_flags = flags; - } in - if ps.ps_name <> modname then - error (Illegal_renaming(modname, ps.ps_name, filename)); - - List.iter - (function - | Rectypes -> - if not !Clflags.recursive_types then - error (Need_recursive_types(ps.ps_name, !current_unit)) - | Unsafe_string -> - if Config.safe_string then - error (Depend_on_unsafe_string_unit (ps.ps_name, !current_unit)); - | Alerts _ -> () - | Opaque -> add_imported_opaque modname) - ps.ps_flags; - if check then check_consistency ps; - Hashtbl.add persistent_structures modname (Some ps); - ps - -let read_pers_struct check modname filename = - add_import modname; - let cmi = read_cmi filename in - acknowledge_pers_struct check modname - { Persistent_signature.filename; cmi } - -let find_pers_struct check name = - if name = "*predef*" then raise Not_found; - match Hashtbl.find persistent_structures name with - | Some ps -> ps - | None -> raise Not_found - | exception Not_found -> - match !can_load_cmis with - | Cannot_load_cmis _ -> raise Not_found - | Can_load_cmis -> - let ps = - match !Persistent_signature.load ~unit_name:name with - | Some ps -> ps - | None -> - Hashtbl.add persistent_structures name None; - raise Not_found - in - add_import name; - acknowledge_pers_struct check name ps + let loc = Location.none in + let pm_signature = lazy (Subst.signature Make_local Subst.identity sign) in + let pm_components = + let freshening_subst = + if freshen then (Some Subst.identity) else None in + !components_of_module' ~alerts ~loc + empty freshening_subst Subst.identity path addr (Mty_signature sign) in + { + pm_signature; + pm_components; + } -(* Emits a warning if there is no valid cmi for name *) -let check_pers_struct ~loc name = - try - ignore (find_pers_struct false name) - with - | Not_found -> - let warn = Warnings.No_cmi_file(name, None) in - Location.prerr_warning loc warn - | Cmi_format.Error err -> - let msg = Format.asprintf "%a" Cmi_format.report_error err in - let warn = Warnings.No_cmi_file(name, Some msg) in - Location.prerr_warning loc warn - | Error err -> - let msg = - match err with - | Illegal_renaming(name, ps_name, filename) -> - Format.asprintf - " %a@ contains the compiled interface for @ \ - %s when %s was expected" - Location.print_filename filename ps_name name - | Inconsistent_import _ -> assert false - | Need_recursive_types(name, _) -> - Format.sprintf - "%s uses recursive types" - name - | Depend_on_unsafe_string_unit (name, _) -> - Printf.sprintf "%s uses -unsafe-string" - name - | Missing_module _ -> assert false - | Illegal_value_name _ -> assert false - in - let warn = Warnings.No_cmi_file(name, Some msg) in - Location.prerr_warning loc warn - -let read_pers_struct modname filename = - read_pers_struct true modname filename - -let find_pers_struct name = - find_pers_struct true name - -let check_pers_struct ~loc name = - if not (Hashtbl.mem persistent_structures name) then begin - (* PR#6843: record the weak dependency ([add_import]) regardless of - whether the check succeeds, to help make builds more - deterministic. *) - add_import name; - if (Warnings.is_active (Warnings.No_cmi_file("", None))) then - !add_delayed_check_forward - (fun () -> check_pers_struct ~loc name) - end +let read_sign_of_cmi = sign_of_cmi ~freshen:true -let reset_cache () = - current_unit := ""; - Hashtbl.clear persistent_structures; - clear_imports (); +let save_sign_of_cmi = sign_of_cmi ~freshen:false + +let persistent_env : persistent_module Persistent_env.t = + Persistent_env.empty () + +let without_cmis f x = + Persistent_env.without_cmis persistent_env f x + +let imports () = Persistent_env.imports persistent_env + +let import_crcs ~source crcs = + Persistent_env.import_crcs persistent_env ~source crcs + +let read_pers_mod modname filename = + Persistent_env.read persistent_env read_sign_of_cmi modname filename + +let find_pers_mod name = + Persistent_env.find persistent_env read_sign_of_cmi name + +let check_pers_mod ~loc name = + Persistent_env.check persistent_env read_sign_of_cmi ~loc name + +let crc_of_unit name = + Persistent_env.crc_of_unit persistent_env read_sign_of_cmi name + +let is_imported_opaque modname = + Persistent_env.is_imported_opaque persistent_env modname + +let reset_declaration_caches () = Hashtbl.clear value_declarations; Hashtbl.clear type_declarations; Hashtbl.clear module_declarations; - Hashtbl.clear used_constructors + Hashtbl.clear used_constructors; + () + +let reset_cache () = + Current_unit_name.set ""; + Persistent_env.clear persistent_env; + reset_declaration_caches (); + () let reset_cache_toplevel () = - (* Delete 'missing cmi' entries from the cache. *) - let l = - Hashtbl.fold - (fun name r acc -> if r = None then name :: acc else acc) - persistent_structures [] - in - List.iter (Hashtbl.remove persistent_structures) l; - Hashtbl.clear value_declarations; - Hashtbl.clear type_declarations; - Hashtbl.clear module_declarations; - Hashtbl.clear used_constructors + Persistent_env.clear_missing persistent_env; + reset_declaration_caches (); + () +(* get_components *) -let set_unit_name name = - current_unit := name +let get_components_opt c = + match Persistent_env.can_load_cmis persistent_env with + | Persistent_env.Can_load_cmis -> + EnvLazy.force !components_of_module_maker' c.comps + | Persistent_env.Cannot_load_cmis log -> + EnvLazy.force_logged log !components_of_module_maker' c.comps -let get_unit_name () = - !current_unit +let get_components c = + match get_components_opt c with + | None -> empty_structure + | Some c -> c (* Lookup by identifier *) @@ -924,7 +692,7 @@ let rec find_module_descr path env = Pident id -> begin match find_same_module id env.components with | Value x -> fst x - | Persistent -> (find_pers_struct (Ident.name id)).ps_comps + | Persistent -> (find_pers_mod (Ident.name id)).pm_components end | Pdot(p, s) -> begin match get_components (find_module_descr p env) with @@ -1028,8 +796,8 @@ let find_module ~alias path env = match find_same_module id env.modules with | Value (data, _) -> EnvLazy.force subst_modtype_maker data | Persistent -> - let ps = find_pers_struct (Ident.name id) in - md (Mty_signature(Lazy.force ps.ps_sig)) + let pm = find_pers_mod (Ident.name id) in + md (Mty_signature(Lazy.force pm.pm_signature)) end | Pdot(p, s) -> begin match get_components (find_module_descr p env) with @@ -1158,8 +926,8 @@ let normalize_module_path oloc env path = with Not_found -> match oloc with None -> assert false | Some loc -> - raise (Error(Missing_module(loc, path, - normalize_module_path true env path))) + error (Missing_module(loc, path, + normalize_module_path true env path)) let normalize_path_prefix oloc env path = match path with @@ -1266,15 +1034,16 @@ let mark_module_used name loc = let rec lookup_module_descr_aux ?loc ~mark lid env = match lid with Lident s -> + let find_components s = (find_pers_mod s).pm_components in begin match IdTbl.find_name ~mark s env.components with - | exception Not_found when s <> !current_unit -> + | exception Not_found when not (Current_unit_name.is s) -> let p = Path.Pident (Ident.create_persistent s) in - (p, (find_pers_struct s).ps_comps) + (p, find_components s) | (p, data) -> (p, match data with | Value (comp, _) -> comp - | Persistent -> (find_pers_struct s).ps_comps) + | Persistent -> find_components s) end | Ldot(l, s) -> let (p, descr) = lookup_module_descr ?loc ~mark l env in @@ -1314,8 +1083,11 @@ and lookup_module ~load ?loc ~mark lid env : Path.t = match lid with Lident s -> begin match IdTbl.find_name ~mark s env.modules with - | exception Not_found when !Clflags.transparent_modules && not load -> - check_pers_struct s + | exception Not_found + when not (Current_unit_name.is s) + && !Clflags.transparent_modules + && not load -> + check_pers_mod s ~loc:(Option.value loc ~default:Location.none); Path.Pident (Ident.create_persistent s) | p, data -> @@ -1335,11 +1107,11 @@ and lookup_module ~load ?loc ~mark lid env : Path.t = (Builtin_attributes.alerts_of_attrs md_attributes) | Persistent -> if !Clflags.transparent_modules && not load then - check_pers_struct s + check_pers_mod s ~loc:(Option.value loc ~default:Location.none) else begin - let ps = find_pers_struct s in - report_alerts ?loc p ps.ps_comps.alerts + let pm = find_pers_mod s in + report_alerts ?loc p pm.pm_components.alerts end end; p @@ -1633,7 +1405,8 @@ let rec scrape_alias_for_visit env sub mty = begin match may_subst Subst.module_path sub path with | Pident id when Ident.persistent id - && not (Hashtbl.mem persistent_structures (Ident.name id)) -> false + && not (Persistent_env.looked_up persistent_env (Ident.name id)) -> + false | path -> (* PR#6600: find_module may raise Not_found *) try scrape_alias_for_visit env sub (find_module path env).md_type with Not_found -> false @@ -1668,9 +1441,10 @@ let iter_env proj1 proj2 f env () = match comps with | Value (comps, _) -> iter_components (Pident id) path comps | Persistent -> - match Hashtbl.find persistent_structures (Ident.name id) with - | exception Not_found | None -> () - | Some ps -> iter_components (Pident id) path ps.ps_comps) + let modname = Ident.name id in + match Persistent_env.find_in_cache persistent_env modname with + | None -> () + | Some pm -> iter_components (Pident id) path pm.pm_components) env.components let run_iter_cont l = @@ -1686,10 +1460,9 @@ let same_types env1 env2 = env1.types == env2.types && env1.components == env2.components let used_persistent () = - let r = ref Concr.empty in - Hashtbl.iter (fun s pso -> if pso != None then r := Concr.add s !r) - persistent_structures; - !r + Persistent_env.fold persistent_env + (fun s _m r -> Concr.add s r) + Concr.empty let find_all_comps proj s (p,(mcomps, _)) = match get_components mcomps with @@ -2037,7 +1810,7 @@ and check_value_name name loc = if String.length name > 0 && (name.[0] = '#') then for i = 1 to String.length name - 1 do if name.[i] = '#' then - raise (Error(Illegal_value_name(loc, name))) + error (Illegal_value_name(loc, name)) done @@ -2426,10 +2199,9 @@ let open_signature else open_signature None root env (* Read a signature from a file *) - let read_signature modname filename = - let ps = read_pers_struct modname filename in - Lazy.force ps.ps_sig + let pm = read_pers_mod modname filename in + Lazy.force pm.pm_signature let is_identchar_latin1 = function | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246' @@ -2455,80 +2227,28 @@ let persistent_structures_of_dir dir = |> Seq.filter_map unit_name_of_filename |> String.Set.of_seq -(* Return the CRC of the interface of the given compilation unit *) - -let crc_of_unit name = - let ps = find_pers_struct name in - let crco = - try - List.assoc name ps.ps_crcs - with Not_found -> - assert false - in - match crco with - None -> assert false - | Some crc -> crc - -(* Return the list of imported interfaces with their CRCs *) - -let imports () = - Consistbl.extract (String.Set.elements !imported_units) crc_units - -(* Returns true if [s] is an opaque imported module *) -let is_imported_opaque s = - String.Set.mem s !imported_opaque_units - (* Save a signature to a file *) - -let save_signature_with_imports ~alerts sg modname filename imports = - (*prerr_endline filename; - List.iter (fun (name, crc) -> prerr_endline name) imports;*) +let save_signature_with_transform cmi_transform ~alerts sg modname filename = Btype.cleanup_abbrev (); Subst.reset_for_saving (); let sg = Subst.signature Make_local (Subst.for_saving Subst.identity) sg in - let flags = - List.concat [ - if !Clflags.recursive_types then [Cmi_format.Rectypes] else []; - if !Clflags.opaque then [Cmi_format.Opaque] else []; - (if !Clflags.unsafe_string then [Cmi_format.Unsafe_string] else []); - [Alerts alerts]; - ] - in - Misc.try_finally (fun () -> - let cmi = { - cmi_name = modname; - cmi_sign = sg; - cmi_crcs = imports; - cmi_flags = flags; - } in - let crc = - output_to_file_via_temporary (* see MPR#7472, MPR#4991 *) - ~mode: [Open_binary] filename - (fun temp_filename oc -> output_cmi temp_filename oc cmi) in - (* Enter signature in persistent table so that imported_unit() - will also return its crc *) - let id = Ident.create_persistent modname in - let path = Pident id in - let addr = EnvLazy.create_forced (Aident id) in - let comps = - components_of_module ~alerts ~loc:Location.none - empty None Subst.identity path addr (Mty_signature sg) - in - let ps = - { ps_name = modname; - ps_sig = lazy (Subst.signature Make_local Subst.identity sg); - ps_comps = comps; - ps_crcs = (cmi.cmi_name, Some crc) :: imports; - ps_filename = filename; - ps_flags = cmi.cmi_flags; - } in - save_pers_struct crc ps; - cmi - ) - ~exceptionally:(fun () -> remove_file filename) + let cmi = + Persistent_env.make_cmi persistent_env modname sg alerts + |> cmi_transform in + let pm = save_sign_of_cmi + { Persistent_env.Persistent_signature.cmi; filename } in + Persistent_env.save_cmi persistent_env + { Persistent_env.Persistent_signature.filename; cmi } pm; + cmi let save_signature ~alerts sg modname filename = - save_signature_with_imports ~alerts sg modname filename (imports()) + save_signature_with_transform (fun cmi -> cmi) + ~alerts sg modname filename + +let save_signature_with_imports ~alerts sg modname filename imports = + let with_imports cmi = { cmi with cmi_crcs = imports } in + save_signature_with_transform with_imports + ~alerts sg modname filename (* Folding on environments *) @@ -2579,10 +2299,11 @@ let fold_modules f lid env acc = let data = EnvLazy.force subst_modtype_maker data in f name p data acc | Persistent -> - match Hashtbl.find persistent_structures name with - | exception Not_found | None -> acc - | Some ps -> - f name p (md (Mty_signature (Lazy.force ps.ps_sig))) acc) + match Persistent_env.find_in_cache persistent_env name with + | None -> acc + | Some pm -> + let data = md (Mty_signature (Lazy.force pm.pm_signature)) in + f name p data acc) env.modules acc | Some l -> @@ -2624,9 +2345,9 @@ let filter_non_loaded_persistent f env = match data with | Value _ -> acc | Persistent -> - match Hashtbl.find persistent_structures name with + match Persistent_env.find_in_cache persistent_env name with | Some _ -> acc - | exception Not_found | None -> + | None -> if f (Ident.create_persistent name) then acc else @@ -2725,23 +2446,6 @@ let env_of_only_summary env_from_summary env = open Format let report_error ppf = function - | Illegal_renaming(modname, ps_name, filename) -> fprintf ppf - "Wrong file naming: %a@ contains the compiled interface for @ \ - %s when %s was expected" - Location.print_filename filename ps_name modname - | Inconsistent_import(name, source1, source2) -> fprintf ppf - "@[The files %a@ and %a@ \ - make inconsistent assumptions@ over interface %s@]" - Location.print_filename source1 Location.print_filename source2 name - | Need_recursive_types(import, export) -> - fprintf ppf - "@[Unit %s imports from %s, which uses recursive types.@ %s@]" - export import "The compilation flag -rectypes is required" - | Depend_on_unsafe_string_unit(import, export) -> - fprintf ppf - "@[Unit %s imports from %s, compiled with -unsafe-string.@ %s@]" - export import "This compiler has been configured in strict \ - safe-string mode (-force-safe-string)" | Missing_module(_, path1, path2) -> fprintf ppf "@[@["; if Path.same path1 path2 then @@ -2759,10 +2463,15 @@ let report_error ppf = function let () = Location.register_error_of_exn (function - | Error (Missing_module (loc, _, _) - | Illegal_value_name (loc, _) - as err) when loc <> Location.none -> - Some (Location.error_of_printer ~loc report_error err) - | Error err -> Some (Location.error_of_printer_file report_error err) - | _ -> None + | Error err -> + let loc = match err with + (Missing_module (loc, _, _) | Illegal_value_name (loc, _)) -> loc + in + let error_of_printer = + if loc = Location.none + then Location.error_of_printer_file + else Location.error_of_printer ~loc ?sub:None in + Some (error_of_printer report_error err) + | _ -> + None ) diff --git a/typing/env.mli b/typing/env.mli index 9fd1e8fd..cf7490db 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -16,6 +16,7 @@ (* Environment handling *) open Types +open Misc type summary = Env_empty @@ -59,8 +60,8 @@ val same_types: t -> t -> bool val used_persistent: unit -> Concr.t val find_shadowed_types: Path.t -> t -> Path.t list val without_cmis: ('a -> 'b) -> 'a -> 'b - (* [without_cmis f arg] applies [f] to [arg], but does not - allow opening cmis during its execution *) +(* [without_cmis f arg] applies [f] to [arg], but does not + allow opening cmis during its execution *) (* Lookup by paths *) @@ -238,35 +239,29 @@ val set_unit_name: string -> unit val get_unit_name: unit -> string (* Read, save a signature to/from a file *) - -val read_signature: string -> string -> signature +val read_signature: modname -> filepath -> signature (* Arguments: module name, file name. Results: signature. *) val save_signature: - alerts:string Misc.Stdlib.String.Map.t -> signature -> string -> string -> - Cmi_format.cmi_infos + alerts:alerts -> signature -> modname -> filepath + -> Cmi_format.cmi_infos (* Arguments: signature, module name, file name. *) val save_signature_with_imports: - alerts:string Misc.Stdlib.String.Map.t -> - signature -> string -> string -> (string * Digest.t option) list + alerts:alerts -> signature -> modname -> filepath -> crcs -> Cmi_format.cmi_infos (* Arguments: signature, module name, file name, imported units with their CRCs. *) (* Return the CRC of the interface of the given compilation unit *) - -val crc_of_unit: string -> Digest.t +val crc_of_unit: modname -> Digest.t (* Return the set of compilation units imported, with their CRC *) +val imports: unit -> crcs -val imports: unit -> (string * Digest.t option) list +(* may raise Persistent_env.Consistbl.Inconsistency *) +val import_crcs: source:string -> crcs -> unit (* [is_imported_opaque md] returns true if [md] is an opaque imported module *) -val is_imported_opaque: string -> bool - -(* Direct access to the table of imported compilation units with their CRC *) - -val crc_units: Consistbl.t -val add_import: string -> unit +val is_imported_opaque: modname -> bool (* Summaries -- compact representation of an environment, to be exported in debugging information. *) @@ -283,10 +278,6 @@ val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t (* Error report *) type error = - | Illegal_renaming of string * string * string - | Inconsistent_import of string * string * string - | Need_recursive_types of string * string - | Depend_on_unsafe_string_unit of string * string | Missing_module of Location.t * Path.t * Path.t | Illegal_value_name of Location.t * string @@ -367,14 +358,3 @@ val scrape_alias: t -> module_type -> module_type val check_value_name: string -> Location.t -> unit val print_address : Format.formatter -> address -> unit - -module Persistent_signature : sig - type t = - { filename : string; (** Name of the file containing the signature. *) - cmi : Cmi_format.cmi_infos } - - (** Function used to load a persistent signature. The default is to look for - the .cmi file in the load path. This function can be overridden to load - it from memory, for instance to build a self-contained toplevel. *) - val load : (unit_name:string -> t option) ref -end diff --git a/typing/includecore.ml b/typing/includecore.ml index 98e99b8c..b5311b11 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -364,20 +364,22 @@ let extension_constructors ~loc env ~mark id ext1 ext2 = in if not (Ctype.equal env true (ty1 :: ext1.ext_type_params) (ty2 :: ext2.ext_type_params)) - then Some (Field_type id) - else - let r = - compare_constructor_arguments ~loc env id - ext1.ext_type_params ext2.ext_type_params - ext1.ext_args ext2.ext_args - in - if r <> None then r else + then Some (Field_type id) else + let r = match ext1.ext_ret_type, ext2.ext_ret_type with - Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> - Some (Field_type id) + | Some r1, Some r2 -> + if Ctype.equal env true [r1] [r2] then + compare_constructor_arguments ~loc env id [r1] [r2] + ext1.ext_args ext2.ext_args + else Some (Field_type id) | Some _, None | None, Some _ -> Some (Field_type id) - | _ -> - match ext1.ext_private, ext2.ext_private with - Private, Public -> Some Privacy - | _, _ -> None + | None, None -> + compare_constructor_arguments ~loc env id + ext1.ext_type_params ext2.ext_type_params + ext1.ext_args ext2.ext_args + in + if r <> None then r else + match ext1.ext_private, ext2.ext_private with + | Private, Public -> Some Privacy + | _, _ -> None diff --git a/typing/includemod.ml b/typing/includemod.ml index 670dd947..01790075 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -28,7 +28,7 @@ type symptom = * extension_constructor * Includecore.type_mismatch | Module_types of module_type * module_type | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration - | Modtype_permutation + | Modtype_permutation of Types.module_type * Typedtree.module_coercion | Interface_mismatch of string * string | Class_type_declarations of Ident.t * class_type_declaration * class_type_declaration * @@ -522,10 +522,10 @@ and check_modtype_equiv ~loc env ~mark cxt mty1 mty2 = modtypes ~loc env ~mark:(negate_mark mark) cxt Subst.identity mty2 mty1) with (Tcoerce_none, Tcoerce_none) -> () - | (_c1, _c2) -> + | (c1, _c2) -> (* Format.eprintf "@[c1 = %a@ c2 = %a@]@." print_coercion _c1 print_coercion _c2; *) - raise(Error [cxt, env, Modtype_permutation]) + raise(Error [cxt, env, Modtype_permutation (mty1, c1)]) (* Simplified inclusion check between module types (for Env) *) @@ -578,6 +578,107 @@ let modtypes env m1 m2 = (* Error report *) +module Illegal_permutation = struct + (** Extraction of information in case of illegal permutation + in a module type *) + + (** When examining coercions, we only have runtime component indices, + we use thus a limited version of {!pos}. *) + type coerce_pos = + | Item of int + | InArg + | InBody + + let either f x g y = match f x with + | None -> g y + | Some _ as v -> v + + (** We extract a lone transposition from a full tree of permutations. *) + let rec transposition_under path = function + | Tcoerce_structure(c,_) -> + either + (not_fixpoint path 0) c + (first_non_id path 0) c + | Tcoerce_functor(arg,res) -> + either + (transposition_under (InArg::path)) arg + (transposition_under (InBody::path)) res + | Tcoerce_none -> None + | Tcoerce_alias _ | Tcoerce_primitive _ -> + (* these coercions are not inversible, and raise an error earlier when + checking for module type equivalence *) + assert false + (* we search the first point which is not invariant at the current level *) + and not_fixpoint path pos = function + | [] -> None + | (n, _) :: q -> + if n = pos then + not_fixpoint path (pos+1) q + else + Some(List.rev path, pos, n) + (* we search the first item with a non-identity inner coercion *) + and first_non_id path pos = function + | [] -> None + | (_,Tcoerce_none) :: q -> first_non_id path (pos + 1) q + | (_,c) :: q -> + either + (transposition_under (Item pos :: path)) c + (first_non_id path (pos + 1)) q + + let transposition c = + match transposition_under [] c with + | None -> raise Not_found + | Some x -> x + + let rec runtime_item k = function + | [] -> raise Not_found + | item :: q -> + if not(is_runtime_component item) then + runtime_item k q + else if k = 0 then + item + else + runtime_item (k-1) q + + (* Find module type at position [path] and convert the [coerce_pos] path to + a [pos] path *) + let rec find env ctx path mt = match mt, path with + | (Mty_ident p | Mty_alias p), _ -> + begin match (Env.find_modtype p env).mtd_type with + | None -> raise Not_found + | Some mt -> find env ctx path mt + end + | Mty_signature s , [] -> List.rev ctx, s + | Mty_signature s, Item k :: q -> + begin match runtime_item k s with + | Sig_module (id, _, md,_,_) -> find env (Module id :: ctx) q md.md_type + | _ -> raise Not_found + end + | Mty_functor(x,Some mt,_), InArg :: q -> find env (Arg x :: ctx) q mt + | Mty_functor(x,_,mt), InBody :: q -> find env (Body x :: ctx) q mt + | _ -> raise Not_found + + let find env path mt = find env [] path mt + let item mt k = item_ident_name (runtime_item k mt) + + let pp_item ppf (id,_,kind) = + Format.fprintf ppf "%s %S" (kind_of_field_desc kind) (Ident.name id) + + let pp ctx_printer env ppf (mty,c) = + try + let p, k, l = transposition c in + let ctx, mt = find env p mty in + Format.fprintf ppf + "@[Illegal permutation of runtime components in a module type.@ \ + @[For example,@ %a@[the %a@ and the %a are not in the same order@ \ + in the expected and actual module types.@]@]" + ctx_printer ctx pp_item (item mt k) pp_item (item mt l) + with Not_found -> (* this should not happen *) + Format.fprintf ppf + "Illegal permutation of runtime components in a module type." + +end + open Format let show_loc msg ppf loc = @@ -589,7 +690,58 @@ let show_locs ppf (loc1, loc2) = show_loc "Expected declaration" ppf loc2; show_loc "Actual declaration" ppf loc1 -let include_err ppf = function +let path_of_context = function + Module id :: rem -> + let rec subm path = function + | [] -> path + | Module id :: rem -> subm (Path.Pdot (path, Ident.name id)) rem + | _ -> assert false + in subm (Path.Pident id) rem + | _ -> assert false + + +let rec context ppf = function + Module id :: rem -> + fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem + | Modtype id :: rem -> + fprintf ppf "@[<2>module type %a =@ %a@]" + Printtyp.ident id context_mty rem + | Body x :: rem -> + fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem + | Arg x :: rem -> + fprintf ppf "functor (%a : %a) -> ..." Printtyp.ident x context_mty rem + | [] -> + fprintf ppf "" +and context_mty ppf = function + (Module _ | Modtype _) :: _ as rem -> + fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem + | cxt -> context ppf cxt +and args ppf = function + Body x :: rem -> + fprintf ppf "(%s)%a" (argname x) args rem + | Arg x :: rem -> + fprintf ppf "(%a :@ %a) : ..." Printtyp.ident x context_mty rem + | cxt -> + fprintf ppf " :@ %a" context_mty cxt +and argname x = + let s = Ident.name x in + if s = "*" then "" else s + +let alt_context ppf cxt = + if cxt = [] then () else + if List.for_all (function Module _ -> true | _ -> false) cxt then + fprintf ppf "in module %a,@ " Printtyp.path (path_of_context cxt) + else + fprintf ppf "@[at position@ %a,@]@ " context cxt + +let context ppf cxt = + if cxt = [] then () else + if List.for_all (function Module _ -> true | _ -> false) cxt then + fprintf ppf "In module %a:@ " Printtyp.path (path_of_context cxt) + else + fprintf ppf "@[At position@ %a@]@ " context cxt + +let include_err env ppf = function | Missing_field (id, loc, kind) -> fprintf ppf "The %s `%a' is required but not provided" kind Printtyp.ident id; @@ -634,8 +786,8 @@ let include_err ppf = function %a@;<1 -2>does not match@ %a@]" !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d1) !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d2) - | Modtype_permutation -> - fprintf ppf "Illegal permutation of structure fields" + | Modtype_permutation (mty,c) -> + Illegal_permutation.pp alt_context env ppf (mty,c) | Interface_mismatch(impl_name, intf_name) -> fprintf ppf "@[The implementation %s@ does not match the interface %s:" impl_name intf_name @@ -662,52 +814,9 @@ let include_err ppf = function | Invalid_module_alias path -> fprintf ppf "Module %a cannot be aliased" Printtyp.path path -let rec context ppf = function - Module id :: rem -> - fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem - | Modtype id :: rem -> - fprintf ppf "@[<2>module type %a =@ %a@]" - Printtyp.ident id context_mty rem - | Body x :: rem -> - fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem - | Arg x :: rem -> - fprintf ppf "functor (%a : %a) -> ..." Printtyp.ident x context_mty rem - | [] -> - fprintf ppf "" -and context_mty ppf = function - (Module _ | Modtype _) :: _ as rem -> - fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem - | cxt -> context ppf cxt -and args ppf = function - Body x :: rem -> - fprintf ppf "(%s)%a" (argname x) args rem - | Arg x :: rem -> - fprintf ppf "(%a :@ %a) : ..." Printtyp.ident x context_mty rem - | cxt -> - fprintf ppf " :@ %a" context_mty cxt -and argname x = - let s = Ident.name x in - if s = "*" then "" else s - -let path_of_context = function - Module id :: rem -> - let rec subm path = function - | [] -> path - | Module id :: rem -> subm (Path.Pdot (path, Ident.name id)) rem - | _ -> assert false - in subm (Path.Pident id) rem - | _ -> assert false - -let context ppf cxt = - if cxt = [] then () else - if List.for_all (function Module _ -> true | _ -> false) cxt then - fprintf ppf "In module %a:@ " Printtyp.path (path_of_context cxt) - else - fprintf ppf "@[At position@ %a@]@ " context cxt - let include_err ppf (cxt, env, err) = Printtyp.wrap_printing_env ~error:true env (fun () -> - fprintf ppf "@[%a%a@]" context (List.rev cxt) include_err err) + fprintf ppf "@[%a%a@]" context (List.rev cxt) (include_err env) err) let buffer = ref Bytes.empty let is_big obj = diff --git a/typing/includemod.mli b/typing/includemod.mli index 1996894e..f7ce4de7 100644 --- a/typing/includemod.mli +++ b/typing/includemod.mli @@ -64,7 +64,7 @@ type symptom = * extension_constructor * Includecore.type_mismatch | Module_types of module_type * module_type | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration - | Modtype_permutation + | Modtype_permutation of Types.module_type * Typedtree.module_coercion | Interface_mismatch of string * string | Class_type_declarations of Ident.t * class_type_declaration * class_type_declaration * diff --git a/typing/oprint.ml b/typing/oprint.ml index ed6a4dbf..0db53346 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -717,7 +717,9 @@ let print_out_exception ppf exn outv = | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@." | Stack_overflow -> fprintf ppf "Stack overflow during evaluation (looping recursion?).@." - | _ -> fprintf ppf "@[Exception:@ %a.@]@." !out_value outv + | _ -> match Printexc.use_printers exn with + | None -> fprintf ppf "@[Exception:@ %a.@]@." !out_value outv + | Some s -> fprintf ppf "@[Exception:@ %s@]@." s let rec print_items ppf = function diff --git a/typing/parmatch.ml b/typing/parmatch.ml index ccf0dd35..74873f7b 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -2440,37 +2440,35 @@ let pattern_stable_vars ns p = let all_rhs_idents exp = let ids = ref Ident.Set.empty in - let module Iterator = TypedtreeIter.MakeIterator(struct - include TypedtreeIter.DefaultIteratorArgument - let enter_expression exp = match exp.exp_desc with - | Texp_ident (path, _lid, _descr) -> - List.iter - (fun id -> ids := Ident.Set.add id !ids) - (Path.heads path) - | _ -> () - (* Very hackish, detect unpack pattern compilation and perform "indirect check for them" *) - let is_unpack exp = + let is_unpack exp = List.exists (fun attr -> attr.Parsetree.attr_name.txt = "#modulepat") - exp.exp_attributes - - let leave_expression exp = - if is_unpack exp then begin match exp.exp_desc with - | Texp_letmodule - (id_mod,_,_, - {mod_desc= - Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)}, - _) -> - assert (Ident.Set.mem id_exp !ids) ; - if not (Ident.Set.mem id_mod !ids) then begin - ids := Ident.Set.remove id_exp !ids - end - | _ -> assert false - end - end) in - Iterator.iter_expression exp; + exp.exp_attributes in + let open Tast_iterator in + let expr_iter iter exp = + (match exp.exp_desc with + | Texp_ident (path, _lid, _descr) -> + List.iter (fun id -> ids := Ident.Set.add id !ids) (Path.heads path) + (* Use default iterator methods for rest of match.*) + | _ -> Tast_iterator.default_iterator.expr iter exp); + + if is_unpack exp then begin match exp.exp_desc with + | Texp_letmodule + (id_mod,_,_, + {mod_desc= + Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)}, + _) -> + assert (Ident.Set.mem id_exp !ids) ; + if not (Ident.Set.mem id_mod !ids) then begin + ids := Ident.Set.remove id_exp !ids + end + | _ -> assert false + end + in + let iterator = {Tast_iterator.default_iterator with expr = expr_iter} in + iterator.expr iterator exp; !ids let check_ambiguous_bindings = diff --git a/typing/persistent_env.ml b/typing/persistent_env.ml new file mode 100644 index 00000000..29807e05 --- /dev/null +++ b/typing/persistent_env.ml @@ -0,0 +1,369 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* *) +(* Copyright 2019 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Persistent structure descriptions *) + +open Misc +open Cmi_format + +module Consistbl = Consistbl.Make (Misc.Stdlib.String) + +let add_delayed_check_forward = ref (fun _ -> assert false) + +type error = + | Illegal_renaming of modname * modname * filepath + | Inconsistent_import of modname * filepath * filepath + | Need_recursive_types of modname + | Depend_on_unsafe_string_unit of modname + +exception Error of error +let error err = raise (Error err) + +module Persistent_signature = struct + type t = + { filename : string; + cmi : Cmi_format.cmi_infos } + + let load = ref (fun ~unit_name -> + match Load_path.find_uncap (unit_name ^ ".cmi") with + | filename -> Some { filename; cmi = read_cmi filename } + | exception Not_found -> None) +end + +type can_load_cmis = + | Can_load_cmis + | Cannot_load_cmis of EnvLazy.log + +type pers_struct = { + ps_name: string; + ps_crcs: (string * Digest.t option) list; + ps_filename: string; + ps_flags: pers_flags list; +} + +module String = Misc.Stdlib.String + +(* If a .cmi file is missing (or invalid), we + store it as Missing in the cache. *) +type 'a pers_struct_info = + | Missing + | Found of pers_struct * 'a + +type 'a t = { + persistent_structures : (string, 'a pers_struct_info) Hashtbl.t; + imported_units: String.Set.t ref; + imported_opaque_units: String.Set.t ref; + crc_units: Consistbl.t; + can_load_cmis: can_load_cmis ref; +} + +let empty () = { + persistent_structures = Hashtbl.create 17; + imported_units = ref String.Set.empty; + imported_opaque_units = ref String.Set.empty; + crc_units = Consistbl.create (); + can_load_cmis = ref Can_load_cmis; +} + +let clear penv = + let { + persistent_structures; + imported_units; + imported_opaque_units; + crc_units; + can_load_cmis; + } = penv in + Hashtbl.clear persistent_structures; + imported_units := String.Set.empty; + imported_opaque_units := String.Set.empty; + Consistbl.clear crc_units; + can_load_cmis := Can_load_cmis; + () + +let clear_missing {persistent_structures; _} = + let missing_entries = + Hashtbl.fold + (fun name r acc -> if r = Missing then name :: acc else acc) + persistent_structures [] + in + List.iter (Hashtbl.remove persistent_structures) missing_entries + +let add_import {imported_units; _} s = + imported_units := String.Set.add s !imported_units + +let add_imported_opaque {imported_opaque_units; _} s = + imported_opaque_units := String.Set.add s !imported_opaque_units + +let find_in_cache {persistent_structures; _} s = + match Hashtbl.find persistent_structures s with + | exception Not_found -> None + | Missing -> None + | Found (_ps, pm) -> Some pm + +let import_crcs penv ~source crcs = + let {crc_units; _} = penv in + let import_crc (name, crco) = + match crco with + | None -> () + | Some crc -> + add_import penv name; + Consistbl.check crc_units name crc source + in List.iter import_crc crcs + +let check_consistency penv ps = + try import_crcs penv ~source:ps.ps_filename ps.ps_crcs + with Consistbl.Inconsistency(name, source, auth) -> + error (Inconsistent_import(name, auth, source)) + +let can_load_cmis penv = + !(penv.can_load_cmis) +let set_can_load_cmis penv setting = + penv.can_load_cmis := setting + +let without_cmis penv f x = + let log = EnvLazy.log () in + let res = + Misc.(protect_refs + [R (penv.can_load_cmis, Cannot_load_cmis log)] + (fun () -> f x)) + in + EnvLazy.backtrack log; + res + +let fold {persistent_structures; _} f x = + Hashtbl.fold (fun modname pso x -> match pso with + | Missing -> x + | Found (_, pm) -> f modname pm x) + persistent_structures x + +(* Reading persistent structures from .cmi files *) + +let save_pers_struct penv crc ps pm = + let {persistent_structures; crc_units; _} = penv in + let modname = ps.ps_name in + Hashtbl.add persistent_structures modname (Found (ps, pm)); + List.iter + (function + | Rectypes -> () + | Alerts _ -> () + | Unsafe_string -> () + | Opaque -> add_imported_opaque penv modname) + ps.ps_flags; + Consistbl.set crc_units modname crc ps.ps_filename; + add_import penv modname + +let acknowledge_pers_struct penv check modname pers_sig pm = + let { Persistent_signature.filename; cmi } = pers_sig in + let name = cmi.cmi_name in + let crcs = cmi.cmi_crcs in + let flags = cmi.cmi_flags in + let ps = { ps_name = name; + ps_crcs = crcs; + ps_filename = filename; + ps_flags = flags; + } in + if ps.ps_name <> modname then + error (Illegal_renaming(modname, ps.ps_name, filename)); + List.iter + (function + | Rectypes -> + if not !Clflags.recursive_types then + error (Need_recursive_types(ps.ps_name)) + | Unsafe_string -> + if Config.safe_string then + error (Depend_on_unsafe_string_unit(ps.ps_name)); + | Alerts _ -> () + | Opaque -> add_imported_opaque penv modname) + ps.ps_flags; + if check then check_consistency penv ps; + let {persistent_structures; _} = penv in + Hashtbl.add persistent_structures modname (Found (ps, pm)); + ps + +let read_pers_struct penv val_of_pers_sig check modname filename = + add_import penv modname; + let cmi = read_cmi filename in + let pers_sig = { Persistent_signature.filename; cmi } in + let pm = val_of_pers_sig pers_sig in + let ps = acknowledge_pers_struct penv check modname pers_sig pm in + (ps, pm) + +let find_pers_struct penv val_of_pers_sig check name = + let {persistent_structures; _} = penv in + if name = "*predef*" then raise Not_found; + match Hashtbl.find persistent_structures name with + | Found (ps, pm) -> (ps, pm) + | Missing -> raise Not_found + | exception Not_found -> + match can_load_cmis penv with + | Cannot_load_cmis _ -> raise Not_found + | Can_load_cmis -> + let psig = + match !Persistent_signature.load ~unit_name:name with + | Some psig -> psig + | None -> + Hashtbl.add persistent_structures name Missing; + raise Not_found + in + add_import penv name; + let pm = val_of_pers_sig psig in + let ps = acknowledge_pers_struct penv check name psig pm in + (ps, pm) + +(* Emits a warning if there is no valid cmi for name *) +let check_pers_struct penv f ~loc name = + try + ignore (find_pers_struct penv f false name) + with + | Not_found -> + let warn = Warnings.No_cmi_file(name, None) in + Location.prerr_warning loc warn + | Cmi_format.Error err -> + let msg = Format.asprintf "%a" Cmi_format.report_error err in + let warn = Warnings.No_cmi_file(name, Some msg) in + Location.prerr_warning loc warn + | Error err -> + let msg = + match err with + | Illegal_renaming(name, ps_name, filename) -> + Format.asprintf + " %a@ contains the compiled interface for @ \ + %s when %s was expected" + Location.print_filename filename ps_name name + | Inconsistent_import _ -> assert false + | Need_recursive_types name -> + Format.sprintf + "%s uses recursive types" + name + | Depend_on_unsafe_string_unit name -> + Printf.sprintf "%s uses -unsafe-string" + name + in + let warn = Warnings.No_cmi_file(name, Some msg) in + Location.prerr_warning loc warn + +let read penv f modname filename = + snd (read_pers_struct penv f true modname filename) + +let find penv f name = + snd (find_pers_struct penv f true name) + +let check penv f ~loc name = + let {persistent_structures; _} = penv in + if not (Hashtbl.mem persistent_structures name) then begin + (* PR#6843: record the weak dependency ([add_import]) regardless of + whether the check succeeds, to help make builds more + deterministic. *) + add_import penv name; + if (Warnings.is_active (Warnings.No_cmi_file("", None))) then + !add_delayed_check_forward + (fun () -> check_pers_struct penv f ~loc name) + end + +let crc_of_unit penv f name = + let (ps, _pm) = find_pers_struct penv f true name in + let crco = + try + List.assoc name ps.ps_crcs + with Not_found -> + assert false + in + match crco with + None -> assert false + | Some crc -> crc + +let imports {imported_units; crc_units; _} = + Consistbl.extract (String.Set.elements !imported_units) crc_units + +let looked_up {persistent_structures; _} modname = + Hashtbl.mem persistent_structures modname + +let is_imported {imported_units; _} s = + String.Set.mem s !imported_units + +let is_imported_opaque {imported_opaque_units; _} s = + String.Set.mem s !imported_opaque_units + +let make_cmi penv modname sign alerts = + let flags = + List.concat [ + if !Clflags.recursive_types then [Cmi_format.Rectypes] else []; + if !Clflags.opaque then [Cmi_format.Opaque] else []; + (if !Clflags.unsafe_string then [Cmi_format.Unsafe_string] else []); + [Alerts alerts]; + ] + in + let crcs = imports penv in + { + cmi_name = modname; + cmi_sign = sign; + cmi_crcs = crcs; + cmi_flags = flags + } + +let save_cmi penv psig pm = + let { Persistent_signature.filename; cmi } = psig in + Misc.try_finally (fun () -> + let { + cmi_name = modname; + cmi_sign = _; + cmi_crcs = imports; + cmi_flags = flags; + } = cmi in + let crc = + output_to_file_via_temporary (* see MPR#7472, MPR#4991 *) + ~mode: [Open_binary] filename + (fun temp_filename oc -> output_cmi temp_filename oc cmi) in + (* Enter signature in persistent table so that imports() + will also return its crc *) + let ps = + { ps_name = modname; + ps_crcs = (cmi.cmi_name, Some crc) :: imports; + ps_filename = filename; + ps_flags = flags; + } in + save_pers_struct penv crc ps pm + ) + ~exceptionally:(fun () -> remove_file filename) + +let report_error ppf = + let open Format in + function + | Illegal_renaming(modname, ps_name, filename) -> fprintf ppf + "Wrong file naming: %a@ contains the compiled interface for @ \ + %s when %s was expected" + Location.print_filename filename ps_name modname + | Inconsistent_import(name, source1, source2) -> fprintf ppf + "@[The files %a@ and %a@ \ + make inconsistent assumptions@ over interface %s@]" + Location.print_filename source1 Location.print_filename source2 name + | Need_recursive_types(import) -> + fprintf ppf + "@[Invalid import of %s, which uses recursive types.@ %s@]" + import "The compilation flag -rectypes is required" + | Depend_on_unsafe_string_unit(import) -> + fprintf ppf + "@[Invalid import of %s, compiled with -unsafe-string.@ %s@]" + import "This compiler has been configured in strict \ + safe-string mode (-force-safe-string)" + +let () = + Location.register_error_of_exn + (function + | Error err -> + Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/typing/persistent_env.mli b/typing/persistent_env.mli new file mode 100644 index 00000000..765a7b02 --- /dev/null +++ b/typing/persistent_env.mli @@ -0,0 +1,101 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* *) +(* Copyright 2019 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Misc + +module Consistbl : module type of struct + include Consistbl.Make (Misc.Stdlib.String) +end + +type error = + | Illegal_renaming of modname * modname * filepath + | Inconsistent_import of modname * filepath * filepath + | Need_recursive_types of modname + | Depend_on_unsafe_string_unit of modname + +exception Error of error + +val report_error: Format.formatter -> error -> unit + +module Persistent_signature : sig + type t = + { filename : string; (** Name of the file containing the signature. *) + cmi : Cmi_format.cmi_infos } + + (** Function used to load a persistent signature. The default is to look for + the .cmi file in the load path. This function can be overridden to load + it from memory, for instance to build a self-contained toplevel. *) + val load : (unit_name:string -> t option) ref +end + +type can_load_cmis = + | Can_load_cmis + | Cannot_load_cmis of Misc.EnvLazy.log + +type 'a t + +val empty : unit -> 'a t + +val clear : 'a t -> unit +val clear_missing : 'a t -> unit + +val fold : 'a t -> (modname -> 'a -> 'b -> 'b) -> 'b -> 'b + +val read : 'a t -> (Persistent_signature.t -> 'a) + -> modname -> filepath -> 'a +val find : 'a t -> (Persistent_signature.t -> 'a) + -> modname -> 'a + +val find_in_cache : 'a t -> modname -> 'a option + +val check : 'a t -> (Persistent_signature.t -> 'a) + -> loc:Location.t -> modname -> unit + +(* [looked_up penv md] checks if one has already tried + to read the signature for [md] in the environment + [penv] (it may have failed) *) +val looked_up : 'a t -> modname -> bool + +(* [is_imported penv md] checks if [md] has been succesfully + imported in the environment [penv] *) +val is_imported : 'a t -> modname -> bool + +(* [is_imported_opaque penv md] checks if [md] has been imported + in [penv] as an opaque module *) +val is_imported_opaque : 'a t -> modname -> bool + +val make_cmi : 'a t -> modname -> Types.signature -> alerts + -> Cmi_format.cmi_infos + +val save_cmi : 'a t -> Persistent_signature.t -> 'a -> unit + +val can_load_cmis : 'a t -> can_load_cmis +val set_can_load_cmis : 'a t -> can_load_cmis -> unit +val without_cmis : 'a t -> ('b -> 'c) -> 'b -> 'c +(* [without_cmis penv f arg] applies [f] to [arg], but does not + allow [penv] to openi cmis during its execution *) + +(* may raise Consistbl.Inconsistency *) +val import_crcs : 'a t -> source:filepath -> crcs -> unit + +(* Return the set of compilation units imported, with their CRC *) +val imports : 'a t -> crcs + +(* Return the CRC of the interface of the given compilation unit *) +val crc_of_unit: 'a t -> (Persistent_signature.t -> 'a) -> modname -> Digest.t + +(* Forward declaration to break mutual recursion with Typecore. *) +val add_delayed_check_forward: ((unit -> unit) -> unit) ref diff --git a/typing/printtyp.ml b/typing/printtyp.ml index dfc67a57..5df2e811 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -205,6 +205,8 @@ let set namespace x = map.(Namespace.id namespace) <- x let protected = ref S.empty let add_protected id = protected := S.add (Ident.name id) !protected let reset_protected () = protected := S.empty +let with_hidden id f = + protect_refs [ R(protected,S.add (Ident.name id) !protected)] f let pervasives_name namespace name = if not !enabled then Out_name.create name else @@ -1524,13 +1526,16 @@ let protect_rec_items items = | _ -> [] in List.iter Naming_context.add_protected (get_ids Trec_first items) +let stop_type_group env = + Naming_context.reset_protected (); + set_printing_env env + let still_in_type_group env' in_type_group item = match in_type_group, recursive_sigitem item with - true, Some (_,Trec_next,_) -> true + | true, Some (_,Trec_next,_) -> true | _, Some (_, (Trec_not | Trec_first),_) -> - Naming_context.reset_protected (); - set_printing_env env'; true - | _ -> Naming_context.reset_protected (); set_printing_env env'; false + stop_type_group env' ; true + | _ -> stop_type_group env'; false let rec tree_of_modtype ?(ellipsis=false) = function | Mty_ident p -> @@ -1554,7 +1559,7 @@ and tree_of_signature sg = wrap_env (fun env -> env) (tree_of_signature_rec !printing_env false) sg and tree_of_signature_rec env' in_type_group = function - [] -> [] + [] -> stop_type_group env'; [] | item :: rem as items -> let in_type_group = still_in_type_group env' in_type_group item in let (sg, rem) = filter_rem_sig item rem in @@ -1624,7 +1629,7 @@ let print_items showval env x = reset_naming_context (); Conflicts.reset (); let rec print showval in_type_group env = function - | [] -> [] + | [] -> stop_type_group env; [] | item :: rem as items -> let in_type_group = still_in_type_group env in_type_group item in let (sg, rem) = filter_rem_sig item rem in @@ -1899,13 +1904,7 @@ let explanation intro prev env = function type_expr x type_expr y) let mismatch intro env trace = - let rec mismatch intro env = function - | [] -> None - | [h] -> explanation intro None env h - | h :: (prev :: _ as rem) -> match explanation intro (Some prev) env h with - | Some _ as m -> m - | None -> mismatch intro env rem in - mismatch intro env (List.rev trace) + Trace.explain trace (fun ~prev h -> explanation intro prev env h) let explain mis ppf = match mis with @@ -2048,4 +2047,7 @@ let tree_of_modtype = tree_of_modtype ~ellipsis:false let type_expansion ty ppf ty' = type_expansion ppf (trees_of_type_expansion (ty,ty')) let tree_of_type_declaration id td rs = - wrap_env (hide [id]) (fun () -> tree_of_type_declaration id td rs) () + Naming_context.with_hidden id ( (* for disambiguation *) + wrap_env (hide [id]) (* for short-path *) + (fun () -> tree_of_type_declaration id td rs) + ) diff --git a/typing/subst.ml b/typing/subst.ml index bddea430..6a6ac7a9 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -173,6 +173,7 @@ let rec typexp copy_scope s ty = not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm in (* Make a stub *) let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in + ty'.scope <- ty.scope; ty.desc <- Tsubst ty'; ty'.desc <- begin if has_fixed_row then diff --git a/typing/tast_iterator.ml b/typing/tast_iterator.ml new file mode 100644 index 00000000..042e9cdc --- /dev/null +++ b/typing/tast_iterator.ml @@ -0,0 +1,506 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Isaac "Izzy" Avram *) +(* *) +(* Copyright 2019 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Typedtree + +type iterator = + { + binding_op: iterator -> binding_op -> unit; + case: iterator -> case -> unit; + cases: iterator -> case list -> unit; + class_declaration: iterator -> class_declaration -> unit; + class_description: iterator -> class_description -> unit; + class_expr: iterator -> class_expr -> unit; + class_field: iterator -> class_field -> unit; + class_signature: iterator -> class_signature -> unit; + class_structure: iterator -> class_structure -> unit; + class_type: iterator -> class_type -> unit; + class_type_declaration: iterator -> class_type_declaration -> unit; + class_type_field: iterator -> class_type_field -> unit; + env: iterator -> Env.t -> unit; + expr: iterator -> expression -> unit; + extension_constructor: iterator -> extension_constructor -> unit; + module_binding: iterator -> module_binding -> unit; + module_coercion: iterator -> module_coercion -> unit; + module_declaration: iterator -> module_declaration -> unit; + module_substitution: iterator -> module_substitution -> unit; + module_expr: iterator -> module_expr -> unit; + module_type: iterator -> module_type -> unit; + module_type_declaration: iterator -> module_type_declaration -> unit; + package_type: iterator -> package_type -> unit; + pat: iterator -> pattern -> unit; + row_field: iterator -> row_field -> unit; + object_field: iterator -> object_field -> unit; + open_declaration: iterator -> open_declaration -> unit; + open_description: iterator -> open_description -> unit; + signature: iterator -> signature -> unit; + signature_item: iterator -> signature_item -> unit; + structure: iterator -> structure -> unit; + structure_item: iterator -> structure_item -> unit; + typ: iterator -> core_type -> unit; + type_declaration: iterator -> type_declaration -> unit; + type_declarations: iterator -> (rec_flag * type_declaration list) -> unit; + type_extension: iterator -> type_extension -> unit; + type_exception: iterator -> type_exception -> unit; + type_kind: iterator -> type_kind -> unit; + value_binding: iterator -> value_binding -> unit; + value_bindings: iterator -> (rec_flag * value_binding list) -> unit; + value_description: iterator -> value_description -> unit; + with_constraint: iterator -> with_constraint -> unit; + } + +let structure sub {str_items; str_final_env; _} = + List.iter (sub.structure_item sub) str_items; + sub.env sub str_final_env + +let class_infos sub f x = + List.iter (fun (ct, _) -> sub.typ sub ct) x.ci_params; + f x.ci_expr + +let module_type_declaration sub {mtd_type; _} = + Option.iter (sub.module_type sub) mtd_type + +let module_declaration sub {md_type; _} = + sub.module_type sub md_type +let module_substitution _ _ = () + +let include_infos f {incl_mod; _} = f incl_mod + +let class_type_declaration sub x = + class_infos sub (sub.class_type sub) x + +let class_declaration sub x = + class_infos sub (sub.class_expr sub) x + +let structure_item sub {str_desc; str_env; _} = + sub.env sub str_env; + match str_desc with + | Tstr_eval (exp, _) -> sub.expr sub exp + | Tstr_value (rec_flag, list) -> sub.value_bindings sub (rec_flag, list) + | Tstr_primitive v -> sub.value_description sub v + | Tstr_type (rec_flag, list) -> sub.type_declarations sub (rec_flag, list) + | Tstr_typext te -> sub.type_extension sub te + | Tstr_exception ext -> sub.type_exception sub ext + | Tstr_module mb -> sub.module_binding sub mb + | Tstr_recmodule list -> List.iter (sub.module_binding sub) list + | Tstr_modtype x -> sub.module_type_declaration sub x + | Tstr_class list -> + List.iter (fun (cls,_) -> sub.class_declaration sub cls) list + | Tstr_class_type list -> + List.iter (fun (_, _, cltd) -> sub.class_type_declaration sub cltd) list + | Tstr_include incl -> include_infos (sub.module_expr sub) incl + | Tstr_open od -> sub.open_declaration sub od + | Tstr_attribute _ -> () + +let value_description sub x = sub.typ sub x.val_desc + +let label_decl sub {ld_type; _} = sub.typ sub ld_type + +let constructor_args sub = function + | Cstr_tuple l -> List.iter (sub.typ sub) l + | Cstr_record l -> List.iter (label_decl sub) l + +let constructor_decl sub {cd_args; cd_res; _} = + constructor_args sub cd_args; + Option.iter (sub.typ sub) cd_res + +let type_kind sub = function + | Ttype_abstract -> () + | Ttype_variant list -> List.iter (constructor_decl sub) list + | Ttype_record list -> List.iter (label_decl sub) list + | Ttype_open -> () + +let type_declaration sub {typ_cstrs; typ_kind; typ_manifest; typ_params; _} = + List.iter + (fun (c1, c2, _) -> + sub.typ sub c1; + sub.typ sub c2) + typ_cstrs; + sub.type_kind sub typ_kind; + Option.iter (sub.typ sub) typ_manifest; + List.iter (fun (c, _) -> sub.typ sub c) typ_params + +let type_declarations sub (_, list) = List.iter (sub.type_declaration sub) list + +let type_extension sub {tyext_constructors; tyext_params; _} = + List.iter (fun (c, _) -> sub.typ sub c) tyext_params; + List.iter (sub.extension_constructor sub) tyext_constructors + +let type_exception sub {tyexn_constructor; _} = + sub.extension_constructor sub tyexn_constructor + +let extension_constructor sub {ext_kind; _} = + match ext_kind with + | Text_decl (ctl, cto) -> + constructor_args sub ctl; + Option.iter (sub.typ sub) cto + | Text_rebind _ -> () + +let pat sub {pat_extra; pat_desc; pat_env; _} = + let extra = function + | Tpat_type _ -> () + | Tpat_unpack -> () + | Tpat_open (_, _, env) -> sub.env sub env + | Tpat_constraint ct -> sub.typ sub ct + in + sub.env sub pat_env; + List.iter (fun (e, _, _) -> extra e) pat_extra; + match pat_desc with + | Tpat_any -> () + | Tpat_var _ -> () + | Tpat_constant _ -> () + | Tpat_tuple l -> List.iter (sub.pat sub) l + | Tpat_construct (_, _, l) -> List.iter (sub.pat sub) l + | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po + | Tpat_record (l, _) -> List.iter (fun (_, _, i) -> sub.pat sub i) l + | Tpat_array l -> List.iter (sub.pat sub) l + | Tpat_or (p1, p2, _) -> + sub.pat sub p1; + sub.pat sub p2 + | Tpat_alias (p, _, _) -> sub.pat sub p + | Tpat_lazy p -> sub.pat sub p + | Tpat_exception p -> sub.pat sub p + +let expr sub {exp_extra; exp_desc; exp_env; _} = + let extra = function + | Texp_constraint cty -> sub.typ sub cty + | Texp_coerce (cty1, cty2) -> + Option.iter (sub.typ sub) cty1; + sub.typ sub cty2 + | Texp_newtype _ -> () + | Texp_poly cto -> Option.iter (sub.typ sub) cto + in + List.iter (fun (e, _, _) -> extra e) exp_extra; + sub.env sub exp_env; + match exp_desc with + | Texp_ident _ -> () + | Texp_constant _ -> () + | Texp_let (rec_flag, list, exp) -> + sub.value_bindings sub (rec_flag, list); + sub.expr sub exp + | Texp_function {cases; _} -> sub.cases sub cases + | Texp_apply (exp, list) -> + sub.expr sub exp; + List.iter (fun (_, o) -> Option.iter (sub.expr sub) o) list + | Texp_match (exp, cases, _) -> + sub.expr sub exp; + sub.cases sub cases + | Texp_try (exp, cases) -> + sub.expr sub exp; + sub.cases sub cases + | Texp_tuple list -> List.iter (sub.expr sub) list + | Texp_construct (_, _, args) -> List.iter (sub.expr sub) args + | Texp_variant (_, expo) -> Option.iter (sub.expr sub) expo + | Texp_record { fields; extended_expression; _} -> + Array.iter (function + | _, Kept _ -> () + | _, Overridden (_, exp) -> sub.expr sub exp) + fields; + Option.iter (sub.expr sub) extended_expression; + | Texp_field (exp, _, _) -> sub.expr sub exp + | Texp_setfield (exp1, _, _, exp2) -> + sub.expr sub exp1; + sub.expr sub exp2 + | Texp_array list -> List.iter (sub.expr sub) list + | Texp_ifthenelse (exp1, exp2, expo) -> + sub.expr sub exp1; + sub.expr sub exp2; + Option.iter (sub.expr sub) expo + | Texp_sequence (exp1, exp2) -> + sub.expr sub exp1; + sub.expr sub exp2 + | Texp_while (exp1, exp2) -> + sub.expr sub exp1; + sub.expr sub exp2 + | Texp_for (_, _, exp1, exp2, _, exp3) -> + sub.expr sub exp1; + sub.expr sub exp2; + sub.expr sub exp3 + | Texp_send (exp, _, expo) -> + sub.expr sub exp; + Option.iter (sub.expr sub) expo + | Texp_new _ -> () + | Texp_instvar _ -> () + | Texp_setinstvar (_, _, _, exp) ->sub.expr sub exp + | Texp_override (_, list) -> + List.iter (fun (_, _, e) -> sub.expr sub e) list + | Texp_letmodule (_, _, _, mexpr, exp) -> + sub.module_expr sub mexpr; + sub.expr sub exp + | Texp_letexception (cd, exp) -> + sub.extension_constructor sub cd; + sub.expr sub exp + | Texp_assert exp -> sub.expr sub exp + | Texp_lazy exp -> sub.expr sub exp + | Texp_object (cl, _) -> sub.class_structure sub cl + | Texp_pack mexpr -> sub.module_expr sub mexpr + | Texp_letop {let_ = l; ands; body; _} -> + sub.binding_op sub l; + List.iter (sub.binding_op sub) ands; + sub.case sub body + | Texp_unreachable -> () + | Texp_extension_constructor _ -> () + | Texp_open (od, e) -> + sub.open_declaration sub od; + sub.expr sub e + + +let package_type sub {pack_fields; _} = + List.iter (fun (_, p) -> sub.typ sub p) pack_fields + +let binding_op sub {bop_exp; _} = sub.expr sub bop_exp + +let signature sub {sig_items; sig_final_env; _} = + sub.env sub sig_final_env; + List.iter (sub.signature_item sub) sig_items + +let signature_item sub {sig_desc; sig_env; _} = + sub.env sub sig_env; + match sig_desc with + | Tsig_value v -> sub.value_description sub v + | Tsig_type (rf, tdl) -> sub.type_declarations sub (rf, tdl) + | Tsig_typesubst list -> sub.type_declarations sub (Nonrecursive, list) + | Tsig_typext te -> sub.type_extension sub te + | Tsig_exception ext -> sub.type_exception sub ext + | Tsig_module x -> sub.module_declaration sub x + | Tsig_modsubst x -> sub.module_substitution sub x + | Tsig_recmodule list -> List.iter (sub.module_declaration sub) list + | Tsig_modtype x -> sub.module_type_declaration sub x + | Tsig_include incl -> include_infos (sub.module_type sub) incl + | Tsig_class list -> List.iter (sub.class_description sub) list + | Tsig_class_type list -> List.iter (sub.class_type_declaration sub) list + | Tsig_open od -> sub.open_description sub od + | Tsig_attribute _ -> () + +let class_description sub x = + class_infos sub (sub.class_type sub) x + +let module_type sub {mty_desc; mty_env; _} = + sub.env sub mty_env; + match mty_desc with + | Tmty_ident _ -> () + | Tmty_alias _ -> () + | Tmty_signature sg -> sub.signature sub sg + | Tmty_functor (_, _, mtype1, mtype2) -> + Option.iter (sub.module_type sub) mtype1; + sub.module_type sub mtype2 + | Tmty_with (mtype, list) -> + sub.module_type sub mtype; + List.iter (fun (_, _, e) -> sub.with_constraint sub e) list + | Tmty_typeof mexpr -> sub.module_expr sub mexpr + +let with_constraint sub = function + | Twith_type decl -> sub.type_declaration sub decl + | Twith_typesubst decl -> sub.type_declaration sub decl + | Twith_module _ -> () + | Twith_modsubst _ -> () + +let open_description sub {open_env; _} = sub.env sub open_env + +let open_declaration sub {open_expr; open_env; _} = + sub.module_expr sub open_expr; + sub.env sub open_env + +let module_coercion sub = function + | Tcoerce_none -> () + | Tcoerce_functor (c1,c2) -> + sub.module_coercion sub c1; + sub.module_coercion sub c2 + | Tcoerce_alias (env, _, c1) -> + sub.env sub env; + sub.module_coercion sub c1 + | Tcoerce_structure (l1, l2) -> + List.iter (fun (_, c) -> sub.module_coercion sub c) l1; + List.iter (fun (_, _ ,c) -> sub.module_coercion sub c) l2 + | Tcoerce_primitive {pc_env; _} -> sub.env sub pc_env + +let module_expr sub {mod_desc; mod_env; _} = + sub.env sub mod_env; + match mod_desc with + | Tmod_ident _ -> () + | Tmod_structure st -> sub.structure sub st + | Tmod_functor (_, _, mtype, mexpr) -> + Option.iter (sub.module_type sub) mtype; + sub.module_expr sub mexpr + | Tmod_apply (mexp1, mexp2, c) -> + sub.module_expr sub mexp1; + sub.module_expr sub mexp2; + sub.module_coercion sub c + | Tmod_constraint (mexpr, _, Tmodtype_implicit, c) -> + sub.module_expr sub mexpr; + sub.module_coercion sub c + | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, c) -> + sub.module_expr sub mexpr; + sub.module_type sub mtype; + sub.module_coercion sub c + | Tmod_unpack (exp, _) -> sub.expr sub exp + +let module_binding sub {mb_expr; _} = sub.module_expr sub mb_expr + +let class_expr sub {cl_desc; cl_env; _} = + sub.env sub cl_env; + match cl_desc with + | Tcl_constraint (cl, clty, _, _, _) -> + sub.class_expr sub cl; + Option.iter (sub.class_type sub) clty + | Tcl_structure clstr -> sub.class_structure sub clstr + | Tcl_fun (_, pat, priv, cl, _) -> + sub.pat sub pat; + List.iter (fun (_, e) -> sub.expr sub e) priv; + sub.class_expr sub cl + | Tcl_apply (cl, args) -> + sub.class_expr sub cl; + List.iter (fun (_, e) -> Option.iter (sub.expr sub) e) args + | Tcl_let (rec_flag, value_bindings, ivars, cl) -> + sub.value_bindings sub (rec_flag, value_bindings); + List.iter (fun (_, e) -> sub.expr sub e) ivars; + sub.class_expr sub cl + | Tcl_ident (_, _, tyl) -> List.iter (sub.typ sub) tyl + | Tcl_open (od, e) -> + sub.open_description sub od; + sub.class_expr sub e + +let class_type sub {cltyp_desc; cltyp_env; _} = + sub.env sub cltyp_env; + match cltyp_desc with + | Tcty_signature csg -> sub.class_signature sub csg + | Tcty_constr (_, _, list) -> List.iter (sub.typ sub) list + | Tcty_arrow (_, ct, cl) -> + sub.typ sub ct; + sub.class_type sub cl + | Tcty_open (od, e) -> + sub.open_description sub od; + sub.class_type sub e + +let class_signature sub {csig_self; csig_fields; _} = + sub.typ sub csig_self; + List.iter (sub.class_type_field sub) csig_fields + +let class_type_field sub {ctf_desc; _} = + match ctf_desc with + | Tctf_inherit ct -> sub.class_type sub ct + | Tctf_val (_, _, _, ct) -> sub.typ sub ct + | Tctf_method (_, _, _, ct) -> sub.typ sub ct + | Tctf_constraint (ct1, ct2) -> + sub.typ sub ct1; + sub.typ sub ct2 + | Tctf_attribute _ -> () + +let typ sub {ctyp_desc; ctyp_env; _} = + sub.env sub ctyp_env; + match ctyp_desc with + | Ttyp_any -> () + | Ttyp_var _ -> () + | Ttyp_arrow (_, ct1, ct2) -> + sub.typ sub ct1; + sub.typ sub ct2 + | Ttyp_tuple list -> List.iter (sub.typ sub) list + | Ttyp_constr (_, _, list) -> List.iter (sub.typ sub) list + | Ttyp_object (list, _) -> List.iter (sub.object_field sub) list + | Ttyp_class (_, _, list) -> List.iter (sub.typ sub) list + | Ttyp_alias (ct, _) -> sub.typ sub ct + | Ttyp_variant (list, _, _) -> List.iter (sub.row_field sub) list + | Ttyp_poly (_, ct) -> sub.typ sub ct + | Ttyp_package pack -> sub.package_type sub pack + +let class_structure sub {cstr_self; cstr_fields; _} = + sub.pat sub cstr_self; + List.iter (sub.class_field sub) cstr_fields + +let row_field sub {rf_desc; _} = + match rf_desc with + | Ttag (_, _, list) -> List.iter (sub.typ sub) list + | Tinherit ct -> sub.typ sub ct + +let object_field sub {of_desc; _} = + match of_desc with + | OTtag (_, ct) -> sub.typ sub ct + | OTinherit ct -> sub.typ sub ct + +let class_field_kind sub = function + | Tcfk_virtual ct -> sub.typ sub ct + | Tcfk_concrete (_, e) -> sub.expr sub e + +let class_field sub {cf_desc; _} = match cf_desc with + | Tcf_inherit (_, cl, _, _, _) -> sub.class_expr sub cl + | Tcf_constraint (cty1, cty2) -> + sub.typ sub cty1; + sub.typ sub cty2 + | Tcf_val (_, _, _, k, _) -> class_field_kind sub k + | Tcf_method (_, _, k) -> class_field_kind sub k + | Tcf_initializer exp -> sub.expr sub exp + | Tcf_attribute _ -> () + +let value_bindings sub (_, list) = List.iter (sub.value_binding sub) list + +let cases sub l = List.iter (sub.case sub) l + +let case sub {c_lhs; c_guard; c_rhs} = + sub.pat sub c_lhs; + Option.iter (sub.expr sub) c_guard; + sub.expr sub c_rhs + +let value_binding sub {vb_pat; vb_expr; _} = + sub.pat sub vb_pat; + sub.expr sub vb_expr + +let env _sub _ = () + +let default_iterator = + { + binding_op; + case; + cases; + class_declaration; + class_description; + class_expr; + class_field; + class_signature; + class_structure; + class_type; + class_type_declaration; + class_type_field; + env; + expr; + extension_constructor; + module_binding; + module_coercion; + module_declaration; + module_substitution; + module_expr; + module_type; + module_type_declaration; + package_type; + pat; + row_field; + object_field; + open_declaration; + open_description; + signature; + signature_item; + structure; + structure_item; + typ; + type_declaration; + type_declarations; + type_extension; + type_exception; + type_kind; + value_binding; + value_bindings; + value_description; + with_constraint; + } diff --git a/typing/tast_iterator.mli b/typing/tast_iterator.mli new file mode 100644 index 00000000..dc6f56f4 --- /dev/null +++ b/typing/tast_iterator.mli @@ -0,0 +1,69 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Isaac "Izzy" Avram *) +(* *) +(* Copyright 2019 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** +Allows the implementation of typed tree inspection using open recursion +*) + +open Asttypes +open Typedtree + +type iterator = + { + binding_op: iterator -> binding_op -> unit; + case: iterator -> case -> unit; + cases: iterator -> case list -> unit; + class_declaration: iterator -> class_declaration -> unit; + class_description: iterator -> class_description -> unit; + class_expr: iterator -> class_expr -> unit; + class_field: iterator -> class_field -> unit; + class_signature: iterator -> class_signature -> unit; + class_structure: iterator -> class_structure -> unit; + class_type: iterator -> class_type -> unit; + class_type_declaration: iterator -> class_type_declaration -> unit; + class_type_field: iterator -> class_type_field -> unit; + env: iterator -> Env.t -> unit; + expr: iterator -> expression -> unit; + extension_constructor: iterator -> extension_constructor -> unit; + module_binding: iterator -> module_binding -> unit; + module_coercion: iterator -> module_coercion -> unit; + module_declaration: iterator -> module_declaration -> unit; + module_substitution: iterator -> module_substitution -> unit; + module_expr: iterator -> module_expr -> unit; + module_type: iterator -> module_type -> unit; + module_type_declaration: iterator -> module_type_declaration -> unit; + package_type: iterator -> package_type -> unit; + pat: iterator -> pattern -> unit; + row_field: iterator -> row_field -> unit; + object_field: iterator -> object_field -> unit; + open_declaration: iterator -> open_declaration -> unit; + open_description: iterator -> open_description -> unit; + signature: iterator -> signature -> unit; + signature_item: iterator -> signature_item -> unit; + structure: iterator -> structure -> unit; + structure_item: iterator -> structure_item -> unit; + typ: iterator -> core_type -> unit; + type_declaration: iterator -> type_declaration -> unit; + type_declarations: iterator -> (rec_flag * type_declaration list) -> unit; + type_extension: iterator -> type_extension -> unit; + type_exception: iterator -> type_exception -> unit; + type_kind: iterator -> type_kind -> unit; + value_binding: iterator -> value_binding -> unit; + value_bindings: iterator -> (rec_flag * value_binding list) -> unit; + value_description: iterator -> value_description -> unit; + with_constraint: iterator -> with_constraint -> unit; + } + +val default_iterator: iterator diff --git a/typing/typecore.ml b/typing/typecore.ml index e87169ae..64d99ee1 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -52,12 +52,13 @@ type existential_restriction = type error = | Constructor_arity_mismatch of Longident.t * int * int | Label_mismatch of Longident.t * Ctype.Unification_trace.t - | Pattern_type_clash of Ctype.Unification_trace.t + | Pattern_type_clash of Ctype.Unification_trace.t * pattern_desc option | Or_pattern_type_clash of Ident.t * Ctype.Unification_trace.t | Multiply_bound_variable of string | Orpat_vars of Ident.t * Ident.t list | Expr_type_clash of Ctype.Unification_trace.t * type_forcing_context option + * expression_desc option | Apply_non_function of type_expr | Apply_wrong_label of arg_label * type_expr | Label_multiply_defined of string @@ -73,6 +74,7 @@ type error = | Virtual_class of Longident.t | Private_type of type_expr | Private_label of Longident.t * type_expr + | Private_constructor of constructor_description * type_expr | Unbound_instance_variable of string * string list | Instance_variable_not_mutable of bool * string | Not_subtype of Ctype.Unification_trace.t * Ctype.Unification_trace.t @@ -382,7 +384,7 @@ let unify_pat_types loc env ty ty' = unify env ty ty' with Unify trace -> - raise(Error(loc, env, Pattern_type_clash(trace))) + raise(Error(loc, env, Pattern_type_clash(trace, None))) | Tags(l1,l2) -> raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) @@ -394,7 +396,7 @@ let unify_exp_types loc env ty expected_ty = unify env ty expected_ty with Unify trace -> - raise(Error(loc, env, Expr_type_clash(trace, None))) + raise(Error(loc, env, Expr_type_clash(trace, None, None))) | Tags(l1,l2) -> raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) @@ -409,14 +411,16 @@ let unify_pat_types_gadt loc env ty ty' = try unify_gadt ~equations_level:(get_gadt_equations_level ()) env ty ty' with | Unify trace -> - raise(Error(loc, !env, Pattern_type_clash(trace))) + raise(Error(loc, !env, Pattern_type_clash(trace, None))) | Tags(l1,l2) -> raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2))) (* Creating new conjunctive types is not allowed when typing patterns *) let unify_pat env pat expected_ty = - unify_pat_types pat.pat_loc env pat.pat_type expected_ty + try unify_pat_types pat.pat_loc env pat.pat_type expected_ty + with Error (loc, env, Pattern_type_clash(trace, None)) -> + raise(Error(loc, env, Pattern_type_clash(trace, Some pat.pat_desc))) (* make all Reither present in open variants *) let finalize_variant pat = @@ -1116,7 +1120,7 @@ exception Need_backtrack let check_scope_escape loc env level ty = try Ctype.check_scope_escape env level ty with Unify trace -> - raise(Error(loc, env, Pattern_type_clash(trace))) + raise(Error(loc, env, Pattern_type_clash(trace, None))) (* type_pat propagates the expected type as well as maps for constructors and labels. @@ -1418,7 +1422,7 @@ and type_pat_aux ~exception_allowed ~constrs ~labels ~no_existentials ~mode let (_, ty_arg, ty_res) = instance_label false label in begin try unify_pat_types loc !env ty_res (instance record_ty) - with Error(_loc, _env, Pattern_type_clash(trace)) -> + with Error(_loc, _env, Pattern_type_clash(trace, _)) -> raise(Error(label_lid.loc, !env, Label_mismatch(label_lid.txt, trace))) end; @@ -1777,12 +1781,14 @@ let rec final_subexpression sexp = let rec is_nonexpansive exp = match exp.exp_desc with - Texp_ident(_,_,_) -> true - | Texp_constant _ -> true + | Texp_ident _ + | Texp_constant _ + | Texp_unreachable + | Texp_function _ + | Texp_array [] -> true | Texp_let(_rec_flag, pat_exp_list, body) -> List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list && is_nonexpansive body - | Texp_function _ -> true | Texp_apply(e, (_,None)::el) -> is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el) | Texp_match(e, cases, _) -> @@ -1819,12 +1825,10 @@ let rec is_nonexpansive exp = fields && is_nonexpansive_opt extended_expression | Texp_field(exp, _, _) -> is_nonexpansive exp - | Texp_array [] -> true | Texp_ifthenelse(_cond, ifso, ifnot) -> is_nonexpansive ifso && is_nonexpansive_opt ifnot | Texp_sequence (_e1, e2) -> is_nonexpansive e2 (* PR#4354 *) - | Texp_new (_, _, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 -> - true + | Texp_new (_, _, cl_decl) -> Ctype.class_type_arity cl_decl.cty_type > 0 (* Note: nonexpansive only means no _observable_ side effects *) | Texp_lazy e -> is_nonexpansive e | Texp_object ({cstr_fields=fields; cstr_type = { csig_vars=vars}}, _) -> @@ -1861,11 +1865,24 @@ let rec is_nonexpansive exp = ("%raise" | "%reraise" | "%raise_notrace")}}) }, [Nolabel, Some e]) -> is_nonexpansive e - | _ -> false + | Texp_array (_ :: _) + | Texp_apply _ + | Texp_try _ + | Texp_setfield _ + | Texp_while _ + | Texp_for _ + | Texp_send _ + | Texp_instvar _ + | Texp_setinstvar _ + | Texp_override _ + | Texp_letexception _ + | Texp_letop _ + | Texp_extension_constructor _ -> + false and is_nonexpansive_mod mexp = match mexp.mod_desc with - | Tmod_ident _ -> true + | Tmod_ident _ | Tmod_functor _ -> true | Tmod_unpack (e, _) -> is_nonexpansive e | Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m @@ -1898,9 +1915,11 @@ and is_nonexpansive_mod mexp = | Tmod_apply _ -> false and is_nonexpansive_opt = function - None -> true + | None -> true | Some e -> is_nonexpansive e +let maybe_expansive e = not (is_nonexpansive e) + let check_recursive_bindings env valbinds = let ids = let_bound_idents valbinds in List.iter @@ -1956,7 +1975,7 @@ let rec type_approx env sexp = let ty = type_approx env e in let ty1 = approx_type env sty in begin try unify env ty ty1 with Unify trace -> - raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None))) + raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None, None))) end; ty1 | Pexp_coerce (e, sty1, sty2) -> @@ -1968,7 +1987,7 @@ let rec type_approx env sexp = and ty1 = approx_ty_opt sty1 and ty2 = approx_type env sty2 in begin try unify env ty ty1 with Unify trace -> - raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None))) + raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None, None))) end; ty2 | _ -> newvar () @@ -1989,7 +2008,7 @@ let list_labels env ty = (* Check that all univars are safe in a type *) let check_univars env expans kind exp ty_expected vars = - if expans && not (is_nonexpansive exp) then + if expans && maybe_expansive exp then lower_contravariant env exp.exp_type; (* need to expand twice? cf. Ctype.unify2 *) let vars = List.map (expand_head env) vars in @@ -2250,7 +2269,10 @@ let name_cases default lst = let unify_exp env exp expected_ty = let loc = proper_exp_loc exp in - unify_exp_types loc env exp.exp_type expected_ty + try + unify_exp_types loc env exp.exp_type expected_ty + with Error(loc, env, Expr_type_clash(trace, tfc, None)) -> + raise (Error(loc, env, Expr_type_clash(trace, tfc, Some exp.exp_desc))) let rec type_exp ?recarg env sexp = (* We now delegate everything to type_expect *) @@ -2279,9 +2301,10 @@ and with_explanation explanation f = | None -> f () | Some explanation -> try f () - with Error (loc', env', Expr_type_clash(trace', None)) + with Error (loc', env', Expr_type_clash(trace', None, exp')) when not loc'.Location.loc_ghost -> - raise (Error (loc', env', Expr_type_clash(trace', Some explanation))) + let err = Expr_type_clash(trace', Some explanation, exp') in + raise (Error (loc', env', err)) and type_expect_ ?in_function ?(recarg=Rejected) @@ -2481,7 +2504,7 @@ and type_expect_ begin_def (); let arg = type_exp env sarg in end_def (); - if not (is_nonexpansive arg) then lower_contravariant env arg.exp_type; + if maybe_expansive arg then lower_contravariant env arg.exp_type; generalize arg.exp_type; let cases, partial = type_cases ~exception_allowed:true env arg.exp_type ty_expected true loc @@ -3230,7 +3253,12 @@ and type_expect_ re { exp with exp_extra = (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra } | Pexp_newtype({txt=name}, sbody) -> - let ty = newvar () in + let ty = + if Typetexp.valid_tyvar_name name then + newvar ~name () + else + newvar () + in (* remember original level *) begin_def (); (* Create a fake abstract type declaration for name. *) @@ -3608,29 +3636,21 @@ and type_format loc str env = | Int_o -> mk_constr "Int_o" [] | Int_Co -> mk_constr "Int_Co" [] | Int_u -> mk_constr "Int_u" [] | Int_Cd -> mk_constr "Int_Cd" [] | Int_Ci -> mk_constr "Int_Ci" [] | Int_Cu -> mk_constr "Int_Cu" [] - and mk_fconv fconv = match fconv with + and mk_fconv fconv = + let flag = match fst fconv with + | Float_flag_ -> mk_constr "Float_flag_" [] + | Float_flag_p -> mk_constr "Float_flag_p" [] + | Float_flag_s -> mk_constr "Float_flag_s" [] in + let kind = match snd fconv with | Float_f -> mk_constr "Float_f" [] - | Float_pf -> mk_constr "Float_pf" [] - | Float_sf -> mk_constr "Float_sf" [] | Float_e -> mk_constr "Float_e" [] - | Float_pe -> mk_constr "Float_pe" [] - | Float_se -> mk_constr "Float_se" [] | Float_E -> mk_constr "Float_E" [] - | Float_pE -> mk_constr "Float_pE" [] - | Float_sE -> mk_constr "Float_sE" [] | Float_g -> mk_constr "Float_g" [] - | Float_pg -> mk_constr "Float_pg" [] - | Float_sg -> mk_constr "Float_sg" [] | Float_G -> mk_constr "Float_G" [] - | Float_pG -> mk_constr "Float_pG" [] - | Float_sG -> mk_constr "Float_sG" [] | Float_h -> mk_constr "Float_h" [] - | Float_ph -> mk_constr "Float_ph" [] - | Float_sh -> mk_constr "Float_sh" [] | Float_H -> mk_constr "Float_H" [] - | Float_pH -> mk_constr "Float_pH" [] - | Float_sH -> mk_constr "Float_sH" [] - | Float_F -> mk_constr "Float_F" [] + | Float_F -> mk_constr "Float_F" [] in + mk_exp_loc (Pexp_tuple [flag; kind]) and mk_counter cnt = match cnt with | Line_counter -> mk_constr "Line_counter" [] | Char_counter -> mk_constr "Char_counter" [] @@ -3825,7 +3845,7 @@ and type_label_exp create env loc ty_expected try check_univars env (vars <> []) "field value" arg label.lbl_arg vars; arg - with exn when not (is_nonexpansive arg) -> try + with exn when maybe_expansive arg -> try (* Try to retype without propagating ty_arg, cf PR#4862 *) may Btype.backtrack snap; begin_def (); @@ -3840,7 +3860,7 @@ and type_label_exp create env loc ty_expected in (lid, label, {arg with exp_type = instance arg.exp_type}) -and type_argument ?recarg env sarg ty_expected' ty_expected = +and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = (* ty_expected' may be generic *) let no_labels ty = let ls, tvar = list_labels env ty in @@ -3932,7 +3952,8 @@ and type_argument ?recarg env sarg ty_expected' ty_expected = func let_var) } end | _ -> - let texp = type_expect ?recarg env sarg (mk_expected ty_expected') in + let texp = type_expect ?recarg env sarg + (mk_expected ?explanation ty_expected') in unify_exp env texp ty_expected; texp @@ -4205,7 +4226,12 @@ and type_construct env loc lid sarg ty_expected_explained attrs = List.map2 (fun e (t,t0) -> type_argument ~recarg env e t t0) sargs (List.combine ty_args ty_args0) in if constr.cstr_private = Private then - raise(Error(loc, env, Private_type ty_res)); + begin match constr.cstr_tag with + | Cstr_extension _ -> + raise(Error(loc, env, Private_constructor (constr, ty_res))) + | Cstr_constant _ | Cstr_block _ | Cstr_unboxed -> + raise (Error(loc, env, Private_type ty_res)); + end; (* NOTE: shouldn't we call "re" on this final expression? -- AF *) { texp with exp_desc = Texp_construct(lid, constr, args) } @@ -4653,21 +4679,16 @@ and type_let end_def(); List.iter2 (fun pat exp -> - if not (is_nonexpansive exp) then + if maybe_expansive exp then lower_contravariant env pat.pat_type) pat_list exp_list; iter_pattern_variables_type generalize pvs; - (* The next line changes the toplevel experience from: - {[ - let _ = Array.get;; - - : '_weak1 array -> int -> '_weak1 = - ]} - to: - {[ + (* We also generalize expressions that are not bound to a variable. + This does not matter in general, but those types are shown by the + interactive toplevel, for example: {[ let _ = Array.get;; - : 'a array -> int -> 'a = - ]} - *) + ]} *) List.iter (fun exp -> generalize exp.exp_type) exp_list; let l = List.combine pat_list exp_list in let l = @@ -4762,7 +4783,7 @@ let type_expression env sexp = begin_def(); let exp = type_exp env sexp in end_def(); - if not (is_nonexpansive exp) then lower_contravariant env exp.exp_type; + if maybe_expansive exp then lower_contravariant env exp.exp_type; generalize exp.exp_type; match sexp.pexp_desc with Pexp_ident lid -> @@ -4784,193 +4805,283 @@ let spellcheck_idents ppf unbound valid_idents = open Format open Printtyp +(* Returns the first diff of the trace *) +let type_clash_of_trace trace = + Ctype.Unification_trace.(explain trace (fun ~prev:_ -> function + | Diff diff -> Some diff + | _ -> None + )) + +(* Hint on type error on integer literals + To avoid confusion, it is disabled on float literals + and when the expected type is `int` *) +let report_literal_type_constraint expected_type const = + let const_str = match const with + | Const_int n -> Some (Int.to_string n) + | Const_int32 n -> Some (Int32.to_string n) + | Const_int64 n -> Some (Int64.to_string n) + | Const_nativeint n -> Some (Nativeint.to_string n) + | _ -> None + in + let suffix = + if Path.same expected_type Predef.path_int32 then + Some 'l' + else if Path.same expected_type Predef.path_int64 then + Some 'L' + else if Path.same expected_type Predef.path_nativeint then + Some 'n' + else if Path.same expected_type Predef.path_float then + Some '.' + else None + in + match const_str, suffix with + | Some c, Some s -> [ Location.msg "@[Hint: Did you mean `%s%c'?@]" c s ] + | _, _ -> [] + +let report_literal_type_constraint const = function + | Some Unification_trace. + { expected = { t = { desc = Tconstr (typ, [], _) } } } -> + report_literal_type_constraint typ const + | Some _ | None -> [] + +let report_expr_type_clash_hints exp diff = + match exp with + | Some (Texp_constant const) -> report_literal_type_constraint const diff + | _ -> [] + +let report_pattern_type_clash_hints pat diff = + match pat with + | Some (Tpat_constant const) -> report_literal_type_constraint const diff + | _ -> [] + let report_type_expected_explanation expl ppf = + let because expl_str = fprintf ppf "@ because it is in %s" expl_str in match expl with | If_conditional -> - fprintf ppf "the condition of an if-statement" + because "the condition of an if-statement" | If_no_else_branch -> - fprintf ppf "the result of a conditional with no else branch" + because "the result of a conditional with no else branch" | While_loop_conditional -> - fprintf ppf "the condition of a while-loop" + because "the condition of a while-loop" | While_loop_body -> - fprintf ppf "the body of a while-loop" + because "the body of a while-loop" | For_loop_start_index -> - fprintf ppf "a for-loop start index" + because "a for-loop start index" | For_loop_stop_index -> - fprintf ppf "a for-loop stop index" + because "a for-loop stop index" | For_loop_body -> - fprintf ppf "the body of a for-loop" + because "the body of a for-loop" | Assert_condition -> - fprintf ppf "the condition of an assertion" + because "the condition of an assertion" | Sequence_left_hand_side -> - fprintf ppf "the left-hand side of a sequence" + because "the left-hand side of a sequence" | When_guard -> - fprintf ppf "a when-guard" + because "a when-guard" let report_type_expected_explanation_opt expl ppf = match expl with | None -> () - | Some expl -> - fprintf ppf "@ because it is in %t" - (report_type_expected_explanation expl) + | Some expl -> report_type_expected_explanation expl ppf + +let report_unification_error ~loc ?sub env trace + ?type_expected_explanation txt1 txt2 = + Location.error_of_printer ~loc ?sub (fun ppf () -> + Printtyp.report_unification_error ppf env trace + ?type_expected_explanation txt1 txt2 + ) () -let report_error env ppf = function +let report_error ~loc env = function | Constructor_arity_mismatch(lid, expected, provided) -> - fprintf ppf + Location.errorf ~loc "@[The constructor %a@ expects %i argument(s),@ \ but is applied here to %i argument(s)@]" longident lid expected provided | Label_mismatch(lid, trace) -> - report_unification_error ppf env trace + report_unification_error ~loc env trace (function ppf -> fprintf ppf "The record field %a@ belongs to the type" longident lid) (function ppf -> fprintf ppf "but is mixed here with fields of type") - | Pattern_type_clash trace -> - report_unification_error ppf env trace - (function ppf -> - fprintf ppf "This pattern matches values of type") - (function ppf -> - fprintf ppf "but a pattern was expected which matches values of type") + | Pattern_type_clash (trace, pat) -> + let diff = type_clash_of_trace trace in + let sub = report_pattern_type_clash_hints pat diff in + Location.error_of_printer ~loc ~sub (fun ppf () -> + Printtyp.report_unification_error ppf env trace + (function ppf -> + fprintf ppf "This pattern matches values of type") + (function ppf -> + fprintf ppf "but a pattern was expected which matches values of \ + type"); + ) () | Or_pattern_type_clash (id, trace) -> - report_unification_error ppf env trace + report_unification_error ~loc env trace (function ppf -> fprintf ppf "The variable %s on the left-hand side of this \ or-pattern has type" (Ident.name id)) (function ppf -> fprintf ppf "but on the right-hand side it has type") | Multiply_bound_variable name -> - fprintf ppf "Variable %s is bound several times in this matching" name + Location.errorf ~loc + "Variable %s is bound several times in this matching" + name | Orpat_vars (id, valid_idents) -> - fprintf ppf "Variable %s must occur on both sides of this | pattern" - (Ident.name id); - spellcheck_idents ppf id valid_idents - | Expr_type_clash (trace, explanation) -> - report_unification_error ppf env trace - ~type_expected_explanation: - (report_type_expected_explanation_opt explanation) - (function ppf -> - fprintf ppf "This expression has type") - (function ppf -> - fprintf ppf "but an expression was expected of type") + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf + "Variable %s must occur on both sides of this | pattern" + (Ident.name id); + spellcheck_idents ppf id valid_idents + ) () + | Expr_type_clash (trace, explanation, exp) -> + let diff = type_clash_of_trace trace in + let sub = report_expr_type_clash_hints exp diff in + Location.error_of_printer ~loc ~sub (fun ppf () -> + Printtyp.report_unification_error ppf env trace + ~type_expected_explanation: + (report_type_expected_explanation_opt explanation) + (function ppf -> + fprintf ppf "This expression has type") + (function ppf -> + fprintf ppf "but an expression was expected of type"); + ) () | Apply_non_function typ -> reset_and_mark_loops typ; begin match (repr typ).desc with Tarrow _ -> - fprintf ppf "@[@[<2>This function has type@ %a@]" - type_expr typ; - fprintf ppf "@ @[It is applied to too many arguments;@ %s@]@]" - "maybe you forgot a `;'." + Location.errorf ~loc + "@[@[<2>This function has type@ %a@]\ + @ @[It is applied to too many arguments;@ %s@]@]" + type_expr typ "maybe you forgot a `;'."; | _ -> - fprintf ppf "@[@[<2>This expression has type@ %a@]@ %s@]" + Location.errorf ~loc "@[@[<2>This expression has type@ %a@]@ %s@]" type_expr typ "This is not a function; it cannot be applied." end | Apply_wrong_label (l, ty) -> let print_label ppf = function | Nolabel -> fprintf ppf "without label" - | l -> - fprintf ppf "with label %s" (prefixed_label_name l) + | l -> fprintf ppf "with label %s" (prefixed_label_name l) in reset_and_mark_loops ty; - fprintf ppf + Location.errorf ~loc "@[@[<2>The function applied to this argument has type@ %a@]@.\ - This argument cannot be applied %a@]" + This argument cannot be applied %a@]" type_expr ty print_label l | Label_multiply_defined s -> - fprintf ppf "The record field label %s is defined several times" s + Location.errorf ~loc "The record field label %s is defined several times" + s | Label_missing labels -> let print_labels ppf = List.iter (fun lbl -> fprintf ppf "@ %s" (Ident.name lbl)) in - fprintf ppf "@[Some record fields are undefined:%a@]" + Location.errorf ~loc "@[Some record fields are undefined:%a@]" print_labels labels | Label_not_mutable lid -> - fprintf ppf "The record field %a is not mutable" longident lid + Location.errorf ~loc "The record field %a is not mutable" longident lid | Wrong_name (eorp, ty_expected, kind, p, name, valid_names) -> - let { ty; explanation } = ty_expected in - reset_and_mark_loops ty; - if Path.is_constructor_typath p then begin - fprintf ppf "@[The field %s is not part of the record \ - argument for the %a constructor@]" - name - path p; - end else begin - fprintf ppf "@[@[<2>%s type@ %a%t@]@ " - eorp type_expr ty - (report_type_expected_explanation_opt explanation); - fprintf ppf "The %s %s does not belong to type %a@]" - (label_of_kind kind) - name (*kind*) path p; - end; - spellcheck ppf name valid_names; + Location.error_of_printer ~loc (fun ppf () -> + let { ty; explanation } = ty_expected in + reset_and_mark_loops ty; + if Path.is_constructor_typath p then begin + fprintf ppf + "@[The field %s is not part of the record \ + argument for the %a constructor@]" + name + path p; + end else begin + fprintf ppf + "@[@[<2>%s type@ %a%t@]@ \ + The %s %s does not belong to type %a@]" + eorp type_expr ty + (report_type_expected_explanation_opt explanation) + (label_of_kind kind) + name (*kind*) path p; + end; + spellcheck ppf name valid_names + ) () | Name_type_mismatch (kind, lid, tp, tpl) -> let name = label_of_kind kind in - report_ambiguous_type_error ppf env tp tpl - (function ppf -> - fprintf ppf "The %s %a@ belongs to the %s type" - name longident lid kind) - (function ppf -> - fprintf ppf "The %s %a@ belongs to one of the following %s types:" - name longident lid kind) - (function ppf -> - fprintf ppf "but a %s was expected belonging to the %s type" - name kind) + Location.error_of_printer ~loc (fun ppf () -> + report_ambiguous_type_error ppf env tp tpl + (function ppf -> + fprintf ppf "The %s %a@ belongs to the %s type" + name longident lid kind) + (function ppf -> + fprintf ppf "The %s %a@ belongs to one of the following %s types:" + name longident lid kind) + (function ppf -> + fprintf ppf "but a %s was expected belonging to the %s type" + name kind) + ) () | Invalid_format msg -> - fprintf ppf "%s" msg + Location.errorf ~loc "%s" msg | Undefined_method (ty, me, valid_methods) -> reset_and_mark_loops ty; - fprintf ppf - "@[@[This expression has type@;<1 2>%a@]@,\ - It has no method %s@]" type_expr ty me; - begin match valid_methods with - | None -> () - | Some valid_methods -> spellcheck ppf me valid_methods - end + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf + "@[@[This expression has type@;<1 2>%a@]@,\ + It has no method %s@]" type_expr ty me; + begin match valid_methods with + | None -> () + | Some valid_methods -> spellcheck ppf me valid_methods + end + ) () | Undefined_inherited_method (me, valid_methods) -> - fprintf ppf "This expression has no method %s" me; - spellcheck ppf me valid_methods; + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf "This expression has no method %s" me; + spellcheck ppf me valid_methods; + ) () | Virtual_class cl -> - fprintf ppf "Cannot instantiate the virtual class %a" + Location.errorf ~loc "Cannot instantiate the virtual class %a" longident cl | Unbound_instance_variable (var, valid_vars) -> - fprintf ppf "Unbound instance variable %s" var; - spellcheck ppf var valid_vars; + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf "Unbound instance variable %s" var; + spellcheck ppf var valid_vars; + ) () | Instance_variable_not_mutable (b, v) -> if b then - fprintf ppf "The instance variable %s is not mutable" v + Location.errorf ~loc "The instance variable %s is not mutable" v else - fprintf ppf "The value %s is not an instance variable" v + Location.errorf ~loc "The value %s is not an instance variable" v | Not_subtype(tr1, tr2) -> - report_subtyping_error ppf env tr1 "is not a subtype of" tr2 + Location.error_of_printer ~loc (fun ppf () -> + report_subtyping_error ppf env tr1 "is not a subtype of" tr2 + ) () | Outside_class -> - fprintf ppf "This object duplication occurs outside a method definition" + Location.errorf ~loc + "This object duplication occurs outside a method definition" | Value_multiply_overridden v -> - fprintf ppf "The instance variable %s is overridden several times" v + Location.errorf ~loc + "The instance variable %s is overridden several times" + v | Coercion_failure (ty, ty', trace, b) -> - report_unification_error ppf env trace - (function ppf -> - let ty, ty' = prepare_expansion (ty, ty') in - fprintf ppf - "This expression cannot be coerced to type@;<1 2>%a;@ it has type" - (type_expansion ty) ty') - (function ppf -> - fprintf ppf "but is here used with type"); - if b then - fprintf ppf ".@.@[%s@ %s@ %s@]" - "This simple coercion was not fully general." - "Hint: Consider using a fully explicit coercion" - "of the form: `(foo : ty1 :> ty2)'." + Location.error_of_printer ~loc (fun ppf () -> + Printtyp.report_unification_error ppf env trace + (function ppf -> + let ty, ty' = prepare_expansion (ty, ty') in + fprintf ppf "This expression cannot be coerced to type@;<1 2>%a;@ \ + it has type" + (type_expansion ty) ty') + (function ppf -> + fprintf ppf "but is here used with type"); + if b then + fprintf ppf ".@.@[%s@ %s@ %s@]" + "This simple coercion was not fully general." + "Hint: Consider using a fully explicit coercion" + "of the form: `(foo : ty1 :> ty2)'." + ) () | Too_many_arguments (in_function, ty, explanation) -> reset_and_mark_loops ty; if in_function then begin - fprintf ppf "This function expects too many arguments,@ "; - fprintf ppf "it should have type@ %a%t" + Location.errorf ~loc + "This function expects too many arguments,@ \ + it should have type@ %a%t" type_expr ty (report_type_expected_explanation_opt explanation) end else begin - fprintf ppf "This expression should not be a function,@ "; - fprintf ppf "the expected type is@ %a%t" + Location.errorf ~loc + "This expression should not be a function,@ \ + the expected type is@ %a%t" type_expr ty (report_type_expected_explanation_opt explanation) end @@ -4980,151 +5091,159 @@ let report_error env ppf = function | l -> sprintf "but its first argument is labelled %s" (prefixed_label_name l) in reset_and_mark_loops ty; - fprintf ppf "@[@[<2>This function should have type@ %a%t@]@,%s@]" + Location.errorf ~loc + "@[@[<2>This function should have type@ %a%t@]@,%s@]" type_expr ty (report_type_expected_explanation_opt explanation) (label_mark l) | Scoping_let_module(id, ty) -> reset_and_mark_loops ty; - fprintf ppf - "This `let module' expression has type@ %a@ " type_expr ty; - fprintf ppf - "In this type, the locally bound module name %s escapes its scope" id + Location.errorf ~loc + "This `let module' expression has type@ %a@ \ + In this type, the locally bound module name %s escapes its scope" + type_expr ty id | Masked_instance_variable lid -> - fprintf ppf + Location.errorf ~loc "The instance variable %a@ \ cannot be accessed from the definition of another instance variable" longident lid | Private_type ty -> - fprintf ppf "Cannot create values of the private type %a" type_expr ty + Location.errorf ~loc "Cannot create values of the private type %a" + type_expr ty | Private_label (lid, ty) -> - fprintf ppf "Cannot assign field %a of the private type %a" + Location.errorf ~loc "Cannot assign field %a of the private type %a" longident lid type_expr ty + | Private_constructor (constr, ty) -> + Location.errorf ~loc + "Cannot use private constructor %s to create values of type %a" + constr.cstr_name type_expr ty | Not_a_variant_type lid -> - fprintf ppf "The type %a@ is not a variant type" longident lid + Location.errorf ~loc "The type %a@ is not a variant type" longident lid | Incoherent_label_order -> - fprintf ppf "This function is applied to arguments@ "; - fprintf ppf "in an order different from other calls.@ "; - fprintf ppf "This is only allowed when the real type is known." + Location.errorf ~loc + "This function is applied to arguments@ \ + in an order different from other calls.@ \ + This is only allowed when the real type is known." | Less_general (kind, trace) -> - report_unification_error ppf env trace + report_unification_error ~loc env trace (fun ppf -> fprintf ppf "This %s has type" kind) (fun ppf -> fprintf ppf "which is less general than") | Modules_not_allowed -> - fprintf ppf "Modules are not allowed in this pattern." + Location.errorf ~loc "Modules are not allowed in this pattern." | Cannot_infer_signature -> - fprintf ppf + Location.errorf ~loc "The signature for this packaged module couldn't be inferred." | Not_a_packed_module ty -> - fprintf ppf + Location.errorf ~loc "This expression is packed module, but the expected type is@ %a" type_expr ty - | Unexpected_existential (reason, name, types) -> ( - begin match reason with - | In_class_args -> - fprintf ppf "Existential types are not allowed in class arguments,@ " - | In_class_def -> - fprintf ppf "Existential types are not allowed in bindings inside \ - class definition,@ " - | In_self_pattern -> - fprintf ppf "Existential types are not allowed in self patterns,@ " - | At_toplevel -> - fprintf ppf - "Existential types are not allowed in toplevel bindings,@ " - | In_group -> - fprintf ppf - "Existential types are not allowed in \"let ... and ...\" bindings,\ - @ " - | In_rec -> - fprintf ppf - "Existential types are not allowed in recursive bindings,@ " - | With_attributes -> - fprintf ppf - "Existential types are not allowed in presence of attributes,@ " - end; - try - let example = List.find (fun ty -> ty <> "$" ^ name) types in - fprintf ppf - "but this pattern introduces the existential type %s." example - with Not_found -> - fprintf ppf - "but the constructor %s introduces existential types." name - ) + | Unexpected_existential (reason, name, types) -> + let reason_str = + match reason with + | In_class_args -> + "Existential types are not allowed in class arguments" + | In_class_def -> + "Existential types are not allowed in bindings inside \ + class definition" + | In_self_pattern -> + "Existential types are not allowed in self patterns" + | At_toplevel -> + "Existential types are not allowed in toplevel bindings" + | In_group -> + "Existential types are not allowed in \"let ... and ...\" bindings" + | In_rec -> + "Existential types are not allowed in recursive bindings" + | With_attributes -> + "Existential types are not allowed in presence of attributes" + in + begin match List.find (fun ty -> ty <> "$" ^ name) types with + | example -> + Location.errorf ~loc + "%s,@ but this pattern introduces the existential type %s." + reason_str example + | exception Not_found -> + Location.errorf ~loc + "%s,@ but the constructor %s introduces existential types." + reason_str name + end | Invalid_interval -> - fprintf ppf "@[Only character intervals are supported in patterns.@]" + Location.errorf ~loc + "@[Only character intervals are supported in patterns.@]" | Invalid_for_loop_index -> - fprintf ppf + Location.errorf ~loc "@[Invalid for-loop index: only variables and _ are allowed.@]" | No_value_clauses -> - fprintf ppf + Location.errorf ~loc "None of the patterns in this 'match' expression match values." | Exception_pattern_disallowed -> - fprintf ppf + Location.errorf ~loc "@[Exception patterns are not allowed in this position.@]" | Mixed_value_and_exception_patterns_under_guard -> - fprintf ppf + Location.errorf ~loc "@[Mixing value and exception patterns under when-guards is not \ supported.@]" | Inlined_record_escape -> - fprintf ppf + Location.errorf ~loc "@[This form is not allowed as the type of the inlined record could \ escape.@]" | Inlined_record_expected -> - fprintf ppf + Location.errorf ~loc "@[This constructor expects an inlined record argument.@]" | Unrefuted_pattern pat -> - fprintf ppf + Location.errorf ~loc "@[%s@ %s@ %a@]" "This match case could not be refuted." "Here is an example of a value that would reach it:" Printpat.top_pretty pat | Invalid_extension_constructor_payload -> - fprintf ppf + Location.errorf ~loc "Invalid [%%extension_constructor] payload, a constructor is expected." | Not_an_extension_constructor -> - fprintf ppf + Location.errorf ~loc "This constructor is not an extension constructor." | Literal_overflow ty -> - fprintf ppf "Integer literal exceeds the range of representable \ - integers of type %s" ty + Location.errorf ~loc + "Integer literal exceeds the range of representable integers of type %s" + ty | Unknown_literal (n, m) -> - fprintf ppf "Unknown modifier '%c' for literal %s%c" m n m + Location.errorf ~loc "Unknown modifier '%c' for literal %s%c" m n m | Illegal_letrec_pat -> - fprintf ppf + Location.errorf ~loc "Only variables are allowed as left-hand side of `let rec'" | Illegal_letrec_expr -> - fprintf ppf + Location.errorf ~loc "This kind of expression is not allowed as right-hand side of `let rec'" | Illegal_class_expr -> - fprintf ppf "This kind of recursive class expression is not allowed" + Location.errorf ~loc + "This kind of recursive class expression is not allowed" | Letop_type_clash(name, trace) -> - report_unification_error ppf env trace + report_unification_error ~loc env trace (function ppf -> fprintf ppf "The operator %s has type" name) (function ppf -> fprintf ppf "but it was expected to have type") | Andop_type_clash(name, trace) -> - report_unification_error ppf env trace + report_unification_error ~loc env trace (function ppf -> fprintf ppf "The operator %s has type" name) (function ppf -> fprintf ppf "but it was expected to have type") | Bindings_type_clash(trace) -> - report_unification_error ppf env trace + report_unification_error ~loc env trace (function ppf -> fprintf ppf "These bindings have type") (function ppf -> fprintf ppf "but bindings were expected of type") | Empty_pattern -> assert false -let report_error env ppf err = - wrap_printing_env ~error:true env (fun () -> report_error env ppf err) +let report_error ~loc env err = + wrap_printing_env ~error:true env (fun () -> report_error ~loc env err) let () = Location.register_error_of_exn (function | Error (loc, env, err) -> - Some (Location.error_of_printer ~loc (report_error env) err) + Some (report_error ~loc env err) | Error_forward err -> Some err | _ -> @@ -5132,7 +5251,9 @@ let () = ) let () = - Env.add_delayed_check_forward := add_delayed_check + Persistent_env.add_delayed_check_forward := add_delayed_check; + Env.add_delayed_check_forward := add_delayed_check; + () (* drop ?recarg argument from the external API *) let type_expect ?in_function env e ty = type_expect ?in_function env e ty diff --git a/typing/typecore.mli b/typing/typecore.mli index 08f865f1..e28f75e0 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -17,7 +17,6 @@ open Asttypes open Types -open Format (* This variant is used to print improved error messages, and does not affect the behavior of the typechecker itself. @@ -119,12 +118,14 @@ val self_coercion : (Path.t * Location.t list ref) list ref type error = | Constructor_arity_mismatch of Longident.t * int * int | Label_mismatch of Longident.t * Ctype.Unification_trace.t - | Pattern_type_clash of Ctype.Unification_trace.t + | Pattern_type_clash of + Ctype.Unification_trace.t * Typedtree.pattern_desc option | Or_pattern_type_clash of Ident.t * Ctype.Unification_trace.t | Multiply_bound_variable of string | Orpat_vars of Ident.t * Ident.t list | Expr_type_clash of Ctype.Unification_trace.t * type_forcing_context option + * Typedtree.expression_desc option | Apply_non_function of type_expr | Apply_wrong_label of arg_label * type_expr | Label_multiply_defined of string @@ -140,6 +141,7 @@ type error = | Virtual_class of Longident.t | Private_type of type_expr | Private_label of Longident.t * type_expr + | Private_constructor of constructor_description * type_expr | Unbound_instance_variable of string * string list | Instance_variable_not_mutable of bool * string | Not_subtype of Ctype.Unification_trace.t * Ctype.Unification_trace.t @@ -181,7 +183,7 @@ type error = exception Error of Location.t * Env.t * error exception Error_forward of Location.error -val report_error: Env.t -> formatter -> error -> unit +val report_error: loc:Location.t -> Env.t -> error -> Location.error (** @deprecated. Use {!Location.error_of_exn}, {!Location.print_report}. *) (* Forward declaration, to be filled in by Typemod.type_module *) diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml deleted file mode 100644 index 3c3fe34c..00000000 --- a/typing/typedtreeIter.ml +++ /dev/null @@ -1,709 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) -(* *) -(* Copyright 2007 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* -TODO: - - 2012/05/10: Follow camlp4 way of building map and iter using classes - and inheritance ? -*) - -open Asttypes -open Typedtree - -module type IteratorArgument = sig - - val enter_structure : structure -> unit - val enter_value_description : value_description -> unit - val enter_type_extension : type_extension -> unit - val enter_type_exception : type_exception -> unit - val enter_extension_constructor : extension_constructor -> unit - val enter_pattern : pattern -> unit - val enter_expression : expression -> unit - val enter_package_type : package_type -> unit - val enter_signature : signature -> unit - val enter_signature_item : signature_item -> unit - val enter_module_type_declaration : module_type_declaration -> unit - val enter_module_type : module_type -> unit - val enter_module_expr : module_expr -> unit - val enter_with_constraint : with_constraint -> unit - val enter_class_expr : class_expr -> unit - val enter_class_signature : class_signature -> unit - val enter_class_declaration : class_declaration -> unit - val enter_class_description : class_description -> unit - val enter_class_type_declaration : class_type_declaration -> unit - val enter_class_type : class_type -> unit - val enter_class_type_field : class_type_field -> unit - val enter_core_type : core_type -> unit - val enter_class_structure : class_structure -> unit - val enter_class_field : class_field -> unit - val enter_structure_item : structure_item -> unit - - - val leave_structure : structure -> unit - val leave_value_description : value_description -> unit - val leave_type_extension : type_extension -> unit - val leave_type_exception : type_exception -> unit - val leave_extension_constructor : extension_constructor -> unit - val leave_pattern : pattern -> unit - val leave_expression : expression -> unit - val leave_package_type : package_type -> unit - val leave_signature : signature -> unit - val leave_signature_item : signature_item -> unit - val leave_module_type_declaration : module_type_declaration -> unit - val leave_module_type : module_type -> unit - val leave_module_expr : module_expr -> unit - val leave_with_constraint : with_constraint -> unit - val leave_class_expr : class_expr -> unit - val leave_class_signature : class_signature -> unit - val leave_class_declaration : class_declaration -> unit - val leave_class_description : class_description -> unit - val leave_class_type_declaration : class_type_declaration -> unit - val leave_class_type : class_type -> unit - val leave_class_type_field : class_type_field -> unit - val leave_core_type : core_type -> unit - val leave_class_structure : class_structure -> unit - val leave_class_field : class_field -> unit - val leave_structure_item : structure_item -> unit - - val enter_bindings : rec_flag -> unit - val enter_binding : value_binding -> unit - val leave_binding : value_binding -> unit - val leave_bindings : rec_flag -> unit - - val enter_type_declarations : rec_flag -> unit - val enter_type_declaration : type_declaration -> unit - val leave_type_declaration : type_declaration -> unit - val leave_type_declarations : rec_flag -> unit - - end - -module MakeIterator(Iter : IteratorArgument) : sig - - val iter_structure : structure -> unit - val iter_signature : signature -> unit - val iter_structure_item : structure_item -> unit - val iter_signature_item : signature_item -> unit - val iter_expression : expression -> unit - val iter_module_type : module_type -> unit - val iter_pattern : pattern -> unit - val iter_class_expr : class_expr -> unit - - end = struct - - let may_iter f v = - match v with - None -> () - | Some x -> f x - - - let rec iter_structure str = - Iter.enter_structure str; - List.iter iter_structure_item str.str_items; - Iter.leave_structure str - - - and iter_binding vb = - Iter.enter_binding vb; - iter_pattern vb.vb_pat; - iter_expression vb.vb_expr; - Iter.leave_binding vb - - and iter_bindings rec_flag list = - Iter.enter_bindings rec_flag; - List.iter iter_binding list; - Iter.leave_bindings rec_flag - - and iter_case {c_lhs; c_guard; c_rhs} = - iter_pattern c_lhs; - may_iter iter_expression c_guard; - iter_expression c_rhs - - and iter_cases cases = - List.iter iter_case cases - - and iter_structure_item item = - Iter.enter_structure_item item; - begin - match item.str_desc with - Tstr_eval (exp, _attrs) -> iter_expression exp - | Tstr_value (rec_flag, list) -> - iter_bindings rec_flag list - | Tstr_primitive vd -> iter_value_description vd - | Tstr_type (rf, list) -> iter_type_declarations rf list - | Tstr_typext tyext -> iter_type_extension tyext - | Tstr_exception ext -> iter_type_exception ext - | Tstr_module x -> iter_module_binding x - | Tstr_recmodule list -> List.iter iter_module_binding list - | Tstr_modtype mtd -> iter_module_type_declaration mtd - | Tstr_open od -> iter_module_expr od.open_expr - | Tstr_class list -> - List.iter (fun (ci, _) -> iter_class_declaration ci) list - | Tstr_class_type list -> - List.iter - (fun (_, _, ct) -> iter_class_type_declaration ct) - list - | Tstr_include incl -> iter_module_expr incl.incl_mod - | Tstr_attribute _ -> - () - end; - Iter.leave_structure_item item - - and iter_module_binding x = - iter_module_expr x.mb_expr - - and iter_value_description v = - Iter.enter_value_description v; - iter_core_type v.val_desc; - Iter.leave_value_description v - - and iter_constructor_arguments = function - | Cstr_tuple l -> List.iter iter_core_type l - | Cstr_record l -> List.iter (fun ld -> iter_core_type ld.ld_type) l - - and iter_constructor_declaration cd = - iter_constructor_arguments cd.cd_args; - option iter_core_type cd.cd_res; - - and iter_type_parameter (ct, _v) = - iter_core_type ct - - and iter_type_declaration decl = - Iter.enter_type_declaration decl; - List.iter iter_type_parameter decl.typ_params; - List.iter (fun (ct1, ct2, _loc) -> - iter_core_type ct1; - iter_core_type ct2 - ) decl.typ_cstrs; - begin match decl.typ_kind with - Ttype_abstract -> () - | Ttype_variant list -> - List.iter iter_constructor_declaration list - | Ttype_record list -> - List.iter - (fun ld -> - iter_core_type ld.ld_type - ) list - | Ttype_open -> () - end; - option iter_core_type decl.typ_manifest; - Iter.leave_type_declaration decl - - and iter_type_declarations rec_flag decls = - Iter.enter_type_declarations rec_flag; - List.iter iter_type_declaration decls; - Iter.leave_type_declarations rec_flag - - and iter_extension_constructor ext = - Iter.enter_extension_constructor ext; - begin match ext.ext_kind with - Text_decl(args, ret) -> - iter_constructor_arguments args; - option iter_core_type ret - | Text_rebind _ -> () - end; - Iter.leave_extension_constructor ext; - - and iter_type_extension tyext = - Iter.enter_type_extension tyext; - List.iter iter_type_parameter tyext.tyext_params; - List.iter iter_extension_constructor tyext.tyext_constructors; - Iter.leave_type_extension tyext - - and iter_type_exception tyexn = - Iter.enter_type_exception tyexn; - iter_extension_constructor tyexn.tyexn_constructor; - Iter.leave_type_exception tyexn - - and iter_pattern pat = - Iter.enter_pattern pat; - List.iter (fun (cstr, _, _attrs) -> match cstr with - | Tpat_type _ -> () - | Tpat_unpack -> () - | Tpat_open _ -> () - | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra; - begin - match pat.pat_desc with - Tpat_any -> () - | Tpat_var _ -> () - | Tpat_alias (pat1, _, _) -> iter_pattern pat1 - | Tpat_constant _ -> () - | Tpat_tuple list -> - List.iter iter_pattern list - | Tpat_construct (_, _, args) -> - List.iter iter_pattern args - | Tpat_variant (_, pato, _) -> - begin match pato with - None -> () - | Some pat -> iter_pattern pat - end - | Tpat_record (list, _closed) -> - List.iter (fun (_, _, pat) -> iter_pattern pat) list - | Tpat_array list -> List.iter iter_pattern list - | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2 - | Tpat_lazy p - | Tpat_exception p -> iter_pattern p - end; - Iter.leave_pattern pat - - and option f x = match x with None -> () | Some e -> f e - - and iter_expression exp = - Iter.enter_expression exp; - List.iter (function (cstr, _, _attrs) -> - match cstr with - Texp_constraint ct -> - iter_core_type ct - | Texp_coerce (cty1, cty2) -> - option iter_core_type cty1; iter_core_type cty2 - | Texp_poly cto -> option iter_core_type cto - | Texp_newtype _ -> ()) - exp.exp_extra; - begin - match exp.exp_desc with - Texp_ident _ -> () - | Texp_constant _ -> () - | Texp_let (rec_flag, list, exp) -> - iter_bindings rec_flag list; - iter_expression exp - | Texp_function { cases; _ } -> - iter_cases cases - | Texp_apply (exp, list) -> - iter_expression exp; - List.iter (fun (_label, expo) -> - match expo with - None -> () - | Some exp -> iter_expression exp - ) list - | Texp_match (exp, list, _) -> - iter_expression exp; - iter_cases list - | Texp_try (exp, list) -> - iter_expression exp; - iter_cases list - | Texp_tuple list -> - List.iter iter_expression list - | Texp_construct (_, _, args) -> - List.iter iter_expression args - | Texp_variant (_label, expo) -> - begin match expo with - None -> () - | Some exp -> iter_expression exp - end - | Texp_record { fields; extended_expression; _ } -> - Array.iter (function - | _, Kept _ -> () - | _, Overridden (_, exp) -> iter_expression exp) - fields; - begin match extended_expression with - None -> () - | Some exp -> iter_expression exp - end - | Texp_field (exp, _, _label) -> - iter_expression exp - | Texp_setfield (exp1, _, _label, exp2) -> - iter_expression exp1; - iter_expression exp2 - | Texp_array list -> - List.iter iter_expression list - | Texp_ifthenelse (exp1, exp2, expo) -> - iter_expression exp1; - iter_expression exp2; - begin match expo with - None -> () - | Some exp -> iter_expression exp - end - | Texp_sequence (exp1, exp2) -> - iter_expression exp1; - iter_expression exp2 - | Texp_while (exp1, exp2) -> - iter_expression exp1; - iter_expression exp2 - | Texp_for (_id, _, exp1, exp2, _dir, exp3) -> - iter_expression exp1; - iter_expression exp2; - iter_expression exp3 - | Texp_send (exp, _meth, expo) -> - iter_expression exp; - begin - match expo with - None -> () - | Some exp -> iter_expression exp - end - | Texp_new _ -> () - | Texp_instvar _ -> () - | Texp_setinstvar (_, _, _, exp) -> - iter_expression exp - | Texp_override (_, list) -> - List.iter (fun (_path, _, exp) -> - iter_expression exp - ) list - | Texp_letmodule (_id, _, _, mexpr, exp) -> - iter_module_expr mexpr; - iter_expression exp - | Texp_letexception (cd, exp) -> - iter_extension_constructor cd; - iter_expression exp - | Texp_assert exp -> iter_expression exp - | Texp_lazy exp -> iter_expression exp - | Texp_object (cl, _) -> - iter_class_structure cl - | Texp_pack (mexpr) -> - iter_module_expr mexpr - | Texp_letop{let_; ands; param = _; body; partial = _} -> - iter_binding_op let_; - List.iter iter_binding_op ands; - iter_case body - | Texp_unreachable -> - () - | Texp_extension_constructor _ -> - () - | Texp_open (od, e) -> - iter_module_expr od.open_expr; - iter_expression e - end; - Iter.leave_expression exp; - - and iter_binding_op bop = - iter_expression bop.bop_exp - - and iter_package_type pack = - Iter.enter_package_type pack; - List.iter (fun (_s, ct) -> iter_core_type ct) pack.pack_fields; - Iter.leave_package_type pack; - - and iter_signature sg = - Iter.enter_signature sg; - List.iter iter_signature_item sg.sig_items; - Iter.leave_signature sg; - - and iter_signature_item item = - Iter.enter_signature_item item; - begin - match item.sig_desc with - Tsig_value vd -> - iter_value_description vd - | Tsig_type (rf, list) -> - iter_type_declarations rf list - | Tsig_typesubst list -> - iter_type_declarations Nonrecursive list - | Tsig_exception ext -> - iter_type_exception ext - | Tsig_typext tyext -> - iter_type_extension tyext - | Tsig_module md -> - iter_module_type md.md_type - | Tsig_modsubst _ -> () - | Tsig_recmodule list -> - List.iter (fun md -> iter_module_type md.md_type) list - | Tsig_modtype mtd -> - iter_module_type_declaration mtd - | Tsig_open _ -> () - | Tsig_include incl -> iter_module_type incl.incl_mod - | Tsig_class list -> - List.iter iter_class_description list - | Tsig_class_type list -> - List.iter iter_class_type_declaration list - | Tsig_attribute _ -> () - end; - Iter.leave_signature_item item; - - and iter_module_type_declaration mtd = - Iter.enter_module_type_declaration mtd; - begin - match mtd.mtd_type with - | None -> () - | Some mtype -> iter_module_type mtype - end; - Iter.leave_module_type_declaration mtd - - and iter_class_declaration cd = - Iter.enter_class_declaration cd; - List.iter iter_type_parameter cd.ci_params; - iter_class_expr cd.ci_expr; - Iter.leave_class_declaration cd; - - and iter_class_description cd = - Iter.enter_class_description cd; - List.iter iter_type_parameter cd.ci_params; - iter_class_type cd.ci_expr; - Iter.leave_class_description cd; - - and iter_class_type_declaration cd = - Iter.enter_class_type_declaration cd; - List.iter iter_type_parameter cd.ci_params; - iter_class_type cd.ci_expr; - Iter.leave_class_type_declaration cd; - - and iter_module_type mty = - Iter.enter_module_type mty; - begin - match mty.mty_desc with - Tmty_ident _ -> () - | Tmty_alias _ -> () - | Tmty_signature sg -> iter_signature sg - | Tmty_functor (_, _, mtype1, mtype2) -> - Misc.may iter_module_type mtype1; iter_module_type mtype2 - | Tmty_with (mtype, list) -> - iter_module_type mtype; - List.iter (fun (_path, _, withc) -> - iter_with_constraint withc - ) list - | Tmty_typeof mexpr -> - iter_module_expr mexpr - end; - Iter.leave_module_type mty; - - and iter_with_constraint cstr = - Iter.enter_with_constraint cstr; - begin - match cstr with - Twith_type decl -> iter_type_declaration decl - | Twith_module _ -> () - | Twith_typesubst decl -> iter_type_declaration decl - | Twith_modsubst _ -> () - end; - Iter.leave_with_constraint cstr; - - and iter_module_expr mexpr = - Iter.enter_module_expr mexpr; - begin - match mexpr.mod_desc with - Tmod_ident _ -> () - | Tmod_structure st -> iter_structure st - | Tmod_functor (_, _, mtype, mexpr) -> - Misc.may iter_module_type mtype; - iter_module_expr mexpr - | Tmod_apply (mexp1, mexp2, _) -> - iter_module_expr mexp1; - iter_module_expr mexp2 - | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) -> - iter_module_expr mexpr - | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> - iter_module_expr mexpr; - iter_module_type mtype - | Tmod_unpack (exp, _mty) -> - iter_expression exp -(* iter_module_type mty *) - end; - Iter.leave_module_expr mexpr; - - and iter_class_expr cexpr = - Iter.enter_class_expr cexpr; - begin - match cexpr.cl_desc with - | Tcl_constraint (cl, None, _, _, _ ) -> - iter_class_expr cl; - | Tcl_structure clstr -> iter_class_structure clstr - | Tcl_fun (_label, pat, priv, cl, _partial) -> - iter_pattern pat; - List.iter (fun (_id, exp) -> iter_expression exp) priv; - iter_class_expr cl - - | Tcl_apply (cl, args) -> - iter_class_expr cl; - List.iter (fun (_label, expo) -> - match expo with - None -> () - | Some exp -> iter_expression exp - ) args - - | Tcl_let (rec_flat, bindings, ivars, cl) -> - iter_bindings rec_flat bindings; - List.iter (fun (_id, exp) -> iter_expression exp) ivars; - iter_class_expr cl - - | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) -> - iter_class_expr cl; - iter_class_type clty - - | Tcl_ident (_, _, tyl) -> - List.iter iter_core_type tyl - - | Tcl_open (_, e) -> - iter_class_expr e - end; - Iter.leave_class_expr cexpr; - - and iter_class_type ct = - Iter.enter_class_type ct; - begin - match ct.cltyp_desc with - Tcty_signature csg -> iter_class_signature csg - | Tcty_constr (_path, _, list) -> - List.iter iter_core_type list - | Tcty_arrow (_label, ct, cl) -> - iter_core_type ct; - iter_class_type cl - | Tcty_open (_, e) -> - iter_class_type e - end; - Iter.leave_class_type ct; - - and iter_class_signature cs = - Iter.enter_class_signature cs; - iter_core_type cs.csig_self; - List.iter iter_class_type_field cs.csig_fields; - Iter.leave_class_signature cs - - - and iter_class_type_field ctf = - Iter.enter_class_type_field ctf; - begin - match ctf.ctf_desc with - Tctf_inherit ct -> iter_class_type ct - | Tctf_val (_s, _mut, _virt, ct) -> - iter_core_type ct - | Tctf_method (_s, _priv, _virt, ct) -> - iter_core_type ct - | Tctf_constraint (ct1, ct2) -> - iter_core_type ct1; - iter_core_type ct2 - | Tctf_attribute _ -> () - end; - Iter.leave_class_type_field ctf - - and iter_core_type ct = - Iter.enter_core_type ct; - begin - match ct.ctyp_desc with - Ttyp_any -> () - | Ttyp_var _ -> () - | Ttyp_arrow (_label, ct1, ct2) -> - iter_core_type ct1; - iter_core_type ct2 - | Ttyp_tuple list -> List.iter iter_core_type list - | Ttyp_constr (_path, _, list) -> - List.iter iter_core_type list - | Ttyp_object (list, _o) -> - List.iter iter_object_field list - | Ttyp_class (_path, _, list) -> - List.iter iter_core_type list - | Ttyp_alias (ct, _s) -> - iter_core_type ct - | Ttyp_variant (list, _bool, _labels) -> - List.iter iter_row_field list - | Ttyp_poly (_list, ct) -> iter_core_type ct - | Ttyp_package pack -> iter_package_type pack - end; - Iter.leave_core_type ct - - and iter_class_structure cs = - Iter.enter_class_structure cs; - iter_pattern cs.cstr_self; - List.iter iter_class_field cs.cstr_fields; - Iter.leave_class_structure cs; - - - and iter_row_field rf = - match rf.rf_desc with - | Ttag (_label, _bool, list) -> - List.iter iter_core_type list - | Tinherit ct -> iter_core_type ct - - and iter_object_field ofield = - match ofield.of_desc with - | OTtag (_, ct) | OTinherit ct -> iter_core_type ct - - and iter_class_field cf = - Iter.enter_class_field cf; - begin - match cf.cf_desc with - Tcf_inherit (_ovf, cl, _super, _vals, _meths) -> - iter_class_expr cl - | Tcf_constraint (cty, cty') -> - iter_core_type cty; - iter_core_type cty' - | Tcf_val (_lab, _, _, Tcfk_virtual cty, _) -> - iter_core_type cty - | Tcf_val (_lab, _, _, Tcfk_concrete (_, exp), _) -> - iter_expression exp - | Tcf_method (_lab, _, Tcfk_virtual cty) -> - iter_core_type cty - | Tcf_method (_lab, _, Tcfk_concrete (_, exp)) -> - iter_expression exp - | Tcf_initializer exp -> - iter_expression exp - | Tcf_attribute _ -> () - end; - Iter.leave_class_field cf; - end - -module DefaultIteratorArgument = struct - - let enter_structure _ = () - let enter_value_description _ = () - let enter_type_extension _ = () - let enter_type_exception _ = () - let enter_extension_constructor _ = () - let enter_pattern _ = () - let enter_expression _ = () - let enter_package_type _ = () - let enter_signature _ = () - let enter_signature_item _ = () - let enter_module_type_declaration _ = () - let enter_module_type _ = () - let enter_module_expr _ = () - let enter_with_constraint _ = () - let enter_class_expr _ = () - let enter_class_signature _ = () - let enter_class_declaration _ = () - let enter_class_description _ = () - let enter_class_type_declaration _ = () - let enter_class_type _ = () - let enter_class_type_field _ = () - let enter_core_type _ = () - let enter_class_structure _ = () - let enter_class_field _ = () - let enter_structure_item _ = () - - - let leave_structure _ = () - let leave_value_description _ = () - let leave_type_extension _ = () - let leave_type_exception _ = () - let leave_extension_constructor _ = () - let leave_pattern _ = () - let leave_expression _ = () - let leave_package_type _ = () - let leave_signature _ = () - let leave_signature_item _ = () - let leave_module_type_declaration _ = () - let leave_module_type _ = () - let leave_module_expr _ = () - let leave_with_constraint _ = () - let leave_class_expr _ = () - let leave_class_signature _ = () - let leave_class_declaration _ = () - let leave_class_description _ = () - let leave_class_type_declaration _ = () - let leave_class_type _ = () - let leave_class_type_field _ = () - let leave_core_type _ = () - let leave_class_structure _ = () - let leave_class_field _ = () - let leave_structure_item _ = () - - let enter_binding _ = () - let leave_binding _ = () - - let enter_bindings _ = () - let leave_bindings _ = () - - let enter_type_declaration _ = () - let leave_type_declaration _ = () - - let enter_type_declarations _ = () - let leave_type_declarations _ = () -end diff --git a/typing/typedtreeIter.mli b/typing/typedtreeIter.mli deleted file mode 100644 index 2e2d0d05..00000000 --- a/typing/typedtreeIter.mli +++ /dev/null @@ -1,99 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) -(* *) -(* Copyright 2007 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Asttypes -open Typedtree - - -module type IteratorArgument = sig - val enter_structure : structure -> unit - val enter_value_description : value_description -> unit - val enter_type_extension : type_extension -> unit - val enter_type_exception : type_exception -> unit - val enter_extension_constructor : extension_constructor -> unit - val enter_pattern : pattern -> unit - val enter_expression : expression -> unit - val enter_package_type : package_type -> unit - val enter_signature : signature -> unit - val enter_signature_item : signature_item -> unit - val enter_module_type_declaration : module_type_declaration -> unit - val enter_module_type : module_type -> unit - val enter_module_expr : module_expr -> unit - val enter_with_constraint : with_constraint -> unit - val enter_class_expr : class_expr -> unit - val enter_class_signature : class_signature -> unit - val enter_class_declaration : class_declaration -> unit - val enter_class_description : class_description -> unit - val enter_class_type_declaration : class_type_declaration -> unit - val enter_class_type : class_type -> unit - val enter_class_type_field : class_type_field -> unit - val enter_core_type : core_type -> unit - val enter_class_structure : class_structure -> unit - val enter_class_field : class_field -> unit - val enter_structure_item : structure_item -> unit - - - val leave_structure : structure -> unit - val leave_value_description : value_description -> unit - val leave_type_extension : type_extension -> unit - val leave_type_exception : type_exception -> unit - val leave_extension_constructor : extension_constructor -> unit - val leave_pattern : pattern -> unit - val leave_expression : expression -> unit - val leave_package_type : package_type -> unit - val leave_signature : signature -> unit - val leave_signature_item : signature_item -> unit - val leave_module_type_declaration : module_type_declaration -> unit - val leave_module_type : module_type -> unit - val leave_module_expr : module_expr -> unit - val leave_with_constraint : with_constraint -> unit - val leave_class_expr : class_expr -> unit - val leave_class_signature : class_signature -> unit - val leave_class_declaration : class_declaration -> unit - val leave_class_description : class_description -> unit - val leave_class_type_declaration : class_type_declaration -> unit - val leave_class_type : class_type -> unit - val leave_class_type_field : class_type_field -> unit - val leave_core_type : core_type -> unit - val leave_class_structure : class_structure -> unit - val leave_class_field : class_field -> unit - val leave_structure_item : structure_item -> unit - - val enter_bindings : rec_flag -> unit - val enter_binding : value_binding -> unit - val leave_binding : value_binding -> unit - val leave_bindings : rec_flag -> unit - - val enter_type_declarations : rec_flag -> unit - val enter_type_declaration : type_declaration -> unit - val leave_type_declaration : type_declaration -> unit - val leave_type_declarations : rec_flag -> unit - -end - -module MakeIterator : - functor (Iter : IteratorArgument) -> - sig - val iter_structure : structure -> unit - val iter_signature : signature -> unit - val iter_structure_item : structure_item -> unit - val iter_signature_item : signature_item -> unit - val iter_expression : expression -> unit - val iter_module_type : module_type -> unit - val iter_pattern : pattern -> unit - val iter_class_expr : class_expr -> unit - end - -module DefaultIteratorArgument : IteratorArgument diff --git a/typing/typemod.ml b/typing/typemod.ml index b89f0f0d..93ed01ef 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -110,13 +110,6 @@ let update_location loc = function | err -> err let () = Typetexp.typemod_update_location := update_location -module ImplementationHooks = Misc.MakeHooks(struct - type t = Typedtree.structure * Typedtree.module_coercion - end) -module InterfaceHooks = Misc.MakeHooks(struct - type t = Typedtree.signature - end) - open Typedtree let rec path_concat head p = @@ -1193,18 +1186,14 @@ and transl_signature env sg = sg, final_env | Psig_typesubst sdecls -> - List.iter (fun td -> - if td.ptype_kind <> Ptype_abstract || td.ptype_manifest = None || - td.ptype_private = Private - then - (* This error should be a parsing error, - once we have nice error messages there. *) - raise (Error (td.ptype_loc, env, Invalid_type_subst_rhs)) - ) sdecls; let (decls, newenv) = Typedecl.transl_type_decl env Nonrecursive sdecls in List.iter (fun td -> + if td.typ_kind <> Ttype_abstract || td.typ_manifest = None || + td.typ_private = Private + then + raise (Error (td.typ_loc, env, Invalid_type_subst_rhs)); let info = let subst = Subst.add_type_function (Pident td.typ_id) @@ -2318,9 +2307,6 @@ let type_toplevel_phrase env s = Env.reset_required_globals (); let (str, sg, to_remove_from_sg, env) = type_structure ~toplevel:true false None env s Location.none in - let (str, _coerce) = ImplementationHooks.apply_hooks - { Misc.sourcefile = "//toplevel//" } (str, Tcoerce_none) - in (str, sg, to_remove_from_sg, env) let type_module_alias = type_module ~alias:true true false None @@ -2501,16 +2487,12 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = (Array.of_list (Cmt_format.get_saved_types ()))) (Some sourcefile) initial_env None) -let type_implementation sourcefile outputprefix modulename initial_env ast = - ImplementationHooks.apply_hooks { Misc.sourcefile } - (type_implementation sourcefile outputprefix modulename initial_env ast) - let save_signature modname tsg outputprefix source_file initial_env cmi = Cmt_format.save_cmt (outputprefix ^ ".cmti") modname (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi) -let type_interface sourcefile env ast = - InterfaceHooks.apply_hooks { Misc.sourcefile } (transl_signature env ast) +let type_interface env ast = + transl_signature env ast (* "Packaging" of several compilation units into one unit having them as sub-modules. *) diff --git a/typing/typemod.mli b/typing/typemod.mli index ac895d39..f74a57d8 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -13,7 +13,7 @@ (* *) (**************************************************************************) -(** Type-checking of the module language and typed ast plugin hooks +(** Type-checking of the module language and typed ast hooks {b Warning:} this module is unstable and part of {{!Compiler_libs}compiler-libs}. @@ -41,7 +41,7 @@ val type_implementation: string -> string -> string -> Env.t -> Parsetree.structure -> Typedtree.structure * Typedtree.module_coercion val type_interface: - string -> Env.t -> Parsetree.signature -> Typedtree.signature + Env.t -> Parsetree.signature -> Typedtree.signature val transl_signature: Env.t -> Parsetree.signature -> Typedtree.signature val check_nongen_schemes: @@ -135,9 +135,3 @@ exception Error of Location.t * Env.t * error exception Error_forward of Location.error val report_error: Env.t -> formatter -> error -> unit - - -module ImplementationHooks : Misc.HookSig - with type t = Typedtree.structure * Typedtree.module_coercion -module InterfaceHooks : Misc.HookSig - with type t = Typedtree.signature diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 0fc8882e..36501f08 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -285,6 +285,9 @@ let type_variable loc name = with Not_found -> raise(Error(loc, Env.empty, Unbound_type_variable ("'" ^ name))) +let valid_tyvar_name name = + name <> "" && name.[0] <> '_' + let transl_type_param env styp = let loc = styp.ptyp_loc in match styp.ptyp_desc with @@ -295,7 +298,7 @@ let transl_type_param env styp = | Ptyp_var name -> let ty = try - if name <> "" && name.[0] = '_' then + if not (valid_tyvar_name name) then raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name))); ignore (TyVarMap.find name !type_variables); raise Already_bound @@ -341,7 +344,7 @@ and transl_type_aux env policy styp = ctyp Ttyp_any ty | Ptyp_var name -> let ty = - if name <> "" && name.[0] = '_' then + if not (valid_tyvar_name name) then raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name))); begin try instance (List.assoc name !univars) diff --git a/typing/typetexp.mli b/typing/typetexp.mli index b6cea61b..d726019b 100644 --- a/typing/typetexp.mli +++ b/typing/typetexp.mli @@ -17,6 +17,8 @@ open Types +val valid_tyvar_name : string -> bool + val transl_simple_type: Env.t -> bool -> Parsetree.core_type -> Typedtree.core_type val transl_simple_type_univars: diff --git a/utils/HACKING.adoc b/utils/HACKING.adoc index af2fd01f..182847b5 100644 --- a/utils/HACKING.adoc +++ b/utils/HACKING.adoc @@ -53,8 +53,3 @@ and (There are two commits as one kind of magic number was forgotten, ideally there should be only one commit.) - -=== How to update magic numbers - -In order to update magic numbers, you must follow the boostrap procedure -described in BOOTSTRAP.adoc diff --git a/utils/Makefile b/utils/Makefile index b446d8da..687529b3 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -47,7 +47,6 @@ config.ml: config.mlp $(ROOTDIR)/Makefile.config Makefile $(call SUBST,BYTECCLIBS) \ $(call SUBST,CC) \ $(call SUBST,CCOMPTYPE) \ - $(call SUBST,CC_PROFILE) \ $(call SUBST,OUTPUTOBJ) \ $(call SUBST,EXT_ASM) \ $(call SUBST,EXT_DLL) \ @@ -73,7 +72,6 @@ config.ml: config.mlp $(ROOTDIR)/Makefile.config Makefile $(call SUBST,OCAMLOPT_CFLAGS) \ $(call SUBST,OCAMLOPT_CPPFLAGS) \ $(call SUBST,PACKLD) \ - $(call SUBST,PROFILING) \ $(call SUBST,PROFINFO_WIDTH) \ $(call SUBST,RANLIBCMD) \ $(call SUBST,FORCE_SAFE_STRING) \ diff --git a/utils/ccomp.ml b/utils/ccomp.ml index d5cee649..649faf38 100644 --- a/utils/ccomp.ml +++ b/utils/ccomp.ml @@ -195,7 +195,7 @@ let call_linker mode output_name files extra = (quote_files (remove_Wl files)) extra else - Printf.sprintf "%s -o %s %s %s %s %s %s %s" + Printf.sprintf "%s -o %s %s %s %s %s %s" (match !Clflags.c_compiler, mode with | Some cc, _ -> cc | None, Exe -> Config.mkexe @@ -204,7 +204,6 @@ let call_linker mode output_name files extra = | None, Partial -> assert false ) (Filename.quote output_name) - (if !Clflags.gprofile then Config.cc_profile else "") "" (*(Clflags.std_include_flag "-I")*) (quote_prefixed "-L" (Load_path.get_paths ())) (String.concat " " (List.rev !Clflags.all_ccopts)) diff --git a/utils/clflags.ml b/utils/clflags.ml index c0a70280..5d85b6ca 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -68,7 +68,6 @@ let absname = ref false (* -absname *) let annotations = ref false (* -annot *) let binary_annotations = ref false (* -annot *) and use_threads = ref false (* -thread *) -and use_vmthreads = ref false (* -vmthread *) and noassert = ref false (* -noassert *) and verbose = ref false (* -verbose *) and noversion = ref false (* -no-version *) @@ -79,6 +78,7 @@ and noinit = ref false (* -noinit *) and open_modules = ref [] (* -open *) and use_prims = ref "" (* -use-prims ... *) and use_runtime = ref "" (* -use-runtime ... *) +and plugin = ref false (* -plugin ... *) and principal = ref false (* -principal *) and real_paths = ref true (* -short-paths *) and recursive_types = ref false (* -rectypes *) @@ -86,7 +86,6 @@ and strict_sequence = ref false (* -strict-sequence *) and strict_formats = ref false (* -strict-formats *) and applicative_functors = ref true (* -no-app-funct *) and make_runtime = ref false (* -make-runtime *) -and gprofile = ref false (* -p *) and c_compiler = ref (None: string option) (* -cc *) and no_auto_link = ref false (* -noautolink *) and dllpaths = ref ([] : string list) (* -dllpath *) @@ -144,6 +143,9 @@ let flambda_invariant_checks = let dont_write_files = ref false (* set to true under ocamldoc *) +let insn_sched_default = true +let insn_sched = ref insn_sched_default (* -[no-]insn-sched *) + let std_include_flag prefix = if !no_std_include then "" else (prefix ^ (Filename.quote Config.standard_library)) @@ -161,6 +163,7 @@ let pic_code = ref (match Config.architecture with (* -fPIC *) | _ -> false) let runtime_variant = ref "";; (* -runtime-variant *) +let with_runtime = ref true;; (* -with-runtime *) let keep_docs = ref false (* -keep-docs *) let keep_locs = ref true (* -keep-locs *) @@ -370,6 +373,7 @@ let dump_into_file = ref false (* -dump-into-file *) type 'a env_reader = { parse : string -> 'a option; + print : 'a -> string; usage : string; env_var : string; } @@ -382,6 +386,10 @@ let color_reader = { | "always" -> Some Misc.Color.Always | "never" -> Some Misc.Color.Never | _ -> None); + print = (function + | Misc.Color.Auto -> "auto" + | Misc.Color.Always -> "always" + | Misc.Color.Never -> "never"); usage = "expected \"auto\", \"always\" or \"never\""; env_var = "OCAML_COLOR"; } @@ -393,6 +401,9 @@ let error_style_reader = { | "contextual" -> Some Misc.Error_style.Contextual | "short" -> Some Misc.Error_style.Short | _ -> None); + print = (function + | Misc.Error_style.Contextual -> "contextual" + | Misc.Error_style.Short -> "short"); usage = "expected \"contextual\" or \"short\""; env_var = "OCAML_ERROR_STYLE"; } @@ -449,7 +460,7 @@ let add_arguments loc args = try let loc2 = String.Map.find arg_name !arg_names in Printf.eprintf - "Warning: plugin argument %s is already defined:\n" arg_name; + "Warning: compiler argument %s is already defined:\n" arg_name; Printf.eprintf " First definition: %s\n" loc2; Printf.eprintf " New definition: %s\n" loc; with Not_found -> diff --git a/utils/clflags.mli b/utils/clflags.mli index 9355f2ee..1aaff70c 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -96,7 +96,6 @@ val absname : bool ref val annotations : bool ref val binary_annotations : bool ref val use_threads : bool ref -val use_vmthreads : bool ref val noassert : bool ref val verbose : bool ref val noprompt : bool ref @@ -106,6 +105,7 @@ val noinit : bool ref val noversion : bool ref val use_prims : string ref val use_runtime : string ref +val plugin : bool ref val principal : bool ref val real_paths : bool ref val recursive_types : bool ref @@ -113,7 +113,6 @@ val strict_sequence : bool ref val strict_formats : bool ref val applicative_functors : bool ref val make_runtime : bool ref -val gprofile : bool ref val c_compiler : string option ref val no_auto_link : bool ref val dllpaths : string list ref @@ -186,6 +185,7 @@ val shared : bool ref val dlcode : bool ref val pic_code : bool ref val runtime_variant : string ref +val with_runtime : bool ref val force_slash : bool ref val keep_docs : bool ref val keep_locs : bool ref @@ -216,6 +216,7 @@ val dump_into_file : bool ref (* Support for flags that can also be set from an environment variable *) type 'a env_reader = { parse : string -> 'a option; + print : 'a -> string; usage : string; env_var : string; } @@ -228,6 +229,9 @@ val error_style_reader : Misc.Error_style.setting env_reader val unboxed_types : bool ref +val insn_sched : bool ref +val insn_sched_default : bool + module Compiler_pass : sig type t = Parsing | Typing val of_string : string -> t option @@ -248,8 +252,7 @@ val arg_spec : (string * Arg.spec * string) list ref val add_arguments : string -> (string * Arg.spec * string) list -> unit (* [parse_arguments anon_arg usage] will parse the arguments, using - the arguments provided in [Clflags.arg_spec]. It allows plugins to - provide their own arguments. + the arguments provided in [Clflags.arg_spec]. *) val parse_arguments : Arg.anon_fun -> string -> unit diff --git a/utils/config.mli b/utils/config.mli index cb830782..b089f61d 100644 --- a/utils/config.mli +++ b/utils/config.mli @@ -81,9 +81,6 @@ val ranlib: string val ar: string (** Name of the ar command, or "" if not needed (MSVC) *) -val cc_profile : string -(** The command line option to the C compiler to enable profiling. *) - val interface_suffix: string ref (** Suffix for interface file names *) @@ -185,9 +182,6 @@ val host : string val target : string (** Whether the compiler is a cross-compiler *) -val profiling : bool -(** Whether profiling with gprof is supported on this platform *) - val flambda : bool (** Whether the compiler was configured for flambda *) diff --git a/utils/config.mlp b/utils/config.mlp index 025497a7..a5619bde 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -52,7 +52,6 @@ let native_c_libraries = "%%NATIVECCLIBS%%" let native_pack_linker = "%%PACKLD%%" let ranlib = "%%RANLIBCMD%%" let ar = "%%ARCMD%%" -let cc_profile = "%%CC_PROFILE%%" let mkdll, mkexe, mkmaindll = (* @@DRA Cygwin - but only if shared libraries are enabled, which we should be able to detect? *) @@ -72,7 +71,6 @@ let mkdll, mkexe, mkmaindll = else "%%MKDLL%%", "%%MKEXE%%", "%%MKMAINDLL%%" -let profiling = %%PROFILING%% let flambda = %%FLAMBDA%% let with_flambda_invariants = %%WITH_FLAMBDA_INVARIANTS%% let safe_string = %%FORCE_SAFE_STRING%% @@ -84,26 +82,25 @@ let flat_float_array = %%FLAT_FLOAT_ARRAY%% let afl_instrument = %%AFL_INSTRUMENT%% -let exec_magic_number = "Caml1999X025" +let exec_magic_number = "Caml1999X026" (* exec_magic_number is duplicated in runtime/caml/exec.h *) -and cmi_magic_number = "Caml1999I025" -and cmo_magic_number = "Caml1999O025" -and cma_magic_number = "Caml1999A025" +and cmi_magic_number = "Caml1999I026" +and cmo_magic_number = "Caml1999O026" +and cma_magic_number = "Caml1999A026" and cmx_magic_number = if flambda then - "Caml1999y025" + "Caml1999y026" else - "Caml1999Y025" + "Caml1999Y026" and cmxa_magic_number = if flambda then - "Caml1999z025" + "Caml1999z026" else - "Caml1999Z025" -and ast_impl_magic_number = "Caml1999M025" -and ast_intf_magic_number = "Caml1999N025" -and cmxs_magic_number = "Caml1999D025" - (* cmxs_magic_number is duplicated in otherlibs/dynlink/natdynlink.ml *) -and cmt_magic_number = "Caml1999T025" + "Caml1999Z026" +and ast_impl_magic_number = "Caml1999M026" +and ast_intf_magic_number = "Caml1999N026" +and cmxs_magic_number = "Caml1999D026" +and cmt_magic_number = "Caml1999T026" let interface_suffix = ref ".mli" @@ -175,7 +172,6 @@ let configuration_variables = p "native_c_libraries" native_c_libraries; p "native_pack_linker" native_pack_linker; p "ranlib" ranlib; - p "cc_profile" cc_profile; p "architecture" architecture; p "model" model; p_int "int_size" Sys.int_size; @@ -194,7 +190,6 @@ let configuration_variables = p_bool "systhread_supported" systhread_supported; p "host" host; p "target" target; - p_bool "profiling" profiling; p_bool "flambda" flambda; p_bool "spacetime" spacetime; p_bool "safe_string" safe_string; diff --git a/utils/consistbl.ml b/utils/consistbl.ml index dbba5d1f..24fde86f 100644 --- a/utils/consistbl.ml +++ b/utils/consistbl.ml @@ -15,52 +15,75 @@ (* Consistency tables: for checking consistency of module CRCs *) -type t = (string, Digest.t * string) Hashtbl.t +open Misc -let create () = Hashtbl.create 13 +module Make (Module_name : sig + type t + module Set : Set.S with type elt = t + module Map : Map.S with type key = t + module Tbl : Hashtbl.S with type key = t + val compare : t -> t -> int +end) = struct + type t = (Digest.t * filepath) Module_name.Tbl.t -let clear = Hashtbl.clear + let create () = Module_name.Tbl.create 13 -exception Inconsistency of string * string * string + let clear = Module_name.Tbl.clear -exception Not_available of string + exception Inconsistency of Module_name.t * filepath * filepath -let check tbl name crc source = - try - let (old_crc, old_source) = Hashtbl.find tbl name in - if crc <> old_crc then raise(Inconsistency(name, source, old_source)) - with Not_found -> - Hashtbl.add tbl name (crc, source) + exception Not_available of Module_name.t -let check_noadd tbl name crc source = - try - let (old_crc, old_source) = Hashtbl.find tbl name in - if crc <> old_crc then raise(Inconsistency(name, source, old_source)) - with Not_found -> - raise (Not_available name) + let check tbl name crc source = + try + let (old_crc, old_source) = Module_name.Tbl.find tbl name in + if crc <> old_crc then raise(Inconsistency(name, source, old_source)) + with Not_found -> + Module_name.Tbl.add tbl name (crc, source) -let set tbl name crc source = Hashtbl.add tbl name (crc, source) + let check_noadd tbl name crc source = + try + let (old_crc, old_source) = Module_name.Tbl.find tbl name in + if crc <> old_crc then raise(Inconsistency(name, source, old_source)) + with Not_found -> + raise (Not_available name) -let source tbl name = snd (Hashtbl.find tbl name) + let set tbl name crc source = Module_name.Tbl.add tbl name (crc, source) -let extract l tbl = - let l = List.sort_uniq String.compare l in - List.fold_left - (fun assc name -> - try - let (crc, _) = Hashtbl.find tbl name in - (name, Some crc) :: assc - with Not_found -> - (name, None) :: assc) - [] l + let source tbl name = snd (Module_name.Tbl.find tbl name) -let filter p tbl = - let to_remove = ref [] in - Hashtbl.iter - (fun name _ -> - if not (p name) then to_remove := name :: !to_remove) - tbl; - List.iter - (fun name -> - while Hashtbl.mem tbl name do Hashtbl.remove tbl name done) - !to_remove + let extract l tbl = + let l = List.sort_uniq Module_name.compare l in + List.fold_left + (fun assc name -> + try + let (crc, _) = Module_name.Tbl.find tbl name in + (name, Some crc) :: assc + with Not_found -> + (name, None) :: assc) + [] l + + let extract_map mod_names tbl = + Module_name.Set.fold + (fun name result -> + try + let (crc, _) = Module_name.Tbl.find tbl name in + Module_name.Map.add name (Some crc) result + with Not_found -> + Module_name.Map.add name None result) + mod_names + Module_name.Map.empty + + let filter p tbl = + let to_remove = ref [] in + Module_name.Tbl.iter + (fun name _ -> + if not (p name) then to_remove := name :: !to_remove) + tbl; + List.iter + (fun name -> + while Module_name.Tbl.mem tbl name do + Module_name.Tbl.remove tbl name + done) + !to_remove +end diff --git a/utils/consistbl.mli b/utils/consistbl.mli index af3e7e58..5c8c5428 100644 --- a/utils/consistbl.mli +++ b/utils/consistbl.mli @@ -20,48 +20,62 @@ *) -type t - -val create: unit -> t - -val clear: t -> unit - -val check: t -> string -> Digest.t -> string -> unit - (* [check tbl name crc source] - checks consistency of ([name], [crc]) with infos previously - stored in [tbl]. If no CRC was previously associated with - [name], record ([name], [crc]) in [tbl]. - [source] is the name of the file from which the information - comes from. This is used for error reporting. *) - -val check_noadd: t -> string -> Digest.t -> string -> unit - (* Same as [check], but raise [Not_available] if no CRC was previously - associated with [name]. *) - -val set: t -> string -> Digest.t -> string -> unit - (* [set tbl name crc source] forcefully associates [name] with - [crc] in [tbl], even if [name] already had a different CRC - associated with [name] in [tbl]. *) - -val source: t -> string -> string - (* [source tbl name] returns the file name associated with [name] - if the latter has an associated CRC in [tbl]. - Raise [Not_found] otherwise. *) - -val extract: string list -> t -> (string * Digest.t option) list - (* [extract tbl names] returns an associative list mapping each string - in [names] to the CRC associated with it in [tbl]. If no CRC is - associated with a name then it is mapped to [None]. *) - -val filter: (string -> bool) -> t -> unit - (* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs - such that [pred name] is [false]. *) - -exception Inconsistency of string * string * string - (* Raised by [check] when a CRC mismatch is detected. - First string is the name of the compilation unit. - Second string is the source that caused the inconsistency. - Third string is the source that set the CRC. *) - -exception Not_available of string - (* Raised by [check_noadd] when a name doesn't have an associated CRC. *) +open Misc + +module Make (Module_name : sig + type t + module Set : Set.S with type elt = t + module Map : Map.S with type key = t + module Tbl : Hashtbl.S with type key = t + val compare : t -> t -> int +end) : sig + type t + + val create: unit -> t + + val clear: t -> unit + + val check: t -> Module_name.t -> Digest.t -> filepath -> unit + (* [check tbl name crc source] + checks consistency of ([name], [crc]) with infos previously + stored in [tbl]. If no CRC was previously associated with + [name], record ([name], [crc]) in [tbl]. + [source] is the name of the file from which the information + comes from. This is used for error reporting. *) + + val check_noadd: t -> Module_name.t -> Digest.t -> filepath -> unit + (* Same as [check], but raise [Not_available] if no CRC was previously + associated with [name]. *) + + val set: t -> Module_name.t -> Digest.t -> filepath -> unit + (* [set tbl name crc source] forcefully associates [name] with + [crc] in [tbl], even if [name] already had a different CRC + associated with [name] in [tbl]. *) + + val source: t -> Module_name.t -> filepath + (* [source tbl name] returns the file name associated with [name] + if the latter has an associated CRC in [tbl]. + Raise [Not_found] otherwise. *) + + val extract: Module_name.t list -> t -> (Module_name.t * Digest.t option) list + (* [extract tbl names] returns an associative list mapping each string + in [names] to the CRC associated with it in [tbl]. If no CRC is + associated with a name then it is mapped to [None]. *) + + val extract_map : Module_name.Set.t -> t -> Digest.t option Module_name.Map.t + (* Like [extract] but with a more sophisticated type. *) + + val filter: (Module_name.t -> bool) -> t -> unit + (* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs + such that [pred name] is [false]. *) + + exception Inconsistency of Module_name.t * filepath * filepath + (* Raised by [check] when a CRC mismatch is detected. + First string is the name of the compilation unit. + Second string is the source that caused the inconsistency. + Third string is the source that set the CRC. *) + + exception Not_available of Module_name.t + (* Raised by [check_noadd] when a name doesn't have an associated + CRC. *) +end diff --git a/utils/int_replace_polymorphic_compare.ml b/utils/int_replace_polymorphic_compare.ml new file mode 100644 index 00000000..7cd6bf10 --- /dev/null +++ b/utils/int_replace_polymorphic_compare.ml @@ -0,0 +1,8 @@ +let ( = ) : int -> int -> bool = Stdlib.( = ) +let ( <> ) : int -> int -> bool = Stdlib.( <> ) +let ( < ) : int -> int -> bool = Stdlib.( < ) +let ( > ) : int -> int -> bool = Stdlib.( > ) +let ( <= ) : int -> int -> bool = Stdlib.( <= ) +let ( >= ) : int -> int -> bool = Stdlib.( >= ) + +let compare : int -> int -> int = Stdlib.compare diff --git a/utils/int_replace_polymorphic_compare.mli b/utils/int_replace_polymorphic_compare.mli new file mode 100644 index 00000000..689e741b --- /dev/null +++ b/utils/int_replace_polymorphic_compare.mli @@ -0,0 +1,8 @@ +val ( = ) : int -> int -> bool +val ( <> ) : int -> int -> bool +val ( < ) : int -> int -> bool +val ( > ) : int -> int -> bool +val ( <= ) : int -> int -> bool +val ( >= ) : int -> int -> bool + +val compare : int -> int -> int diff --git a/utils/misc.ml b/utils/misc.ml index f9115fe6..2b073ce5 100644 --- a/utils/misc.ml +++ b/utils/misc.ml @@ -150,42 +150,48 @@ module Stdlib = struct | t::q -> aux (n-1) (t::acc) q in aux n [] l + + let rec is_prefix ~equal t ~of_ = + match t, of_ with + | [], [] -> true + | _::_, [] -> false + | [], _::_ -> true + | x1::t, x2::of_ -> equal x1 x2 && is_prefix ~equal t ~of_ + + type 'a longest_common_prefix_result = { + longest_common_prefix : 'a list; + first_without_longest_common_prefix : 'a list; + second_without_longest_common_prefix : 'a list; + } + + let find_and_chop_longest_common_prefix ~equal ~first ~second = + let rec find_prefix ~longest_common_prefix_rev l1 l2 = + match l1, l2 with + | elt1 :: l1, elt2 :: l2 when equal elt1 elt2 -> + let longest_common_prefix_rev = elt1 :: longest_common_prefix_rev in + find_prefix ~longest_common_prefix_rev l1 l2 + | l1, l2 -> + { longest_common_prefix = List.rev longest_common_prefix_rev; + first_without_longest_common_prefix = l1; + second_without_longest_common_prefix = l2; + } + in + find_prefix ~longest_common_prefix_rev:[] first second end module Option = struct type 'a t = 'a option - let is_none = function - | None -> true - | Some _ -> false - - let is_some = function - | None -> false - | Some _ -> true - - let equal eq o1 o2 = - match o1, o2 with - | None, None -> true - | Some e1, Some e2 -> eq e1 e2 - | _, _ -> false - - let iter f = function - | Some x -> f x - | None -> () - - let map f = function - | Some x -> Some (f x) - | None -> None - - let fold f a b = - match a with - | None -> b - | Some a -> f a b - let value_default f ~default a = match a with | None -> default | Some a -> f a + + let print print_contents ppf t = + match t with + | None -> Format.pp_print_string ppf "None" + | Some contents -> + Format.fprintf ppf "@[(Some@ %a)@]" print_contents contents end module Array = struct @@ -197,6 +203,20 @@ module Stdlib = struct else if p (Array.unsafe_get a1 i) (Array.unsafe_get a2 i) then true else loop (succ i) in loop 0 + + let for_alli p a = + let n = Array.length a in + let rec loop i = + if i = n then true + else if p i (Array.unsafe_get a i) then loop (succ i) + else false in + loop 0 + + let all_somes a = + try + Some (Array.map (function None -> raise_notrace Exit | Some x -> x) a) + with + | Exit -> None end module String = struct @@ -214,13 +234,16 @@ module Stdlib = struct i = len || (f t.[i] && loop (i + 1)) in loop 0 + + let print ppf t = + Format.pp_print_string ppf t end external compare : 'a -> 'a -> int = "%compare" end -let may = Stdlib.Option.iter -let may_map = Stdlib.Option.map +let may = Option.iter +let may_map = Option.map (* File functions *) @@ -348,6 +371,12 @@ let output_to_file_via_temporary ?(mode = [Open_text]) filename fn = | exception exn -> close_out oc; remove_file temp_filename; raise exn +let protect_writing_to_file ~filename ~f = + let outchan = open_out_bin filename in + try_finally ~always:(fun () -> close_out outchan) + ~exceptionally:(fun () -> remove_file filename) + (fun () -> f outchan) + (* Integer operations *) let rec log2 n = @@ -365,7 +394,7 @@ let no_overflow_mul a b = not ((a = min_int && b < 0) || (b <> 0 && (a * b) / b <> a)) let no_overflow_lsl a k = - 0 <= k && k < Sys.word_size && min_int asr k <= a && a <= max_int asr k + 0 <= k && k < Sys.word_size - 1 && min_int asr k <= a && a <= max_int asr k module Int_literal_converter = struct (* To convert integer literals, allowing max_int + 1 (PR#4210) *) @@ -689,21 +718,26 @@ module Color = struct type setting = Auto | Always | Never + let default_setting = Auto + let setup = let first = ref true in (* initialize only once *) let formatter_l = [Format.std_formatter; Format.err_formatter; Format.str_formatter] in + let enable_color = function + | Auto -> should_enable_color () + | Always -> true + | Never -> false + in fun o -> if !first then ( first := false; Format.set_mark_tags true; List.iter set_color_tag_handling formatter_l; color_enabled := (match o with - | Some Always -> true - | Some Auto -> should_enable_color () - | Some Never -> false - | None -> should_enable_color ()) + | Some s -> enable_color s + | None -> enable_color default_setting) ); () end @@ -712,6 +746,8 @@ module Error_style = struct type setting = | Contextual | Short + + let default_setting = Contextual end let normalise_eol s = @@ -774,53 +810,6 @@ let pp_two_columns ?(sep = "|") ?max_lines ppf (lines: (string * string) list) = ) lines; Format.fprintf ppf "@]" -type hook_info = { - sourcefile : string; -} - -exception HookExnWrapper of - { - error: exn; - hook_name: string; - hook_info: hook_info; - } - -exception HookExn of exn - -let raise_direct_hook_exn e = raise (HookExn e) - -let fold_hooks list hook_info ast = - List.fold_left (fun ast (hook_name,f) -> - try - f hook_info ast - with - | HookExn e -> raise e - | error -> raise (HookExnWrapper {error; hook_name; hook_info}) - (* when explicit reraise with backtrace will be available, - it should be used here *) - - ) ast (List.sort compare list) - -module type HookSig = sig - type t - - val add_hook : string -> (hook_info -> t -> t) -> unit - val apply_hooks : hook_info -> t -> t -end - -module MakeHooks(M: sig - type t - end) : HookSig with type t = M.t -= struct - - type t = M.t - - let hooks = ref [] - let add_hook name f = hooks := (name, f) :: !hooks - let apply_hooks sourcefile intf = - fold_hooks !hooks sourcefile intf -end - (* showing configuration and configuration variables *) let show_config_and_exit () = Config.print_config stdout; @@ -880,3 +869,81 @@ let debug_prefix_map_flags () = let print_if ppf flag printer arg = if !flag then Format.fprintf ppf "%a@." printer arg; arg + + +type filepath = string +type modname = string +type crcs = (modname * Digest.t option) list + +type alerts = string Stdlib.String.Map.t + + +module EnvLazy = struct + type ('a,'b) t = ('a,'b) eval ref + + and ('a,'b) eval = + | Done of 'b + | Raise of exn + | Thunk of 'a + + type undo = + | Nil + | Cons : ('a, 'b) t * 'a * undo -> undo + + type log = undo ref + + let force f x = + match !x with + | Done x -> x + | Raise e -> raise e + | Thunk e -> + match f e with + | y -> + x := Done y; + y + | exception e -> + x := Raise e; + raise e + + let get_arg x = + match !x with Thunk a -> Some a | _ -> None + + let create x = + ref (Thunk x) + + let create_forced y = + ref (Done y) + + let create_failed e = + ref (Raise e) + + let log () = + ref Nil + + let force_logged log f x = + match !x with + | Done x -> x + | Raise e -> raise e + | Thunk e -> + match f e with + | None -> + x := Done None; + log := Cons(x, e, !log); + None + | Some _ as y -> + x := Done y; + y + | exception e -> + x := Raise e; + raise e + + let backtrack log = + let rec loop = function + | Nil -> () + | Cons(x, e, rest) -> + x := Thunk e; + loop rest + in + loop !log + +end diff --git a/utils/misc.mli b/utils/misc.mli index 7005dcfb..97d9fefa 100644 --- a/utils/misc.mli +++ b/utils/misc.mli @@ -116,20 +116,41 @@ module Stdlib : sig (** [split_at n l] returns the pair [before, after] where [before] is the [n] first elements of [l] and [after] the remaining ones. If [l] has less than [n] elements, raises Invalid_argument. *) + + val is_prefix + : equal:('a -> 'a -> bool) + -> 'a list + -> of_:'a list + -> bool + (** Returns [true] iff the given list, with respect to the given equality + function on list members, is a prefix of the list [of_]. *) + + type 'a longest_common_prefix_result = private { + longest_common_prefix : 'a list; + first_without_longest_common_prefix : 'a list; + second_without_longest_common_prefix : 'a list; + } + + val find_and_chop_longest_common_prefix + : equal:('a -> 'a -> bool) + -> first:'a list + -> second:'a list + -> 'a longest_common_prefix_result + (** Returns the longest list that, with respect to the provided equality + function, is a prefix of both of the given lists. The input lists, + each with such longest common prefix removed, are also returned. *) end module Option : sig type 'a t = 'a option - val is_none : 'a t -> bool - val is_some : 'a t -> bool - - val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - - val iter : ('a -> unit) -> 'a t -> unit - val map : ('a -> 'b) -> 'a t -> 'b t - val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b val value_default : ('a -> 'b) -> default:'b -> 'a t -> 'b + + val print + : (Format.formatter -> 'a -> unit) + -> Format.formatter + -> 'a t + -> unit end module Array : sig @@ -137,6 +158,13 @@ module Stdlib : sig (* Same as [Array.exists], but for a two-argument predicate. Raise Invalid_argument if the two arrays are determined to have different lengths. *) + + val for_alli : (int -> 'a -> bool) -> 'a array -> bool + (** Same as {!Array.for_all}, but the + function is applied with the index of the element as first argument, + and the element itself as second argument. *) + + val all_somes : 'a option array -> 'a array option end module String : sig @@ -145,6 +173,8 @@ module Stdlib : sig module Map : Map.S with type key = string module Tbl : Hashtbl.S with type key = string + val print : Format.formatter -> t -> unit + val for_all : (char -> bool) -> t -> bool end @@ -195,6 +225,14 @@ val output_to_file_via_temporary: the channel is closed and the temporary file is renamed to [filename]. *) +(** Open the given [filename] for writing (in binary mode), pass the + [out_channel] to the given function, then close the channel. If the function + raises an exception then [filename] will be removed. *) +val protect_writing_to_file + : filename:string + -> f:(out_channel -> 'a) + -> 'a + val log2: int -> int (* [log2 n] returns [s] such that [n = 1 lsl s] if [n] is a power of 2*) @@ -350,6 +388,8 @@ module Color : sig type setting = Auto | Always | Never + val default_setting : setting + val setup : setting option -> unit (* [setup opt] will enable or disable color handling on standard formatters according to the value of color setting [opt]. @@ -364,6 +404,8 @@ module Error_style : sig type setting = | Contextual | Short + + val default_setting : setting end val normalise_eol : string -> string @@ -402,41 +444,6 @@ val pp_two_columns : v} *) -(** {1 Hook machinery} - - Hooks machinery: - [add_hook name f] will register a function that will be called on the - argument of a later call to [apply_hooks]. Hooks are applied in the - lexicographical order of their names. -*) - -type hook_info = { - sourcefile : string; -} - -exception HookExnWrapper of - { - error: exn; - hook_name: string; - hook_info: hook_info; - } - (** An exception raised by a hook will be wrapped into a - [HookExnWrapper] constructor by the hook machinery. *) - - -val raise_direct_hook_exn: exn -> 'a - (** A hook can use [raise_unwrapped_hook_exn] to raise an exception that will - not be wrapped into a {!HookExnWrapper}. *) - -module type HookSig = sig - type t - val add_hook : string -> (hook_info -> t -> t) -> unit - val apply_hooks : hook_info -> t -> t -end - -module MakeHooks : functor (M : sig type t end) -> HookSig with type t = M.t - - (** configuration variables *) val show_config_and_exit : unit -> unit val show_config_variable_and_exit : string -> unit @@ -452,3 +459,31 @@ val debug_prefix_map_flags: unit -> string list val print_if : Format.formatter -> bool ref -> (Format.formatter -> 'a -> unit) -> 'a -> 'a (** [print_if ppf flag fmt x] prints [x] with [fmt] on [ppf] if [b] is true. *) + + +type filepath = string +type modname = string +type crcs = (modname * Digest.t option) list + +type alerts = string Stdlib.String.Map.t + + +module EnvLazy: sig + type ('a,'b) t + + type log + + val force : ('a -> 'b) -> ('a,'b) t -> 'b + val create : 'a -> ('a,'b) t + val get_arg : ('a,'b) t -> 'a option + val create_forced : 'b -> ('a, 'b) t + val create_failed : exn -> ('a, 'b) t + + (* [force_logged log f t] is equivalent to [force f t] but if [f] returns + [None] then [t] is recorded in [log]. [backtrack log] will then reset all + the recorded [t]s back to their original state. *) + val log : unit -> log + val force_logged : log -> ('a -> 'b option) -> ('a,'b option) t -> 'b option + val backtrack : log -> unit + +end