New upstream version 4.09.0

diff --git a/.depend b/.depend
index cea6ca97a0903628006caa8ba3738929bf68c23c..83c43d907863225bbb9024e44e5257b16ba312be 100644 (file)
--- 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 ceac151dd457d584430332419fc53ad780a06f5c..ce51bd798860908df61506f26d130b5076e6461a 100644 (file)
--- 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 1f3241263ebfe90a457744e1fb4ec934d798b03d..04ddcaa008d57046dcb31f249383dc95b709e0cc 100644 (file)
--- 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 6959fe22860d54f4053be436ce8359d8cb547892..d83748ccbab533a9d94ee8ab2acfd2bf18a0d7ef 100644 (file)
--- a/.mailmap
+++ b/.mailmap
@@ -47,6 +47,8 @@ Nicolás Ojeda Bär <n.oje.bar@gmail.com>
 #   Preferred Name <nickname>
 
 Gabriel Radanne <Drup>
+Vincent Laviron <lthls@github>
+Jeremy Yallop <yallop>
 
 
 ### Remembering naming preferences for contributors

diff --git a/.travis.yml b/.travis.yml
index 60b2d7abbbd90647be208862efbc2383ddd17b46..da9f2a3c8370cf8f1363d79b8dceea8348031097 100644 (file)
--- 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 7cfbf6b217473ef12fa278e2ebd07e9c84e49be2..b60089b257206199c91ecad98e9eef8b4403c090 100644 (file)
--- 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 670abe75f0950d3f380927503a0740f9f36c598e..d4b8a994dd73a3ff8c733155b9dc47aed749427c 100644 (file)
--- 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 (.<n>) 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 3941a6f372c04a96b41b859ebf3d962dfc184a95..2958e85146df6d73f538ea13c149922e329562da 100644 (file)
--- 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 c281eeb8dfb3161fc590f5eaaaa7139f0be9bd19..2643c6f2da68feb80b1137fb0240a35df98ddb62 100644 (file)
--- 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 83598d6c4991df09aad89cc05436ed24edfcaa52..47548c79d7f79daf6357ef977e55ffb4bab77f01 100644 (file)
--- 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 585aab9de7ded0111e3ba02f5ae9df5f647f591d..acd48010ae463c2cba20e8e6856fc87083b37106 100644 (file)
--- 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 391e469ae1f12f331ab825d1f5e0c8be4b8e0d8a..3e0bedf7ee7166ec8e9f1187a3cfa2d3944731ef 100644 (file)
--- 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 53cd4512ee19b19b8603f12fd265cdcf4d80d892..504c7a7087bfd9e5afbfca98989649752ae959d2 100644 (file)
--- 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 8ad56c88f2abd060030d5a0d71ff73ea78ba4bcd..c8ab81c43621a545e22b4f4a4df7aed8558a7f66 100644 (file)
--- 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 <<tb2,(**)>>       | yes <<tb2,(**)>> | 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 <<tb1,(*)>>
 |=====
 
@@ -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 2c3d7f9496cc80044b8218b5c2ad823cf4fa4d21..7128cac1fa331c62c02d33302cb17c373b6d2f73 100644 (file)
--- 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 543fff725d31812a1af69cf3725a12ae46aa6281..ff12869a29f2bc3c3b53707d4809dd892e0cb674 100644 (file)
--- 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 09ecca70a6049346f6b63179dc5b40fec71d4fe8..d71198addaf044a2465d79d0c58b9c6e1c91c535 100644 (file)
--- 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 8397c30db0316869950651ffbf2115c0eaafbd2c..9e0084117f2c2b67fbcdbc473d532f663c038497 100644 (file)
--- 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 1eb439b27a1964d04022122c9bcae6e36aa27a56..c98cbcd1aef9e6215aea341b3779c9cdba3e8e06 100644 (file)
--- 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 4acbd694afabec2f7e851faed165818014e1cf82..e5b42b83871b5b0179ba03a99984c3c2a1000416 100644 (file)
--- 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 db94a476f603f57b50bd0943488243391e92b8d8..4c3c636b59ffccec719974f5babab12ba0196637 100644 (file)
--- 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 db7ee0a6c0e8c916a2f274d8b09997c99334ec22..3fd47b7b83de35ffbdf5b87b8aa3e9e44a3a3649 100644 (file)
--- 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 a523fbb9f6b669989628e0a503648f744df0c8db..00d01748fae9a531d9241732627e361a69c6849c 100644 (file)
--- 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 1622fa49ce3b3c4f4339131704a341b3e264e057..8ad7bebcc4fe94d34c2bafa1675d8afbb9081e29 100644 (file)
--- 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 747e86a2a7a163e292c186347497b9647bcb7c0c..f43c13d9bd7701a731f05391a12a862ee2992d82 100644 (file)
--- 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 5879266358a59cebfc78a56b2f1e17f992af56a5..a00cbced898f26f73d579618ab0aea1e40ed9c66 100644 (file)
--- 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 14ba08d59bca845a0a189402451f60a499c6ec42..095f22f269dead6bc45ad96ff37ef01f229fd2cf 100644 (file)
--- 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 b714d0032cf59b552fefd2df0db175959c44e923..90166141dd6c86371f3532f8d450559ae038bf5b 100644 (file)
--- 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 ddbbae8d7099dc11c32d33a5f6c29dc459c80632..46f7b2704632f13ff47518144d61caab8b700288 100644 (file)
--- 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 f2f4ccaef3994438697e7b9b1b2e0b87471867f9..160456215ac4fd8d25869d0077917eec239700ff 100644 (file)
--- 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 f77b6cc3219ebb31eccef8cde6bcfb76a2680c5c..8c4457c80b11d27651e420d522d1f446b0c339ce 100644 (file)
--- 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 80d66099040c7823448c08f7d3e6eeda7c2f8bcc..1c8322765b86f7ef64d8c54a8bf58adfc9d741ec 100644 (file)
--- 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 f079e0e6a803677c00834554cc8cbd8a67f0afd6..df9686aa97d4fc1a7ef5b54e8e5719d1ee0164f5 100644 (file)
--- 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 (file)
index 39af7f6..0000000
--- 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 "@[<hov 1>(\
-        @[<hov 1>(module_path@ %a)@]@ \
-        @[<hov 1>(location@ %a)@]@ \
-        @[<hov 1>(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 (file)
index f236be1..0000000
--- 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 (file)
index 88082cf..0000000
--- 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 (file)
index 0380604..0000000
--- 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 (file)
index 0e858f1..0000000
--- 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 (file)
index 98f3184..0000000
--- 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 (file)
index 35239fa..0000000
--- 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 (file)
index f930e0f..0000000
--- 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 (file)
index 51a09f0..0000000
--- 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 (file)
index 7ecf9c2..0000000
--- 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 3c0b2d7877fa9a7009dcd3059ea23f8d5d957a9a..b2d58d0b81f6ac38273df13894341c9abffb49bb 100644 (file)
--- 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 219083a17f32976709419f183d6d93b237e02e66..a46e6599da29ece224482cafc84306d3369af435 100644 (file)
--- 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 68e36d0d9e0bf4f2e1f19ec55e44ed1db91e0609..598debb607d86557fb90a759142806b66081afb0 100644 (file)
--- 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 6c33da9548c9bfd98b20619b53bfb82a5e58e7c2..b7388a3f5f83f43e0ae05bf2a80a5a84abbbd665 100644 (file)
--- 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 (file)
index 0000000..b40375a
--- /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 (file)
index 0000000..aa9de81
--- /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 (file)
index 0e3cf28..0000000
--- 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 b10edd2af9d1fde6d110ef3719656c9b6f4af62c..29ee15b36c87379ceaa13960989301af6c8f7c34 100644 (file)
--- 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 (file)
index add4e90..0000000
--- 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 (file)
index 569d51e..0000000
--- 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 c713b64b49fca6d3d3b5cdd47cb66466e4c8701d..d803a0082da50a1d84c0a849dc9662088c8b24b3 100644 (file)
--- 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 9886f7729092aef4bb858b2f08bd2ba320025daa..6ca2544bd7fb82825ef5737a1d3ebb9113d647dc 100644 (file)
--- 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 (file)
index 0000000..734eca5
--- /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 (file)
index 0000000..695529f
--- /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 (file)
index 0000000..69d8206
--- /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 (file)
index 22dbb6c..0000000
--- 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 "<None>"
-    | 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 "@[<hov 2>(%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 "@[<hov 2>%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 "@[<hov 2>Globals:@ ";
-  fprintf ppf "@]@ @[<hov 2>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 "@[<v 2>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 "@]@ @[<v 2>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 (file)
index f93698b..0000000
--- 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 (file)
index 42a8155..0000000
--- 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 (file)
index 2ba3a35..0000000
--- 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 (file)
index e1b0f44..0000000
--- 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 -> "<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 (file)
index 8c493d4..0000000
--- 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 6f1e183978f760909894612fb6c20ac828f3cdad..69567cbd779c2ce335adb683c478f66370f0e729 100644 (file)
--- 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 23f54232a44eb4821a20da2dcfaf9e39c77ba640..ba76a82584da766cf631c31fb11e51054f670cdd 100644 (file)
--- 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 654b5629a0b82cf7382e87362129a595b4d32511..9f55cd293a8d7fd1cf906efdbfc5faf3d0127ae9 100644 (file)
--- 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 29290d0d90937e8db3ba1d2b18d9334db1ca14a7..0b333af499385a66944926de48d8d02b85109fb5 100644 (file)
--- 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 efde628d6b08893de5214bc49dda376f4de70b61..9e4e949aa2ef99e71d1d5099876b70f4e40c82fd 100644 (file)
--- 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 (file)
index 64fbbb8..0000000
--- 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 (file)
index 23d9d29..0000000
--- 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 7d569c5b9304515654702b7ab1e46a8f6d01e61f..a1cdb9217af0e742dd9bed9a492431ebd979a64a 100644 (file)
--- 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 01f49a30ae62fc1ff1a35d2793af923c8ffdf17f..956ac4f78bdaabeab8fc1d593584cf6848519e66 100644 (file)
--- 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 a5a39aa56f14c09c5d0c4f2d1ed2199ae814847c..38d3d6ac8b8105d0746c81f779a4ef3913708240 100644 (file)
--- 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 e30996fe4161fbe3616ab930b302c91ba1b983e9..d1662295689304ae256ef1bfd2bed1cb0022804c 100644 (file)
--- 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 28c5868c38dc06c7e44024904cedd50746f8b653..2da5b160b2224ef604b12989ec0b4094b9d25d64 100644 (file)
--- 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 17a5ba7e832d5adb1eb2b30d166ce6e5b15d77a8..bfed9f7e64894aab8a7b7db6712765bcf09ce1e7 100644 (file)
--- 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 f32d8604a208319d189b125e065757c96b82cda9..6ad4cda474ae01a373205af5a5e5d7f04b43b650 100644 (file)
--- 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 b489fa995f8f6a3fba06c342524dc88dcfec2c81..558d1a1e856810bedb9d4730d852ded680effb09 100644 (file)
--- 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 8560d0f988a50aa902704d39764276bb89985e7b..86b4476c19ba0d20a2a8cc6a3cd36af2eb58b21c 100644 (file)
--- 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 e62b0b890ae8688081ed01bebe5b67747b21c35c..6e97feba9f79d15bdf8d70177f5996ac4e2c4e5c 100644 (file)
--- 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 (file)
index 954fecf..0000000
--- 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@ @[<hv 1>(@[<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@ @[<hv 1>(@[<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@ (@[<hv 1>%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
-       "@[<v 0>@[<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 "@[<hv 1>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 "@[<hv 1>default:@ %a@]" lam d
-        | None -> ()
-        end in
-      fprintf ppf
-        "@[<1>(switch %a@ @[<v 0>%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 "@[<hov 1>(%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 (file)
index 121667e..0000000
--- 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 c485eec19677a30521d8000f4dd5cfa29b0953c8..7be55c2f2772576b2cf95e686069552c559d4eb9 100644 (file)
--- 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 "@[<v 0>@[<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 69557687a2ccc0b1c14cdf16f7b23c688332888e..4e62fc6f61adae369a3fe10d0b2c601a6c207b50 100644 (file)
--- 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 6ef11ce3461db60785b3f3b7a16cd566122cbf97..d90e302d53421f3506fa8cab13178806044a2df6 100644 (file)
--- 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 "@[<v 2>loop@,%a@;<0 -2>endloop@]" instr body
   | Icatch(flag, handlers, body) ->
       fprintf ppf "@[<v 2>catch%a@,%a@;<0 -2>with"
         Printcmm.rec_flag flag instr body;

diff --git a/asmcomp/proc.mli b/asmcomp/proc.mli
index 2074d619b36e3e0f8f71e7ffa0da62e6a22c392d..4e0e03640ed6e5986902e85d3267deb6a1ee2902 100644 (file)
--- 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 d2bf9150a1ac6b70935ac577c8f264d4be9e4e73..b1f260c1aeb64b6430828ec3911a18f4c08d8360 100644 (file)
--- 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 f422ad29a9058503b11d5903ebc83116efe30f29..619b454fe077bf77effcba808c2d28b6f04abbec 100644 (file)
--- 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 9b359b1905459cfa78a63c1a102619cf644e5bdf..db2b0c044d6e44a1bba369b8883262111b0be914 100644 (file)
--- 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 44ab1f9d13e63279b0381e9a636f6f6b16a57ec8..760719b5179b1896cf67d52c28bc43363bfec9cd 100644 (file)
--- 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 c640f7f7c8e8915e4b1894f1fa201d931aa3b844..414842283d11dd94353ed39f51753d5f5f77f6ef 100644 (file)
--- 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 302115c77cee486c1d1a2f751c4c6b27d6a3549b..ea59ad2291e1db491c281e21f9473c996610563a 100644 (file)
--- 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 003d706734791331ef2170af3c9a8787e6625dd8..87c35be7e9a6daf974d4672a5b2907545d20caf4 100644 (file)
--- 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 acabf7c04c50b58bccaaa751477ae2346f14f4bd..a61cd1c4359aab8626fd2a3e3026272ace30fda8 100644 (file)
--- 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 7e3a31885dda4e7611c1d6ce7d53f3538ea56278..0aeee83c2b2377b81a04184f889232813e839d3d 100644 (file)
--- 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 650c404e098d22bc8bd11313c2662c5afe97da50..cfe4b0d623fb00f04bc49041446b2d7631847596 100644 (file)
--- 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 b1efbf8f278170a2a4b19207024fc4e5f689c15a..07d77ebf43f39b4f8d1758a197b7f6c0fe71066d 100644 (file)
--- 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 (file)
index 1b7ce57..0000000
--- 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 (file)
index 2825a38..0000000
--- 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 (file)
index 450a9dd..0000000
--- 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 (file)
index 92ea06c..0000000
--- 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 31e16a4f85914ad525dd1bb58a240d1301216a1b..99ddd398425d75f07de739125e8d0869469e65fd 100644 (file)
--- 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 e8aed9c115578a70cc7e3ae80fb9e61e6a544415..c7f20bc99ee2b90bb681390b9850dbd0bf425503 100644 (file)
--- 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 a4e15f94d73840c22f81066ac334a2ceedfdd17b..40f47afa9e66b80205dcb457b0854b8db01c6363 100755 (executable)
--- 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 4938ace50addf8fb828e59a6ebedf9a4b6554cc3..9cc6a5bb55a75639363991cc556557204e3957d8 100755 (executable)
Binary files a/boot/ocamlc and b/boot/ocamlc differ

diff --git a/boot/ocamllex b/boot/ocamllex
index 893f709e4b52cf1fe6fca0a27d69e8137e0f487f..261bb7d13fc75adf63f407490ceb2336d80364c8 100755 (executable)
Binary files a/boot/ocamllex and b/boot/ocamllex differ

diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index c7343bfc1d17fec765570431059c22774971bdec..2bbb19a51b8459a1a3dbdbc2c3644ac3c033bbac 100644 (file)
--- 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 0b964e69df40e2b06d2481d1107581c07d5d23d3..3f50520c26352ca615fdcc512b201bd43bb1cfe4 100644 (file)
--- 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 e3cf98dad7b15fd5f6d0d71fb0409184a677a41d..4792e7c8a5a0cd163c984b018202f1adda16bcf2 100644 (file)
--- 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 4c19f5c28077e86e6f96fe8fe04ef92fbdf07dd4..2458030bd14563238b219ae82f65e483dd7be010 100644 (file)
--- 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 (file)
index 7fbb35a..0000000
--- 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 b2409cf4f11b0cd9c7387ee573886bfaba4b78f4..655cb57ebe68c4d1a0748477d4ef88dea2ce9f13 100644 (file)
--- 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 (executable)
index 66ccf3c..0000000
--- 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 (file)
index ebdd49a..0000000
--- 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 (file)
index f79ee0c..0000000
--- 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 (file)
index 0b31ecb..0000000
--- 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 -> "<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 (file)
index f29901b..0000000
--- 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 (file)
index e4bb26a..0000000
--- 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@ @[<hv 1>(@[<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@ (@[<hv 1>%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 "@[<hv 1>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 "@[<hv 1>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 "@[<hv 1>default:@ %a@]" lam l
-        end in
-      fprintf ppf
-       "@[<1>(%s %a@ @[<v 0>%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 "@[<hv 1>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 "@[<hv 1>default:@ %a@]" lam default
-        | None -> ()
-        end in
-      fprintf ppf
-       "@[<1>(stringswitch %a@ @[<v 0>%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 "<ghost>" 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 (file)
index 137190e..0000000
--- 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 (file)
index 3baabb6..0000000
--- 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 (file)
index b6b09e1..0000000
--- 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 (file)
index c0c2b9a..0000000
--- 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 (file)
index 9e1eb92..0000000
--- 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 (file)
index daa2f70..0000000
--- 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 (file)
index 89bfe83..0000000
--- 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 (file)
index b4058c1..0000000
--- 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 (file)
index 1520a3b..0000000
--- 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 (file)
index bf22fd1..0000000
--- 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 (file)
index 10b0906..0000000
--- 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 (file)
index 4c4bed0..0000000
--- 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 (file)
index e9098a2..0000000
--- 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 (file)
index 7a27dbc..0000000
--- 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 (file)
index 436344f..0000000
--- 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 (file)
index d0898c7..0000000
--- 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 (file)
index ce06353..0000000
--- 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 (file)
index c27053e..0000000
--- 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 (file)
index 448a2ac..0000000
--- 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 (file)
index abf0f7d..0000000
--- 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 (file)
index c5a78f7..0000000
--- 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 (file)
index 4c50467..0000000
--- 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 (file)
index 827e61e..0000000
--- 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 (file)
index b992a52..0000000
--- 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 (file)
index c5f5f3f..0000000
--- 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 <stdio.h>
-#include <signal.h>
-#include <setjmp.h>
-
-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 (file)
index 65d8240..0000000
--- 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 (file)
index b8f5257..0000000
--- 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 <stdio.h>
-#include <fcntl.h>
-#include <signal.h>
-#include <errno.h>
-#include <sys/types.h>
-#include <sys/socket.h>
-#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 (file)
index 203f701..0000000
--- 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 (file)
index acd052d..0000000
--- 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 (file)
index 6909710..0000000
--- 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 <stdio.h>
-#include <signal.h>
-#include <setjmp.h>
-
-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 (file)
index e7f044b..0000000
--- 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 <stdio.h>
-
-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 (file)
index bd2bbe0..0000000
--- 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 <string.h>
-#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 (file)
index a538ed0..0000000
--- 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 <sys/types.h>
-#include <limits.h>
-
-#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 (file)
index a932d11..0000000
--- 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 <sys/types.h>
-#include <netdb.h>
-
-#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 (file)
index aefd85f..0000000
--- 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 <sys/types.h>
-#include <netdb.h>
-
-#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 (executable)
index 54281a4..0000000
--- 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 (file)
index 5a3444e..0000000
--- 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 (executable)
index eb447ba..0000000
--- 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 (executable)
index 3753096..0000000
--- 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 (executable)
index 90002cb..0000000
--- 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 (file)
index d0391ea..0000000
--- 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 (file)
index af96803..0000000
--- a/config/auto-aux/initgroups.c
+++ /dev/null
@@ -1,26 +0,0 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                 OCaml                                  */
-/*                                                                        */
-/*   Contributed by Stephane Glondu <steph@glondu.net>                    */
-/*                                                                        */
-/*   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 <errno.h>
-
-#include <sys/types.h>
-#include <limits.h>
-#include <grp.h>
-
-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 (file)
index adf9821..0000000
--- 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 <stdio.h>
-#include <signal.h>
-#include <setjmp.h>
-#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 (file)
index 9bd43ba..0000000
--- 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 <sys/mman.h>
-#include <stdio.h>
-#include <stdlib.h>
-
-#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 (file)
index 8a15a30..0000000
--- 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 <sys/types.h>
-#include <sys/stat.h>
-#include <unistd.h>
-
-#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 (executable)
index c889a0d..0000000
--- 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 (executable)
index 0f5d9e8..0000000
--- 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 (file)
index 8a9e365..0000000
--- a/config/auto-aux/setgroups.c
+++ /dev/null
@@ -1,28 +0,0 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                 OCaml                                  */
-/*                                                                        */
-/*   Contributed by Stephane Glondu <steph@glondu.net>                    */
-/*                                                                        */
-/*   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 <errno.h>
-
-#include <sys/types.h>
-#include <limits.h>
-#include <grp.h>
-
-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 (file)
index 90b893f..0000000
--- 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 <stdio.h>
-#include <signal.h>
-
-/* 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 (file)
index c27acb7..0000000
--- 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 (file)
index ffa9fb7..0000000
--- 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 <stdio.h>
-
-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 (file)
index 48239ac..0000000
--- 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 (file)
index c07c136..0000000
--- 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 (executable)
index c697413..0000000
--- 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 (executable)
index b79252d..0000000
--- 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 <http://www.gnu.org/licenses/>.
-#
-# 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 <config-patches@gnu.org>."
-
-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 <features.h>
-       #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 <stdio.h>  /* 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 <sys/systemcfg.h>
-
-               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 <stdlib.h>
-               #include <unistd.h>
-
-               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 <unistd.h>
-       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' </usr/options/cb.name`
-               echo ${UNAME_MACHINE}-pc-isc$UNAME_REL
-       elif /bin/uname -X 2>/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 <Richard.M.Bartel@ccMail.Census.GOV>
-       echo i586-unisys-sysv4
-       exit ;;
-    *:UNIX_System_V:4*:FTX*)
-       # From Gerald Hewes <hewes@openmarket.com>.
-       # 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 <<EOF
-#ifdef _SEQUENT_
-# include <sys/types.h>
-# include <sys/utsname.h>
-#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 <sys/param.h>
-  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 <sys/param.h>
-#  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 <<EOF
-$0: unable to guess system type
-
-This script, last modified $timestamp, has failed to recognize
-the operating system you are using. It is advised that you
-download the most up to date version of the config scripts from
-
-  http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD
-and
-  http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD
-
-If the version you run ($0) is already up to date, please
-send the following data and any information you think might be
-pertinent to <config-patches@gnu.org> 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 (executable)
index 8b612ab..0000000
--- 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 <http://www.gnu.org/licenses/>.
-#
-# 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 <config-patches@gnu.org>."
-
-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 (file)
index eae64b6..0000000
--- 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 (file)
index 9947158..0000000
--- 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 9a78a455419c59e8ec001325268ebf0be7315e34..85fb6842dffc1ba52a07895aefa7d49f7f383d17 100755 (executable)
--- 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 <caml-list@inria.fr>.
 #
@@ -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 <stdio.h>
-#include <fcntl.h>
-#include <signal.h>
-#include <errno.h>
-#include <sys/types.h>
-#include <sys/socket.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
-}
-
-_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 <X11/Xlib.h>
-_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 <X11/Xlib.h>
-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 f5d8a2687bca02820be49069b7ee37ce791fc2a4..c2f185373d04e477ac16cf47e19475a4651b5f24 100644 (file)
--- 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 <stdio.h>
-#include <fcntl.h>
-#include <signal.h>
-#include <errno.h>
-#include <sys/types.h>
-#include <sys/socket.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
-}
-  ]])],
-  [
-    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 841f8fe275a419ad35445b9e0a2cea2bbd8f59fb..114bd380e37de199420b638b98d4f3098658212a 100644 (file)
--- 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 4d7a09662bfc5ffc0b37dbe8077635fcb9800f76..1ff7fc25f058f5ee4cfdd30ea998930d5bd3c648 100644 (file)
--- 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 97560943700ddc30f189bfbc5dfce38b9fc6f204..60813e0c8ce418826963e8447c62d9a874b47fed 100644 (file)
--- 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 fd1a9d35283e14c7359a17140e080ac1bad93fca..f664a27839500209f8826a5b8335669ef9c9bf60 100644 (file)
--- 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 81e4814e796c174f09bbfca10b305cf6d7123820..f20345a4503e459a202caa35478607d41bb44405 100644 (file)
--- 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 41429a3bde191ef9947ee359d24b92321af3ce3f..60bbdd2b7738d9ef3242ed295ff8a38696c208ad 100644 (file)
--- 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 c4b62d63e03e9d42de87996f3e85d92fd913c9a2..d5dde2114be1d0ea50ed235ba23a8ff614463a69 100644 (file)
--- 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 f9465b6255e9febbaddbf6db7e8bdd4373e78c21..ddbdc81872fd21e9ab6046a643e20de27db32045 100644 (file)
--- 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 (executable)
index 63bb86b..0000000
--- 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 ba63a63bd9d7915009b011da19096646c4511563..c41a877ff40f6bc67fbb5267be3d31ec94dbc829 100644 (file)
--- 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 2dc00d10b78fd357b8da5dc7c32cecdeafe46f76..601cfa831c3965e85b66fbfdb195cbedf30e8540 100644 (file)
--- 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 7cf81f2e2f1af528e0f507c36ebbff50bcbbbaf5..743df6c97b85ea007c174d5dd1f62b5faa5d4e04 100644 (file)
--- 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 dd1ded47c196a2b85be676059580f170acb72121..bb4c292b4f1e690811b8ed6cd35f98ff429dbe48 100644 (file)
--- 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 (file)
index ad29cc9..0000000
--- 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 (file)
index a1103f6..0000000
--- 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 (file)
index 7f2697e..0000000
--- 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 93299aed8de0dfff5e4014e8ad142d81d482b58b..a649d24a592a377b4c55c659b1a30ab3e0733d08 100644 (file)
--- a/driver/main.ml
+++ b/driver/main.ml
@@ -21,6 +21,12 @@ let usage = "Usage: ocamlc <options> <files>\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 456850eb63e6b7a97ae128e9e7049991dacece36..b7e3c08213f47beed05448b44597077d8bd3afc9 100644 (file)
--- 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, "<string>  (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,
-  "<plugin>  Load dynamic plugin <plugin>"
+  "<plugin>  (no longer supported)"
 ;;
 
 let mk_principal f =
@@ -444,6 +454,16 @@ let mk_runtime_variant f =
   "<str>  Use the <str> 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 1dff86e7952f6ef2c00bfb112b829cb4b12e73ad..64067b2c2a2ec5727a8a732f485d95fcd842afd7 100644 (file)
--- 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 655a25106256433fbfe2495d6554df6ba255a61d..d94940566f55d6ef3d3205025cf579f88ea8ce8c 100644 (file)
--- 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),
         "<module>  Opens the module <module> before typing";
-     "-plugin", Arg.String Compplugin.load,
-         "<plugin>  Load dynamic plugin <plugin>";
+     "-plugin", Arg.String(fun _p -> Clflags.plugin := true),
+         "<plugin>  (no longer supported)";
      "-pp", Arg.String(fun s -> Clflags.preprocessor := Some s),
          "<cmd>  Pipe sources through preprocessor <cmd>";
      "-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 85c655e96d3f7c5a9e567183069fd26cfbdbf96b..0af391cc5d0f4330c9c42b76b82ddff9e535bb70 100644 (file)
--- 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 27cd1e0d6fd0ad3573b441eb797d6eb23f29e86b..9a23b8b2396b031d42164e648964e4a503ef0397 100644 (file)
--- 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 b6881571d745bc763e2cd19159af1329a6c73c33..59e531e4206668e37271cda773b19e903c519da8 100644 (file)
--- 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 <n> | <round>=<n>[,...]"
        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 0b08b8c801d9cb59bfd15daa264faddf59f42bad..a5e98c0a4af1b90bb3a63ea98d8c4b2fe653661c 100644 (file)
--- 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 73eff1878053ff4c39e13a999a4c7a4ca3eaa32c..40b77a8b042b741fdec1e3b4e9c23bd4206c8e2a 100644 (file)
--- 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 a528f184b7c3c757c782f36b48df67e704a00f4f..278240475bc790badb299d14db37bb7493975eea 100644 (file)
--- 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 (file)
index 0000000..a98520a
--- /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 (file)
index 0000000..d4d665f
--- /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 (file)
index 0000000..d953a88
--- /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 (file)
index 0000000..09c787d
--- /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 (file)
index 0000000..7649de7
--- /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> := \{<cmi>\} <cmt magic> \{cmt infos\} \{<source info>\}
+    where <cmi> is the cmi file format:
+      <cmi> := <cmi magic> <cmi info>.
+    More precisely, the optional <cmi> 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 (file)
index 0000000..0efa32e
--- /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 (file)
index 0000000..c670024
--- /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 (file)
index 0000000..7a33902
--- /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 (file)
index 0000000..4dc5e59
--- /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 (file)
index 0000000..034cdc3
--- /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 (executable)
index 0000000..66ccf3c
--- /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 (file)
index 0000000..ebdd49a
--- /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 (file)
index 0000000..f79ee0c
--- /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 (file)
index 0000000..0b31ecb
--- /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 -> "<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 (file)
index 0000000..f29901b
--- /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 (file)
index 0000000..e4bb26a
--- /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@ @[<hv 1>(@[<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@ (@[<hv 1>%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 "@[<hv 1>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 "@[<hv 1>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 "@[<hv 1>default:@ %a@]" lam l
+        end in
+      fprintf ppf
+       "@[<1>(%s %a@ @[<v 0>%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 "@[<hv 1>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 "@[<hv 1>default:@ %a@]" lam default
+        | None -> ()
+        end in
+      fprintf ppf
+       "@[<1>(stringswitch %a@ @[<v 0>%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 "<ghost>" 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 (file)
index 0000000..7dab522
--- /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 (file)
index 0000000..3baabb6
--- /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 (file)
index 0000000..2aa6e66
--- /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 (file)
index 0000000..d5ca210
--- /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 (file)
index 0000000..89bfe83
--- /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 (file)
index 0000000..b4058c1
--- /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 (file)
index 0000000..1520a3b
--- /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 (file)
index 0000000..bf22fd1
--- /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 (file)
index 0000000..10b0906
--- /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 (file)
index 0000000..4c4bed0
--- /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 (file)
index 0000000..6fe2dcb
--- /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 (file)
index 0000000..7a27dbc
--- /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 (file)
index 0000000..be6ecc3
--- /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 (file)
index 0000000..d0898c7
--- /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 (file)
index 0000000..ce06353
--- /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 (file)
index 0000000..c27053e
--- /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 (file)
index 0000000..d56002b
--- /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 (file)
index 0000000..abf0f7d
--- /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 6c0d8a93e89d04978d709a97884c0eeb970244ce..b643073b4ff8982a6efa183fa7990adcf24a2f38 100644 (file)
--- 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 c3744fdaf35d5a356d20d526294416c1111b9d1a..3fdaf6f1cb991fa1c612f75af7975ad85b4a9ca7 100644 (file)
--- 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 98d1b2731601917f8b8841b3a2aeff480e4c471d..dea9b93e396630364e210f7cd91d4d5bdaa5a1f5 100644 (file)
--- 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 9ba40a237f486fdff35fbf502d157bf19df6dfa2..5c1bc40e2c83f378e3864a96866eeb26439c8701 100644 (file)
--- 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 52824d5ffe828d188c628f61f1c6ec67823304df..b7972b5176edbebed284cd5327c1b7840c0a150f 100644 (file)
--- 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 d1eade0c276fe18fbe50be934442465b9fb1a2b6..2fb6f8e7f27fc1bfb15b7663c77371d0e9e388b2 100644 (file)
--- 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 a6f478531e779d1e0a4bdb98c82e50c7f1544eac..6112a1af7ced8c9b12b333c0d100e48f1bc4055e 100644 (file)
--- 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 6cdd93674667e7ec3094ac73d2beb0af06806efb..39de94fce2a2f0cdea1c2900f65025555c1d6c4b 100644 (file)
--- 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 5cbaa94b7b36be98bd1e68144eb2dcefc3f420dd..70376a2cb9e90183d9078dfbfe98821af07a5cc3 100644 (file)
--- 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 c1f3d925c14737e2e120273235ae9fe08991939a..99c69d03fcb9245aee33e3311de3748d74878efa 100644 (file)
--- 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 0069668138ad33ea114d65b58db9ec49ef7fc3f8..1c2ab78e11e34e9eb3bfcb746b78d1f705308d49 100644 (file)
--- 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 (file)
index d870163..0000000
--- 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 e286f6a4f8600fa697605ca3b39dfb45301eb2d1..18029dbc50d1593acc75ef05f4b496555e698fc2 100644 (file)
--- 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 0af4c2c5f4dccc6d1523a0b861454078d2c3cb88..81f60937a6a9c1333771c4d5ce26dafbfaaef3d8 100644 (file)
--- 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 6862df6b7e2306afe5f9e39c1b10d6c0c2d8b533..a757ef5353a5b4c699dc7c185464b27772b0857b 100644 (file)
--- 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 d491937670bc52080e23c81d3d8e293d8e543b76..e4fb5e3ab4eecff21139c38da8251fb492fd1856 100644 (file)
--- 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 4481ebd45186740484084c4c92783001a2f7b57e..f7448b942729b937eb354108eb5951093ebce8d7 100644 (file)
--- 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 7b5b70b46cb563020a909b726c4ed675d16e3458..89568aec449e9adabfa59458d91f6cb7164a57c5 100644 (file)
--- 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 (file)
index 55a6d1d..0000000
--- 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 (file)
index 5841bfc..0000000
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 7ad9c7e6a8e969a10c20a43f4791f654668e4e93..31113c656e05f8e41b7021ec44194fd255fb742b 100644 (file)
--- 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 38b816b6b63cc502cd62e7f3ff896dd648885f69..bbaf4e56a3af5d7a91b4c6b53486e55f086f9e4d 100644 (file)
--- 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 0370a73b945714fddf3c85b1f2d837ab52aa230a..f3c94174816695fc01ab4b884b41245efedeb3ff 100644 (file)
--- 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 919d3b7a5ffa970937b12bd298f6c1aede8a60d5..7298a0d42c0a62b36e48ddd79c59a166ddc6cfe2 100644 (file)
--- 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 802f43a0248efa5bb53e17fec7300077cbf86cd1..80f0c50659cdfab68cf628b9359e3272226c85c8 100644 (file)
--- 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 (executable)
index fe97a36..0000000
--- 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 (file)
index 515daef..0000000
--- 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 (file)
index 78dc4ee..0000000
--- 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 (file)
index 0bdbe49..0000000
--- 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 (executable)
index c3a3078..0000000
--- 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 (file)
index 5c48a12..0000000
--- 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 (executable)
new mode 100644 (file)

diff --git a/middle_end/backend_var.ml b/middle_end/backend_var.ml
new file mode 100644 (file)
index 0000000..39af7f6
--- /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 "@[<hov 1>(\
+        @[<hov 1>(module_path@ %a)@]@ \
+        @[<hov 1>(location@ %a)@]@ \
+        @[<hov 1>(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 (file)
index 0000000..f236be1
--- /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 (file)
index 561e080..0000000
--- 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 (file)
index d78dd9b..0000000
--- 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 (file)
index 466f59a..0000000
--- 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 (file)
index 853a07f..0000000
--- 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 (file)
index 2285c68..0000000
--- 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 (file)
index 86fcd56..0000000
--- 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 (file)
index 7fb4816..0000000
--- 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 (file)
index fc7d3bf..0000000
--- 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 (file)
index 681ac95..0000000
--- 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 (file)
index 54c1441..0000000
--- 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 (file)
index 6d2e274..0000000
--- 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 (file)
index 48ca037..0000000
--- 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 (file)
index 46febfb..0000000
--- 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 (file)
index 5873191..0000000
--- 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 (file)
index 07fe315..0000000
--- 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 (file)
index 17fe208..0000000
--- 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 (file)
index 681ac95..0000000
--- 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 (executable)
index 811cb66..0000000
--- 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 (file)
index a5ef8c7..0000000
--- 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 (file)
index 4c9cfdc..0000000
--- 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 (file)
index 6cecae6..0000000
--- 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 (file)
index 88f690a..0000000
--- 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 (file)
index 22a2e0a..0000000
--- 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 "<no symbol>"
-  | 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 (file)
index d2771af..0000000
--- 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 (file)
index cfa51dd..0000000
--- 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 (file)
index 12ce552..0000000
--- 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 (file)
index 466f59a..0000000
--- 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 (file)
index 56f0af0..0000000
--- 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 (file)
index 64099a7..0000000
--- 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 "<no var>"
-  | 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 (file)
index b5d3f13..0000000
--- 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 (file)
index 0000000..406bfbc
--- /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 (file)
index 0000000..ddd0956
--- /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 (file)
index 0000000..a7c9798
--- /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 (file)
index 0000000..d534ca9
--- /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 (file)
index 0000000..20767f6
--- /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 (file)
index 0000000..92c7473
--- /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 (executable)
index a852ae8..0000000
--- 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 (file)
index f5fab0a..0000000
--- 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 (file)
index cfcaf34..0000000
--- 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 (executable)
index f16f05f..0000000
--- 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 (file)
index 0000000..7fb4816
--- /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 (file)
index 0000000..fc7d3bf
--- /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 (file)
index 0000000..add4e90
--- /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 (file)
index 0000000..569d51e
--- /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 (file)
index 0000000..17d17ea
--- /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 (file)
index 0000000..8c36912
--- /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 (file)
index 7a33902..0000000
--- 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 (file)
index 4dc5e59..0000000
--- 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 (file)
index b5ab618..0000000
--- 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 (file)
index b025bf0..0000000
--- 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 (file)
index 33cd473..0000000
--- 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 (file)
index 47456bd..0000000
--- 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 (file)
index e694330..0000000
--- 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 (file)
index 3c2dd5b..0000000
--- 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 (file)
index a16b51a..0000000
--- 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 "<always>"
-      | Never_inline -> fprintf ppf "<never>"
-      | Unroll i -> fprintf ppf "<unroll %i>" 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@ @[<hv 1>(@[<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@ (@[<hv 1>%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 "@[<hv 1>case int %i:@ %a@]" n lam l)
-          sw.consts;
-        List.iter
-          (fun (n, l) ->
-             if !spc then fprintf ppf "@ " else spc := true;
-             fprintf ppf "@[<hv 1>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 "@[<hv 1>default:@ %a@]" lam l
-        end in
-      fprintf ppf
-        "@[<1>(%s(%i,%i) %a@ @[<v 0>%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 "@[<hv 1>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 "@[<hv 1>default:@ %a@]" lam default
-        | None -> ()
-        end in
-      fprintf ppf
-       "@[<1>(stringswitch %a@ @[<v 0>%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 (executable)
index a301dd4..0000000
--- 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 (file)
index 0000000..fe97a36
--- /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 (file)
index 0000000..515daef
--- /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 (file)
index 0000000..78dc4ee
--- /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 (file)
index 0000000..0bdbe49
--- /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 (file)
index 0000000..c3a3078
--- /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 (file)
index 0000000..5c48a12
--- /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 (file)
index 0000000..561e080
--- /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 (file)
index 0000000..d78dd9b
--- /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 (file)
index 0000000..466f59a
--- /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 (file)
index 0000000..853a07f
--- /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 (file)
index 0000000..2285c68
--- /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 (file)
index 0000000..86fcd56
--- /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 (file)
index 0000000..681ac95
--- /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 (file)
index 0000000..54c1441
--- /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 (file)
index 0000000..6d2e274
--- /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 (file)
index 0000000..48ca037
--- /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 (file)
index 0000000..07fe315
--- /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 (file)
index 0000000..17fe208
--- /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 (file)
index 0000000..681ac95
--- /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 (file)
index 0000000..811cb66
--- /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 (file)
index 0000000..a5ef8c7
--- /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 (file)
index 0000000..4c9cfdc
--- /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 (file)
index 0000000..6cecae6
--- /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 (file)
index 0000000..88f690a
--- /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 (file)
index 0000000..cfa51dd
--- /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 (file)
index 0000000..12ce552
--- /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 (file)
index 0000000..466f59a
--- /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 (file)
index 0000000..56f0af0
--- /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 (file)
index 0000000..67fea2d
--- /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 (file)
index 0000000..0380604
--- /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 (file)
index 0000000..9bdd30e
--- /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 (file)
index 0000000..f5fab0a
--- /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 (file)
index 0000000..cfcaf34
--- /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 (file)
index 0000000..f16f05f
--- /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 (file)
index 0000000..51a09f0
--- /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 (file)
index 0000000..7ecf9c2
--- /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 (file)
index 0000000..d0cbd44
--- /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 (file)
index 0000000..b025bf0
--- /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 (file)
index 0000000..22dbb6c
--- /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 "<None>"
+    | 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 "@[<hov 2>(%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 "@[<hov 2>%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 "@[<hov 2>Globals:@ ";
+  fprintf ppf "@]@ @[<hov 2>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 "@[<v 2>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 "@]@ @[<v 2>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 (file)
index 0000000..f93698b
--- /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 (file)
index 0000000..42a8155
--- /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 (file)
index 0000000..2ba3a35
--- /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 (file)
index 0000000..33cd473
--- /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 (file)
index 0000000..47456bd
--- /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 (file)
index 0000000..e694330
--- /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 (file)
index 0000000..3c2dd5b
--- /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 (file)
index 0000000..243e2e3
--- /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 "<always>"
+      | Never_inline -> fprintf ppf "<never>"
+      | Unroll i -> fprintf ppf "<unroll %i>" 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@ @[<hv 1>(@[<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@ (@[<hv 1>%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 "@[<hv 1>case int %i:@ %a@]" n lam l)
+          sw.consts;
+        List.iter
+          (fun (n, l) ->
+             if !spc then fprintf ppf "@ " else spc := true;
+             fprintf ppf "@[<hv 1>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 "@[<hv 1>default:@ %a@]" lam l
+        end in
+      fprintf ppf
+        "@[<1>(%s(%i,%i) %a@ @[<v 0>%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 "@[<hv 1>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 "@[<hv 1>default:@ %a@]" lam default
+        | None -> ()
+        end in
+      fprintf ppf
+       "@[<1>(stringswitch %a@ @[<v 0>%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 (file)
index 0000000..325c15e
--- /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 (file)
index 0000000..250a2e9
--- /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 (file)
index 0000000..252578e
--- /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 (file)
index 0000000..a69575d
--- /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 (file)
index 0000000..02fe685
--- /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 (file)
index 0000000..e604a32
--- /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 (file)
index 0000000..584cb45
--- /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 (file)
index 0000000..2f60f9f
--- /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 -> "<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 (file)
index 0000000..8c493d4
--- /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 (file)
index 0000000..c204f5e
--- /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 (file)
index 0000000..0f7b318
--- /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 (file)
index 0000000..891861a
--- /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 (file)
index 0000000..1550797
--- /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 (file)
index 0000000..64fbbb8
--- /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 (file)
index 0000000..23d9d29
--- /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 (file)
index 0000000..59f8aa8
--- /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 (file)
index 0000000..2c5309e
--- /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 (file)
index 0000000..31246b0
--- /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 (file)
index 0000000..fc54f76
--- /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 (file)
index 0000000..7d304cd
--- /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 (file)
index 0000000..9a8e6e8
--- /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 (file)
index 0000000..bb725e8
--- /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 (file)
index 0000000..79d84a3
--- /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 (file)
index 0000000..33e870f
--- /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
+      "@[<v>@[<h>%s@]@;@[<h>%s@]@;@[<h>%s@]@;@[<h>%a@]@;@[<h>%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@,@[<v>@[<v 2>@;%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 (file)
index 0000000..345f67a
--- /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 (file)
index 0000000..ca462a5
--- /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 (file)
index 0000000..3694e30
--- /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 (file)
index 0000000..15a0803
--- /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 (file)
index 0000000..6809d4c
--- /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 "@[<h>%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 "@[<h>%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 (file)
index 0000000..f1e84fd
--- /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 (file)
index 0000000..7aef079
--- /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 "@[<h>%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 "@[<v>@[%a@]@;@;@[%a@]@]"
+        Not_specialised.summary s Inlined.summary i
+    | Unchanged (s, i) ->
+      Format.fprintf ppf "@[<v>@[%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 (file)
index 0000000..9d476c8
--- /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 (file)
index 0000000..c46a6cb
--- /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 (file)
index 0000000..e31d1b0
--- /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 = <access to [y] in [clos_id]> 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 (file)
index 0000000..a43cfda
--- /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: @[<hv>%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 (file)
index 0000000..c685142
--- /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 (file)
index 0000000..02292c4
--- /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 (file)
index 0000000..92ecda0
--- /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 = <expr> in b, b in fst c
+    would be transformed to:
+      let b = <expr> in let c = b, b in fst c
+    which is then clearly just:
+      <expr>
+*)
+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 (file)
index 0000000..dd60de9
--- /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 (file)
index 0000000..969c365
--- /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 (file)
index 0000000..ccef0d8
--- /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 (file)
index 0000000..afb1c60
--- /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 (file)
index 0000000..0c916dd
--- /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 (file)
index 0000000..ceed167
--- /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 (file)
index 0000000..a200533
--- /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 (file)
index 0000000..3a30e61
--- /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 (file)
index 0000000..2c660a2
--- /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 (file)
index 0000000..1b251ca
--- /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 (file)
index 0000000..f93948f
--- /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 (file)
index 0000000..38d3688
--- /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 (file)
index 0000000..6327d30
--- /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 (file)
index 0000000..49f25ac
--- /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 (file)
index 0000000..f70da72
--- /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 (file)
index 0000000..759b32f
--- /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 (file)
index 0000000..0d4ad62
--- /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 (file)
index 0000000..225697a
--- /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 (file)
index 0000000..059d68b
--- /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 (file)
index 0000000..3a72201
--- /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 (file)
index 0000000..2bbd713
--- /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 (file)
index 0000000..7fec22b
--- /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 (file)
index 0000000..34fc5ce
--- /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 "<Function Body>"
+    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 (file)
index 0000000..dd38652
--- /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 (file)
index 0000000..1f95a1e
--- /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 (file)
index 0000000..f346104
--- /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 (file)
index 0000000..f30987a
--- /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 (file)
index 0000000..fcbbcfb
--- /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 (file)
index 0000000..c667bff
--- /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 (file)
index 0000000..349d2f4
--- /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 (file)
index 0000000..a6b6330
--- /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 (file)
index 0000000..1b7ce57
--- /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 (file)
index 0000000..2825a38
--- /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 (file)
index 0000000..50f9e7b
--- /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 (file)
index 0000000..92ea06c
--- /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 (file)
index 0000000..5c86bed
--- /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 (file)
index 0000000..fb935a6
--- /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 (file)
index 0000000..7a4e48e
--- /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 (file)
index 0000000..3ee181e
--- /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 (file)
index 0000000..70eb876
--- /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 (file)
index 0000000..f019176
--- /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 (executable)
index f236fd0..0000000
--- 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 (file)
index 6a24ef3..0000000
--- 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 (file)
index a69575d..0000000
--- 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 (file)
index 02fe685..0000000
--- 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 (file)
index 1bb3a2a..0000000
--- 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 (file)
index 0f7b318..0000000
--- 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 (file)
index 891861a..0000000
--- 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 (file)
index 1550797..0000000
--- 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 (executable)
index 3d8ba90..0000000
--- 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 (file)
index 2c5309e..0000000
--- 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 (file)
index 31246b0..0000000
--- 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 (file)
index fc54f76..0000000
--- 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 (executable)
index c1e6ff5..0000000
--- 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 (file)
index 9a8e6e8..0000000
--- 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 (file)
index bb725e8..0000000
--- 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 (executable)
index 79d84a3..0000000
--- 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 (file)
index f2af293..0000000
--- 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
-      "@[<v>@[<h>%s@]@;@[<h>%s@]@;@[<h>%s@]@;@[<h>%a@]@;@[<h>%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@,@[<v>@[<v 2>@;%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 (file)
index 345f67a..0000000
--- 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 (executable)
index ca462a5..0000000
--- 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 (file)
index 3694e30..0000000
--- 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 (file)
index 15a0803..0000000
--- 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 (file)
index 6809d4c..0000000
--- 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 "@[<h>%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 "@[<h>%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 (file)
index f1e84fd..0000000
--- 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 (file)
index 7aef079..0000000
--- 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 "@[<h>%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 "@[<v>@[%a@]@;@;@[%a@]@]"
-        Not_specialised.summary s Inlined.summary i
-    | Unchanged (s, i) ->
-      Format.fprintf ppf "@[<v>@[%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 (file)
index 9d476c8..0000000
--- 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 (executable)
index c46a6cb..0000000
--- 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 (file)
index e31d1b0..0000000
--- 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 = <access to [y] in [clos_id]> 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 (file)
index 7cd6bf1..0000000
--- 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 (file)
index 689e741..0000000
--- 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 ee40085603d0e4d3daea5f1dd4ca1608d089c041..b87e73f74f3048ea44ebca65162624f1e45ba76c 100644 (file)
--- 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 24712e89a61d7608a5d99791f00ec4fed7bb9054..11a8231e959ded1a3681831264bdc236238063b3 100644 (file)
--- 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 (executable)
index a43cfda..0000000
--- 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: @[<hv>%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 (file)
index c685142..0000000
--- 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 (file)
index 02292c4..0000000
--- 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 (file)
index 92ecda0..0000000
--- 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 = <expr> in b, b in fst c
-    would be transformed to:
-      let b = <expr> in let c = b, b in fst c
-    which is then clearly just:
-      <expr>
-*)
-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 (file)
index dd60de9..0000000
--- 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 (file)
index 969c365..0000000
--- 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 (file)
index ccef0d8..0000000
--- 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 (file)
index afb1c60..0000000
--- 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 (file)
index 0000000..46febfb
--- /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 (file)
index 0000000..5873191
--- /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 (file)
index e604a32..0000000
--- 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 (file)
index 584cb45..0000000
--- 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 (file)
index 0c916dd..0000000
--- 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 (file)
index ceed167..0000000
--- 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 (file)
index a200533..0000000
--- 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 (file)
index 3a30e61..0000000
--- 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 (file)
index 0000000..fceb348
--- /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@ @[<hv 1>(@[<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@ @[<hv 1>(@[<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@ (@[<hv 1>%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
+       "@[<v 0>@[<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 "@[<hv 1>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 "@[<hv 1>default:@ %a@]" lam d
+        | None -> ()
+        end in
+      fprintf ppf
+        "@[<1>(switch %a@ @[<v 0>%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 "@[<hov 1>(%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 (file)
index 0000000..121667e
--- /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 (file)
index 0000000..3f62706
--- /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 (file)
index 0000000..07db5a1
--- /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 (file)
index 2c660a2..0000000
--- 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 (file)
index 1b251ca..0000000
--- 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 (file)
index f93948f..0000000
--- 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 (file)
index 38d3688..0000000
--- 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 (executable)
index 6327d30..0000000
--- 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 (file)
index 49f25ac..0000000
--- 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 (file)
index f70da72..0000000
--- 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 (file)
index 759b32f..0000000
--- 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 (file)
index 0d4ad62..0000000
--- 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 (file)
index 225697a..0000000
--- 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 (file)
index 059d68b..0000000
--- 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 (file)
index 3a72201..0000000
--- 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 (file)
index 0000000..2daf167
--- /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 (file)
index 0000000..78407df
--- /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 (file)
index 2bbd713..0000000
--- 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 (file)
index 7fec22b..0000000
--- 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 (file)
index 34fc5ce..0000000
--- 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 "<Function Body>"
-    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 (file)
index dd38652..0000000
--- 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 (file)
index 24d51e5..0000000
--- 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 (file)
index f346104..0000000
--- 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 (file)
index ee62100..0000000
--- 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 (file)
index fcbbcfb..0000000
--- 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 (file)
index c667bff..0000000
--- 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 (file)
index a7107f7..0000000
--- 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 (file)
index 7f1f149..0000000
--- 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 (file)
index 0000000..22a2e0a
--- /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 "<no symbol>"
+  | 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 (file)
index 0000000..d2771af
--- /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 (file)
index 5c86bed..0000000
--- 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 (file)
index fb935a6..0000000
--- 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 (file)
index 7a4e48e..0000000
--- 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 (file)
index 3ee181e..0000000
--- 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 (executable)
index 70eb876..0000000
--- 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 (file)
index f019176..0000000
--- 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 (file)
index 0000000..64099a7
--- /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 "<no var>"
+  | 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 (file)
index 0000000..b5d3f13
--- /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 96b04ba38bd8e48562ba0abfb3fe7bea4d570942..30d48eb24c758930a395eae698f2ebded0a5476e 100644 (file)
--- 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 f8b8cf633b501816babd966e9cd5d74147341cf6..6710176b43875b293349ecaa3823aeca97985937 100644 (file)
--- 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 fdeb7bf14df6c89d1cbead3fca9f6a982a2bd8f0..9b027426372986e83356d3c09811e7250b9be71b 100644 (file)
--- 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 8cae70afc95a7163fe577108582a6a7f00ae85ae..ab29fe7b2dedf190c43e97d5b6dabfedd897203a 100644 (file)
--- 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 ff86aa6d57383ddff9647eb1305325f3b7711dca..dd1c448ff3b48525be4c257a376a48a65f8610c5 100644 (file)
--- 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 f226e550bf5e9650b264f7a8492e6f0534336b4a..1c0067aa53c61076e041be3c50610e4d35a85fb1 100644 (file)
--- 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 4b1c2a32faedc72619cd27490ac8ac0343fe5a59..64af2eec151526696ec54720c287444445b7f872 100644 (file)
--- 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 6fbedc6bccb33fcf15dc30dfde167f1ba406b085..241270eb361bfe9e6f9ce75098f07422b97ba91a 100644 (file)
--- 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 be3664da79479ebd74fef24439b0657fdfcf0835..02c17aa7d87323f245b98da341d163698ac36efc 100644 (file)
--- 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 520b2451101ed148ef4b396a5583d64931c3063b..bfb31cc7e40ae963e00b9a6225b4051ac43c5377 100644 (file)
--- 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 6bf8ed239c9b657d7defbc300fd14fb76f7e572b..cfa4fbcf56a27a5ff2f2244950ffa3a414654897 100644 (file)
--- 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 f118d2c6eb51aed0e48a91371a4eacb89b0c8e03..bfe69d8af33a42a948d6ac9e0bf3d5f2be6ffab2 100644 (file)
--- 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 c0b75154f589aef201ef4b807740aa2060b41a43..647fd4f18d494bc4689105970e7d9f1ea0e3c01c 100644 (file)
--- 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 5fc70e7ef44d29f537def3367af0fbc11ccbd432..2db26d2d904b75f4334394671a65533d7bb11f66 100644 (file)
--- 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 (file)
index 0000000..0a3555b
--- /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 6e7c4238494a20dff59ebdaf28fecf941c295a4e..2a59ad5bfc2c53d027041f66dd3ec345439ff44c 100644 (file)
--- 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 (file)
index 0000000..9bb5432
--- /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 83b8879caba18173d9df8aab22060a1951d33f09..32a84264a04f1447a56f14b490ff7b03b077a3ea 100644 (file)
--- 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 (file)
index 35bd88e..0000000
--- 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 3b81e752fb06f1bb98581b616335a1260d3f5f44..a9770a25ac4a8881ca0e748e71dd0af63039ed8e 100644 (file)
--- 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 4ce7c63ab2e1586009d572d41154a19d81375bc8..3a362fd1e7f73f7e9eb050588b63a99cdd8e8a1f 100644 (file)
--- 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 a4c001eaa52bf6d437eca09d8f885ee71d29871e..a92012493a62d9ed26e3bce321e095bcab2776da 100644 (file)
--- 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 (file)
index 0000000..4bd3bc5
--- /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 900f595cfd54439469110a3c443638b93d3b7a08..d4b3a9b67ef7575447dba65ded893f07612995cb 100644 (file)
--- 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 2ccbda86e67863e6a9cb13fcfc290a89f52443c3..49c483942f895f24a3f49db3be776b4076685d10 100644 (file)
--- 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 (file)
index 24f04f5..0000000
--- 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 (file)
index 0000000..fda3211
--- /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 (file)
index 4556e77..0000000
--- 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 (file)
index 1ac6088..0000000
--- 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 (file)
index fee153f..0000000
--- 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 (file)
index 5d7bafc..0000000
--- 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 <X11/Xatom.h>
-
-/* 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 (file)
index 6e0f937..0000000
--- 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 <caml/alloc.h>
-
-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 (file)
index 6d9be70..0000000
--- 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 <caml/alloc.h>
-#include <caml/memory.h>
-
-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 (file)
index b858b03..0000000
--- 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 <signal.h>
-#include "libgraph.h"
-#include <caml/alloc.h>
-#include <caml/signals.h>
-#include <sys/types.h>
-#include <sys/time.h>
-#ifdef HAS_SYS_SELECT_H
-#include <sys/select.h>
-#endif
-#include <string.h>
-#include <unistd.h>
-
-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 (file)
index 0eb307f..0000000
--- 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 <caml/memory.h>
-
-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 (file)
index 3632898..0000000
--- 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 (file)
index 1acbd0d..0000000
--- 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 (file)
index 10f39f3..0000000
--- 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 (file)
index e022999..0000000
--- 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 (file)
index baa8554..0000000
--- 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 <caml/alloc.h>
-#include <caml/custom.h>
-
-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 (file)
index acb8511..0000000
--- 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 (file)
index e2dcb2b..0000000
--- 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 <stdio.h>
-#include <X11/Xlib.h>
-#include <X11/Xutil.h>
-#include <caml/mlvalues.h>
-#include <caml/misc.h>
-
-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 (file)
index f1cd761..0000000
--- 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 <caml/memory.h>
-
-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 (file)
index 7fac8c9..0000000
--- 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 <string.h>
-#include <fcntl.h>
-#include <signal.h>
-#include "libgraph.h"
-#include <caml/alloc.h>
-#include <caml/callback.h>
-#include <caml/fail.h>
-#include <caml/memory.h>
-#ifdef HAS_UNISTD
-#include <unistd.h>
-#endif
-#ifdef HAS_SETITIMER
-#include <sys/time.h>
-#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 (file)
index 3c3d33d..0000000
--- 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 (file)
index 75ab2a5..0000000
--- 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 (file)
index 8ccd78f..0000000
--- 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 (file)
index d98c884..0000000
--- 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 <caml/alloc.h>
-
-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 386d45632364df9f07bc4bee31e2195d3ddaa4fe..5e42cdd4a099839146dbcbc2c2b9ed6ee394352e 100644 (file)
--- a/otherlibs/systhreads/st_posix.h
+++ b/otherlibs/systhreads/st_posix.h
@@ -15,6 +15,7 @@
 
 /* POSIX thread implementation of the "st" interface */
 
+#include <assert.h>
 #include <errno.h>
 #include <string.h>
 #include <stdio.h>
@@ -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 c751ffbcf1961ce1205b6844b8e400cb9b9df1f1..bfe57514b552ce9e39c959420e370c16f9556c2d 100644 (file)
--- 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 2f2ea6659384e443af0ef8cc6bcb972814a6a8fd..fcc25290d9b407af5a3a99b0adf6133c68d8ed1d 100644 (file)
--- 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 (file)
index 8c74f88..0000000
--- 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 (file)
index 9b81940..0000000
--- 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 (file)
index c685d81..0000000
--- 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 (file)
index 2557fe7..0000000
--- 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 (file)
index b00a6fc..0000000
--- 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 (file)
index a192123..0000000
--- 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 (file)
index f09be91..0000000
--- 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 (file)
index 8209d7d..0000000
--- 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 (file)
index 8953a15..0000000
--- 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 (file)
index 7a69bfc..0000000
--- 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 <string.h>
-#include <stdlib.h>
-#include <stdio.h>
-
-#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 <errno.h>
-#include <sys/time.h>
-#include <sys/types.h>
-#include <sys/wait.h>
-#include <sys/stat.h>
-#include <fcntl.h>
-#ifdef HAS_UNISTD
-#include <unistd.h>
-#endif
-#ifdef HAS_SYS_SELECT_H
-#include <sys/select.h>
-#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 (file)
index d256f00..0000000
--- 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 (file)
index c4561e1..0000000
--- 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 (file)
index a835a0f..0000000
--- 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 (file)
index 95b5857..0000000
--- 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 (file)
index bd37f71..0000000
--- 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 (file)
index 86d0466..0000000
--- 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 e949f55f5e8620fbecb4655b0b7bd8872cf54696..15465ddc6261325047d5480416ed1a74086a9f83 100644 (file)
--- a/otherlibs/unix/mmap.c
+++ b/otherlibs/unix/mmap.c
@@ -38,29 +38,9 @@
 #include <sys/stat.h>
 #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 f85bcc2ffe3ac65837322bb7f8d1aaaf058bf023..bdb5c60f63f33c8dc52b79d7722b798bd24fe0c0 100644 (file)
--- 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 859dbe446729ac097c51f639a5b910cdf2beddf3..cae1ce0fd08a8fffad2e50d46a5fc2e2c530ab41 100644 (file)
--- 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 547243123266092e949e0e57ad9e57cce423a67d..bada9ae7bae7e513d54b3f4fb2567cf54d715c57 100644 (file)
--- 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 8f7eeeb1705f59bcb2687512dea0ac266063750a..3e053246697bed25dec247b1e4178f4292d3530e 100644 (file)
--- 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 9bbb9343d60effcf638a9784e9198550ea5918d2..937146b21d8942decdc7b31dccb3026c85abe177 100644 (file)
--- 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 448b3f312148f10b4b77109107e8223dea4ac859..d0f06bfcbcef8b7cbeb5e5cac4a1f97092554cf6 100644 (file)
--- 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 (file)
index 66cd62b..0000000
--- 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 (file)
index 3c76eb8..0000000
--- 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 <math.h>
-#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 (executable)
index 810d863..0000000
--- 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 <windows.h>
-
-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 (file)
index 674f92f..0000000
--- 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 <stdio.h>
-#include <windows.h>
-#include <windowsx.h>
-
-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 (file)
index 3bde8a2..0000000
--- 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 <fcntl.h>
-#include <signal.h>
-#include "caml/mlvalues.h"
-#include "caml/fail.h"
-#include "libgraph.h"
-#include "caml/callback.h"
-#include <windows.h>
-
-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 6a97e7f0e1b8cddb0d145b57245ced8b97cbebc9..da08a19fde139e689d6709373af5f0e177bee3ea 100644 (file)
--- 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 (executable)
new mode 100644 (file)

diff --git a/otherlibs/win32unix/unixsupport.c b/otherlibs/win32unix/unixsupport.c
index 71769e94ef2291ff943575d2479a39edaa3f4607..c6005bfcce1c82b49a443b142012db7924eb0d42 100644 (file)
--- 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 (executable)
new mode 100644 (file)

diff --git a/parsing/ast_iterator.mli b/parsing/ast_iterator.mli
old mode 100755 (executable)
new mode 100644 (file)

diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index f2fcd92f6c54ba18d13f72a4690baafa95569ee4..8488f15372b382d27e89f6ea99d0503fbf3fd7d3 100644 (file)
--- 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 (executable)
new mode 100644 (file)

diff --git a/parsing/builtin_attributes.mli b/parsing/builtin_attributes.mli
old mode 100755 (executable)
new mode 100644 (file)
index 35e78ab..03949ee
--- 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 cbed53b9cf1a77cabdc28184dfaeb4b3e79198d7..74c095f969eff8aacbde2715ecccb7d6211b844d 100644 (file)
--- 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 1c0cda3af6b95311f4c66f3eabcd59f39942aee3..25cba42c7d4c241b585aac98ca728bdfb2d8c6d6 100644 (file)
--- 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 1590a89deec8f4b7ce7e28808e2cee7a0bc17868..318ece498b927ab7d1e9d1844b6d69613c8ce625 100644 (file)
--- 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 "@[<hv>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 "@[<hov2>(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l
     | Pexp_constraint (e, ct) ->

diff --git a/runtime/.depend b/runtime/.depend
index 3b707ee490be6ed4437918ae84fe3032fd07f6d0..a89d380da8565fbed4e06620ecb4a9c2f6d61589 100644 (file)
--- 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 9dabe5b2cec865ee0c274d50080e4b7b16588418..7c94d621c30ff171ae7d0a7f940b19a0788c9d4a 100644 (file)
--- 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 a3e6fbc2f50bc82e14913215c0beeb919c9ac85a..3112065eda0b7483a299f30ee659172c7231a00a 100644 (file)
--- 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 1a024283e6539af8673d55811fce0152526c2b18..ab54633c3dce0cf329a6ac1c7141c10789faf97e 100644 (file)
--- 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 12bc4a1b99efc2cbb6bb70f49feb1e72b27714e3..fd43b2141b183d88d62760dc83a47d0f61f20eb9 100644 (file)
--- 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 bb8e1b5e4db1d2d0c91a48db89c06c101c3eb644..f78572639796c87be9f3060ba92c2bd4c4a548cb 100644 (file)
--- 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 8ea94eed140c3134daf3578421e15f39c19e7086..b913dacdd536bf524d4bc6bdf56a02e9f350000c 100644 (file)
--- 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 9c479b3044375d7a5b86d96f926d38b5880ff7fa..03a89b30ff2533c06e111ff90e9255cd96bdc071 100644 (file)
--- 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 93208b7a1d59f6f46c58eed5f483ee92ffee374a..82fab82e87bbec0b8a543d385a077709566601ed 100644 (file)
--- 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 584d268261420e2cc7dc902d801208471920c488..4d5b99db53b66481d392ff4727639b2bd2d6c71d 100644 (file)
--- 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 4e70edb16cb41afa6980605bb1e32c687f4b8e5a..56a9a604d36f3b624c7d60d747ec71be5d9403f5 100644 (file)
--- 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 07c5310dc84ace3cb6f17cca158fcdc3db28c0ef..9aa65371fca589d5fb17eb2ad086b96dd20a4198 100644 (file)
--- 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 (file)
index c1cddcc..0000000
--- 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 <math.h>
-
-#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 (file)
index 40250ed..0000000
--- 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 (file)
index 7df6651..0000000
--- 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 6aa98516bef6cfbe4b7087975ea7338104ee26d7..4466d292e74ec1db90e47dac549d450e9f475a20 100644 (file)
--- 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 70bd891fb1d4c75378e7c780e0f1fa3c26311d76..2e7db51604534d3bb32e878a8317c3e1af7dcfeb 100644 (file)
--- 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 5de2e0e852ac9af2bf1a267ecce0a049d806aee0..fd7ed763d343c02ea8ef506592b2e323bb377f78 100644 (file)
--- 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 a7c202788eebb2f6fee48974533c225160d9ca10..f77cf1eb6530dc28ca59a186f13acdac18938c1a 100644 (file)
--- 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 cf728b0ed683e517b79f9db1d7546fd0299a31c2..2d61f53cc6d0610dceb037e992f2007c65255357 100644 (file)
--- 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 <stdlib>/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 248b61a6d6347f144417bd838e7924e023ea7043..ac434210c9e81f811860104332f9f88ff0307dd3 100644 (file)
--- 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 ec5bfebc961e96f00a81e01324b8e2df661f20ab..e1f687d379e117eb84a3f91a5dde040289fca803 100644 (file)
--- 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 33bf14e814ac36c4f6f50bf8d338b886bea0b8ef..aba01a99783793d43a2792ae5661d50249048124 100644 (file)
--- 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 f689723c205d3ae5d4d8b875afd71a6bb108d166..54fc8b8f6735d48e47975dc3e07cf5667c221f37 100644 (file)
--- 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 aa6a913747f249bf02fb08eb49f2e6cdf40cf17b..a3f05877c15169f07a11cd07090488343152ad3c 100644 (file)
--- 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 9932d80b0852414f6acd2330868689aa4717b8d5..6e2dcc79dbb429e99dd1c00271043f4a535112c6 100644 (file)
--- 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 df6c65a4a7c4ae26419e69297b79a2ac63144130..c9584e4aba2ce36201aa23bc658d4377dc3652ee 100644 (file)
--- 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 4567b8aefca33755621e7fb4834849f742aae05c..a264486615fbca024354e1d6143ed6229d775056 100644 (file)
--- 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 83176500328dcfbb5ba6ffe4352b61159a8f72aa..3220a21dcfeebd3441eec72659e997f3b27e01b2 100644 (file)
--- 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 d9bc8b18a29030438db8417455527ea7730b420e..417768f009be0f93512f4490c9e0b49c02ef2120 100644 (file)
--- 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 <sys/ucontext.h>
+
+  #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 b479f3e23a18ba9cb86b7acf82e310c692ab5595..cb3d9b7927063f68008d70798392fb69e806ad0c 100644 (file)
--- 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 9ab22e2aeec0d75f29bdc810ed03a2b82f326068..a187d91a86593d6401f22de35ca5e26fcdc2222f 100644 (file)
--- 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 1f6489566de2c51047116970f83ac6b1e265e05d..a996788bc336ed5c0784877b11f48421486c64dc 100644 (file)
--- 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 43b85e3196b96209093da93dacf62b90d7cb1fa2..b4e6bc4743e61c814d93ba6fb8f35c68fe075bdd 100644 (file)
--- 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 c019ee9f7e73b72bfc255b083c80d66c3f2644b5..226d596cdff1266f832fa56849d47ff509ae3a4b 100644 (file)
--- 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 f6ae5a0a1db907a2b631d8b98e99486d7f1031ce..de4757d01cd9f0c24b4ab9de953ee69689d4e3b6 100644 (file)
--- 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 8929413f4005eeaa4fa2ba8273f79b3e68b4b4f4..7c6f34946b5065f61dcf6da582865a0119788c14 100644 (file)
--- 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 0f3138cd8f75597f8d230fd09b798c4a1dc932c1..8aa243982149eca2568a789ca5d5e4c2f9cecdae 100755 (executable)
--- 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 67dc8bc4788a1ae84ad6e06874c99d40df4ca03e..97135b5ac60600195ba80d64ccd362c49965048c 100644 (file)
--- 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 e8d83c1c5499ec92d9100f604553d06ca8a872dd..db2182644e33da261d6bcef9b5dc6fb71214d050 100644 (file)
--- 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 d449f82dbd6c0eaebde05722b2550367369ba24c..1016c685d0a7f8d1820685a7b84b9bbbb427cfa6 100644 (file)
--- 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 2cc700a511f295edcf6d51d245962b0e4704b14e..baa7d1fb87e6bd41686e864f793539fd92ac5e45 100644 (file)
--- 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 7c36e22afc71eed77cf22b6cf3c010af1ea78518..b10fba81ad97794f7e8bb57240ae89661b002cb7 100644 (file)
--- 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 03e973cedcdfdab3b3cf76e5fe9a05f50f6b15dd..c7fe17e6f642ecc7810b7818269e7d3f447d3523 100644 (file)
--- 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 4b7f438987a63591169b96334505ce4b659fef0f..952f67a526b0ffc29ef0caa740da05499566a367 100644 (file)
--- 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 bc727b73d7684dcf792e1620174d8c21b584a1cf..8226ffda2e3465505c60de151e8a5704d428c8aa 100644 (file)
--- 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 5ccf92893b2da7043305cda23f8a857fadb5d400..c56d22ef183a659b169105c25902673a718e7c36 100644 (file)
--- 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 b2269a95c2fff17ebee7bc9f5f5762205444b2a3..32049d72b3af977678ba50e19fd55726bf3a3e61 100644 (file)
--- 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 bac04d569bcebfc5d29b0654a161f1f194a81030..818f315f5423a7e302a9ffc4916a20f2358ef076 100644 (file)
--- 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 28f4fe06605e0e15ea8bba01b554a48d1c313f29..13d9ebee5872686d94e7f1a5d3df2ad202e36728 100644 (file)
--- 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 da22a5230c21354e58fd559ff124428f7d4657b9..c215ad76e17896737ddf2ffc0c6598201839d2c1 100644 (file)
--- 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 a80aa04544ba1e21f924ea462b0f428ceedf30b9..445718308ad0368be215e649bd3d8badeb1e5044 100644 (file)
--- 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 b4d62a81259746b18e9c932d6c2666cf2d3009b8..b72c1e6db5b4e9076a1aa6dd2460ee8cdca18e06 100644 (file)
--- 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 370449ecff25697cc24d418bf0722cebf0cd2d32..87fd06222c48cd483eb674307e22a73dc0c6bd94 100644 (file)
--- 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 5d997e8ad9e36888ced238ea834a5a6152eee9cb..2da2b7784651ef4909d4977da0c916709ba3e248 100644 (file)
--- 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 5368ff8017a72fdf6906136207c1591b33e8ae8f..1746574f2de1aacae34274fdc014c8a8bdb194d7 100644 (file)
--- 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 (file)
index c87f2d0..0000000
--- 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 (file)
index 00d776f..0000000
--- 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 (file)
index e69de29..0000000

diff --git a/testsuite/interactive/lib-graph-3/Makefile b/testsuite/interactive/lib-graph-3/Makefile
deleted file mode 100644 (file)
index 7ac0c86..0000000
--- 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 (file)
index 31a7bf8..0000000
--- 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 (file)
index e69de29..0000000

diff --git a/testsuite/interactive/lib-graph/Makefile b/testsuite/interactive/lib-graph/Makefile
deleted file mode 100644 (file)
index 64557c7..0000000
--- 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 (file)
index 1525667..0000000
--- 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 (file)
index e69de29..0000000

diff --git a/testsuite/tests/arch-power/exn_raise.ml b/testsuite/tests/arch-power/exn_raise.ml
new file mode 100644 (file)
index 0000000..a68eb87
--- /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 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/arch-power/ocamltests b/testsuite/tests/arch-power/ocamltests
new file mode 100644 (file)
index 0000000..03fa29c
--- /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 (file)
index 0000000..1510fce
--- /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 e0edd3ae76bfbae594720290c7bda7f440f64e0b..06e3fe0a5a4973cd8a91ab011ae015a09ff3f31f 100644 (file)
--- 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 36465dc0f530d84eaadf84fd5b596b5359895c4b..296d4328a6abeb1326cfbe29e74368338b222f17 100644 (file)
--- 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 c0b9816b7dbb32d02c7b8af95ddadfd086e9e10f..2c246e2db2c42dc9884d6d0ac0e3d4df9ec88475 100644 (file)
--- 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 (file)
index 0000000..3d1f12a
--- /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 045a24cce82594afdc70a1ea4635bee0c65b644e..c2fc78d580a7e2f245e33ef126f086031aff26ab 100644 (file)
--- 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 5d7664c965c1aac99f208967a1cd0c326d2c7be7..3fee64cd845ede6bb5e39ce1394350103aa391ad 100644 (file)
--- 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 222649bcfc9cd214bb07c0e5b43983a34f84f51d..3d4c6e6fdc677db800b050c50534b93a72144390 100644 (file)
--- 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 dae92a6eb09152d88930d1a397ffdde0339303d8..bd6d4ff3445b7b7360d945365ef0c966eb3fd3c4 100644 (file)
--- 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 (file)
index 0000000..bb0df2d
--- /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 316f49c905bc75375b46880392824f7e99ef5203..1eb63ef14a9764f14b77c44c013dfcda4c1be567 100644 (file)
--- 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 f8857caa8d0e477a0784479ab20bf4f320d3e76c..9404040d6db2c42b767a47a5039b1d1a5c69a077 100644 (file)
--- 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 e9a83ff6d74053c9360ccb6af759ae1e1095b3b7..998daee62c36de9028ffcce3e3f55c6368793d19 100644 (file)
--- 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 333a214da784399715ef34390944401a1ea7755a..06fa789b693279cd4885b75d9750aa139e9a8d7c 100644 (file)
--- 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 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/basic/localfunction.ml b/testsuite/tests/basic/localfunction.ml
old mode 100755 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/basic/localfunction.reference b/testsuite/tests/basic/localfunction.reference
old mode 100755 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/basic/opt_variants.ml b/testsuite/tests/basic/opt_variants.ml
old mode 100755 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/basic/patmatch_incoherence.ml b/testsuite/tests/basic/patmatch_incoherence.ml
index 10d38dbb1fa862828e1874d0274a43f2e0b217af..c54fd918a13f132c6d49ffd9ffc3049c05f0f97a 100644 (file)
--- 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 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/basic/switch_opts.ml b/testsuite/tests/basic/switch_opts.ml
index a32772e5592a3762bc5dce9bd866118cc5817343..b4e563feceedd6a117e09ce8b7e81e3f851f4995 100644 (file)
--- 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 48a004599f27ba122402a039a4188a7cd05df0b5..cb07836cf5ed246994a98c763078b61201649081 100644 (file)
--- 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 a83ad61e97d7214de5a64802aeb2681fa4a05efe..825990020a9c27a510d6f21305008e581b6071ac 100644 (file)
--- 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 c8c07273305cc3faede145f1590c5c2a7416c65e..4ca01612abef1a2b27762a9370ec2a7113a68352 100644 (file)
--- 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 df438bc41372c35cd2da4e9ef6e71f16275d9ae2..43d93e3f73db36d94adf3b8535dcb21019c7aefb 100644 (file)
--- 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 28ad2267a299a684d021ce92c6a7250b42af7814..0eb777b0a5b25038f16e519403e6fc74335e739b 100644 (file)
--- 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 (file)
index 0000000..d7ca317
--- /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 f8c8d7e9edf6e3258d97d05a9b7179974a8fcdf0..a6747abd0206cfdd26e82f2f3197e6559cd1f529 100644 (file)
--- 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 897bd0521126d22048131d4533c0545078d23231..ec6f2cff28209bda8fe8008a181f271df9f6f460 100644 (file)
--- 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 3837d57abf355fb3ebde792266e921cbd17d3149..b8d6673ea1edc5420a3738bd8ff69f18fccc15ed 100644 (file)
--- 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 fea13c484104e04d0cc7c5a2715cd27626b4b454..ffdb56d177db07214f23da2ac9c2255ec2b7afd1 100644 (file)
--- 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 e581a0acf6c2629c643510bc4d8c35419a9ec314..93171ae1dc860b5ab8ce3d3172e34715183be180 100644 (file)
--- 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 883c49d9614dbba83c623a14e9b30a5cccbc8595..6507d9a59350c095056f12fa4c5b2b34315d4394 100644 (file)
--- 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 3303026b252317cfda775f0e8e5f54f6335ff47d..71544e4adc1e08e936bc3e166c8695e4f7cd172e 100644 (file)
--- 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 782847225722c99e1a810309abce21b43f150793..7c04199ec98635a105af65e59948aa1aa63ce6b8 100644 (file)
--- 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 6fb1f819df7cfc97adfc01eadf97362aef36eb13..5ac062fb57e3d2bba8032e4c7b0576bbea6354df 100644 (file)
--- 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 (file)
index 0000000..7e9ab0e
--- /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 (file)
index 0000000..8e0fba1
--- /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 94409452c5a6c6246063590a3744a87d15d127b5..6ae29205adc84460ac273f0213cb7dfacc1186e2 100644 (file)
--- 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 a28d5486a8a88fc49c7d7728c47890680d8e2533..a359cd1bccaa226f0d333dd97fb0fabe4e70a448 100644 (file)
--- 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 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/lib-filename/extension.ml b/testsuite/tests/lib-filename/extension.ml
old mode 100755 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/lib-filename/suffix.ml b/testsuite/tests/lib-filename/suffix.ml
old mode 100755 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/lib-int/test.ml b/testsuite/tests/lib-int/test.ml
index 322ae97ce1fcf109282595e8c60a3d9d6be9140f..592dbb33f5eecc56568ba2de109c057110b81476 100644 (file)
--- 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 55f0b5b309922ddc287805359da0776f050db94a..bdddfe9e7fef31ab34c7903da868b538e6c7dfd8 100644 (file)
--- 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 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/lib-obj/with_tag.ml b/testsuite/tests/lib-obj/with_tag.ml
new file mode 100644 (file)
index 0000000..a4b69ea
--- /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 (file)
index 0000000..9766475
--- /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 8036dfb7a352e4e84e1f48e832644620f8f4dda8..54799e12d29820ab1c08f032e13c0dd4bb6bb5c1 100644 (file)
--- 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 af593cd4fdc9c7c62848831da975405680af2916..a1b6b815431e43a47ef19340b6984742618550c0 100644 (file)
--- 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 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/lib-stream/mpr7769.reference b/testsuite/tests/lib-stream/mpr7769.reference
old mode 100755 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/lib-systhreads/ocamltests b/testsuite/tests/lib-systhreads/ocamltests
index 4723c9f10cecc236fde1f870a7d68ccd31174b04..ccae4b47745c2ac26d05bf7ff92d8a5860ed224b 100644 (file)
--- 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 (file)
index 0000000..30e70ce
--- /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 (file)
index 0000000..03f63a1
--- /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 (file)
index 0000000..32476d3
--- /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 (file)
index 0000000..1611435
--- /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 1df74eb523cffbc0de571d72378972ff12a33338..54350865a150714cdd7809883a719e22550ad384 100644 (file)
--- 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 e09fee1b244a8100607c2062a7ff4ca580869587..0cda04a7192a36329b9f78ff8673a30a5c05c85c 100644 (file)
--- 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 fb4cacb90a7bd1f6408a540f1ee05329eb6e6346..5d6e73e53d19591627dd45d18fcebaf02f11c857 100644 (file)
--- 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 d86bac9de59abcc26bc7956c1e842237c7581859..e61ef7b965e17c62ca23b6ff5f0aaf09586e10e9 100644 (file)
--- 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 (executable)
index 0000000..80815e8
--- /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" <<EOF
+-stdout
+-stderr
+EOF
+
+  exit ${TEST_PASS}
+else
+  echo "$uname" > "$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 (file)
index 0000000..34b36e4
--- /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 (file)
index 0000000..f18e084
--- /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 (file)
index 0000000..73fa3fb
--- /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 (file)
index 0000000..df4d7cb
--- /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 (file)
index 0000000..dc66b16
--- /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 (file)
index 0000000..26bbaa4
--- /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 8b6bb3fd1c1c110af21166cdd9599f58b7c2f776..4a16ada8ec0e1eaa6b7df999e1ee8cb8bd3b1cfd 100644 (file)
--- 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 1f76de0cdacbcb57e2013c15c82614e90c553dfb..f336181a7171754e272f375ccb19c06b948d42e7 100644 (file)
--- 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 a183f448215c1de71141115058dab791c1cd5901..93a0d263ac4f17ca06072d8ba60c42f6cd6d66a8 100644 (file)
--- 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 a42f072177b9973b8fc5e92545cf1aed818b736e..76c80d64c974bf97288d35db4cb9493664cfa19a 100644 (file)
--- 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 c6f393f80e9a3b4e8e902744e273d904ace14344..b3486e40ed4c4d1fb648f7627663d345fc846dba 100644 (file)
--- 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
 </ppx-context>
-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.
 <ppx-context>
 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 3a9719e9ac9757a386e0a5c951ec716a926b7d76..e61840c433ebc91969f07d79adb943997239fa79 100644 (file)
--- 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 (file)
index 0000000..24c431a
--- /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 3a974ca84cae478d61f2ef74a730ec51ed301fce..a97308a9a0b0fb84aac57c97b8913c79d1d4686a 100644 (file)
--- 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 5bd6b61f4b626292819916f233155f859ff3b066..4be67c87041ba0ae330a1931029026f6a850b1f1 100644 (file)
--- 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 (file)
index 0000000..3289f51
--- /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 (file)
index 0000000..2d06dde
--- /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 (file)
index 0000000..b1279f6
--- /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 (file)
index 0000000..4f8025c
--- /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 (file)
index 0000000..6ad8f61
--- /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 (file)
index 0000000..31973b4
--- /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 (file)
index 0000000..c7458e1
--- /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 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/tool-ocamldep-shadowing/dir2/b.mli b/testsuite/tests/tool-ocamldep-shadowing/dir2/b.mli
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/tool-ocamldep-shadowing/dir2/c.mli b/testsuite/tests/tool-ocamldep-shadowing/dir2/c.mli
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/tool-ocamldep-shadowing/ocamltests b/testsuite/tests/tool-ocamldep-shadowing/ocamltests
new file mode 100644 (file)
index 0000000..c2790ea
--- /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 (file)
index 0000000..d4b8448
--- /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 (file)
index 0000000..186b46a
--- /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 1229e5db06ba2e14713eb67f9fc797091b7ffef7..8beae14f13603b14dcad4686acfc3fbab67cb0c7 100644 (file)
--- 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 d1e221ec7145a229054e4c33c02f96668f845f9f..c0edb9c5d8e1713eb0e366c20181e2a0abc26894 100644 (file)
--- 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 28d1ff56227349b1888e4417b468b07b031b72af..b8c2470be7a27917b19cf99f5a98030b4039b7f5 100644 (file)
--- 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 (file)
index 0000000..3544e1d
--- /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 (file)
index 0000000..bc4b528
--- /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 089ea7176b7bfdd2d177b91b862fc9bff56b2c73..02cb7e3ecbb2722ad97c65de77d9f5b305d660c8 100644 (file)
--- 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 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/typing-deprecated/alerts.ml b/testsuite/tests/typing-deprecated/alerts.ml
old mode 100755 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/typing-extensions/extensions.ml b/testsuite/tests/typing-extensions/extensions.ml
index f4867449996540bbea4bc00b9616758244c5eeb5..bdd0ff3b4fe85d1d5b4294a11fef29cd35ba5e66 100644 (file)
--- 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 = <fun>
+|}]
 
 (* 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 = <fun>
+|}]
 
 (* 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 = <fun>
+|}]
 
-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 = (<extension>, 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 = <fun>
+|}]
+
 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 = <fun>
+|}]
 
 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 = <fun>
+|}]
 
 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 (file)
index 53e3060..0000000
--- 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 = <fun>
-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 = <fun>
-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 = <fun>
-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 = (<extension>, 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 = <fun>
-val extension_id : 'a -> int = <fun>
-val n1 : string = "Foo"
-val n2 : string = "Bar"
-val t : bool = true
-val f : bool = false
-val is_foo : 'a -> bool = <fun>
-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 d1129878c4db893e5df912d708860f7e8391be39..dd5ed13854c62f7f0ed90b9834975337795ad97c 100644 (file)
--- 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 = <fun>
+|}]
 
 (* 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 = <fun>
+|}]
 
 
 (* 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 = <fun>
+|}]

diff --git a/testsuite/tests/typing-extensions/open_types.ocaml.reference b/testsuite/tests/typing-extensions/open_types.ocaml.reference
deleted file mode 100644 (file)
index 2dddce7..0000000
--- 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 = <fun>
-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 = <fun>
-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 = <fun>
-

diff --git a/testsuite/tests/typing-gadts/ambiguity.ml b/testsuite/tests/typing-gadts/ambiguity.ml
index ab6c97acfa2a6574e8bfbdf9ff3fa912971b2701..b576b2bfdf72689042a0ce30100c6eb9f4e17043 100644 (file)
--- 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 717fb945bb62dc935d61bfa7ae796fb09c45b02d..7c13cb4f6919cc27ee0d00259cb94febef402e91 100644 (file)
--- 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 = <fun>
+val fbool : 't -> 't ty -> 't = <fun>
 |}];;
 (* val fbool : 'a -> 'a ty -> 'a = <fun> *)
 (** 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 = <fun>
+val fint : 't -> 't ty -> bool = <fun>
 |}];;
 (* val fint : 'a -> 'a ty -> bool = <fun> *)
 (** 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 = <fun>
+val f : 't -> 't ty -> bool = <fun>
 |}, 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 = <fun>
+val g : 't -> 't ty -> bool = <fun>
 |}];;
 
 let id x = x;;
@@ -102,7 +102,7 @@ val id : 'a -> 'a = <fun>
 val idb1 : bool -> bool = <fun>
 val idb2 : bool -> bool = <fun>
 val idb3 : bool -> bool = <fun>
-val g : 'a -> 'a ty -> bool = <fun>
+val g : 't -> 't ty -> bool = <fun>
 |}];;
 
 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 = <fun>
+val g : 't -> 't ty -> bool = <fun>
 |}];;

diff --git a/testsuite/tests/typing-gadts/or_patterns.ml b/testsuite/tests/typing-gadts/or_patterns.ml
index c7e0b18d87ce2de451b2bbd4ed1960efc8a1eb78..1cc64034868c456827ff7624eded19dd71c3f5da 100644 (file)
--- 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 96eed8fd5a41d9c52756a400fe6f409aa0b0dbbb..00420834374e1c0ff1faa29d39126c941db59326 100644 (file)
--- 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 ad62ef09f83af5d3732562d30a9780cd5ab9386e..c722ec27c25423a0acabaacde2c1d0942bd893dc 100644 (file)
--- 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 ba8c7e42e53662c4e450316593671a883796b45e..9431a1ca1bd56b6bbfaf7a1f89533f4cdc7f36d0 100644 (file)
--- 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 72bbd2782a23eeab5b703c7c84e9c819cf16694f..c8a9c6f25ad2653a1b35589f762ef9109a0756e7 100644 (file)
--- 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 2c4fdc31fd6bea15dcb009bb030ff868d8571069..def3e533f5ffb37d750627f4cc0db9bae94b98ab 100644 (file)
--- 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 aec74eb0b5b71d3bc62f9c8830cdee7b94a2d2a2..3a7781446f7fe5a36b37b0e946935de0cf226900 100644 (file)
--- 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 d50e3707cd07abc978da5cfa3805154b4d4fde6f..858547ea9d9220fdcac658a0f812bdcd235a6dce 100644 (file)
--- 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 = <fun>
+val vexpr : (unit, 'result, 'visit_action) context -> unit -> 'visit_action =
+  <fun>
 |}];;

diff --git a/testsuite/tests/typing-gadts/pr7160.ml b/testsuite/tests/typing-gadts/pr7160.ml
index f7b94431a013f4aa8e2b36ac84a1dc383c47814a..8af9de8cc8a6896cf1fa9faae137235be4133292 100644 (file)
--- 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 = <fun>
-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 c6f160f4dadda6057762859d3fe2f220cf9981c1..87e7d30e1e643b1fdff5498bd7a21d206c63cc0d 100644 (file)
--- 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 d7767033fcf98e0b9c9f99cc9bb3f65013982ed5..956094d74610f62bd089e6e2fc8b296fba1adaf1 100644 (file)
--- 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 61061872d862ce3e64ba13a6be7ad57c63ee6f7b..be41c36750629925907be1d6dc9a5a273a6a1fcb 100644 (file)
--- 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 -> (<m : a; ..> as 'c) -> (<m : b; ..> 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 -> (<m : a; ..> as 'c) -> (<m : b; ..> 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:<foo:int;bar:int;..>)
 ;;
 [%%expect{|
-val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = <fun>
+val g : 't -> 't int_foo -> 't int_bar -> 't = <fun>
 |}];;
 
 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 = <fun>
+val g : 't -> 't int_foo -> 't int_bar -> 't * int * int = <fun>
 |}];;
 
 (* PR#5554 *)

diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml b/testsuite/tests/typing-gadts/yallop_bugs.ml
index 443a65267b808650daca8d55d9ac61edf5309a1e..d94e63fde904d6f38d291c896d211798b98f5faa 100644 (file)
--- 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 285d112854f14962646a0828a25d15aea6fcff6b..c55c93743f5312e8589d1c0428dc1a9bab8448e2 100644 (file)
--- 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 94f9fff824817307b47de9fb08f1f4d4bf526879..da8efa70b58eae75e0d3a7be9d7970a444034632 100644 (file)
--- 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 = <fun>
-val make_set : ('a -> 'a -> int) -> (module Set.S with type elt = 'a) = <fun>
-val sort_cmp : ('a -> 'a -> int) -> 'a list -> 'a list = <fun>
+val sort : (module Set.S with type elt = 's) -> 's list -> 's list = <fun>
+val make_set : ('s -> 's -> int) -> (module Set.S with type elt = 's) = <fun>
+val sort_cmp : ('s -> 's -> int) -> 's list -> 's list = <fun>
 module type S = sig type t val x : t end
 val f : (module S with type t = int) -> int = <fun>
 Line 1, characters 6-37:
@@ -71,7 +71,7 @@ module rec Typ :
   end
 val int : int Typ.typ = Typ.Int <abstr>
 val str : string Typ.typ = Typ.String <abstr>
-val pair : 'a Typ.typ -> 'b Typ.typ -> ('a * 'b) Typ.typ = <fun>
+val pair : 's1 Typ.typ -> 's2 Typ.typ -> ('s1 * 's2) Typ.typ = <fun>
 val to_string : 'a Typ.typ -> 'a -> string = <fun>
 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 = <fun>
+val add : ('k, 'd, 'm) map -> 'k -> 'd -> 'm -> 'm = <fun>
 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 ed49ecbf76bb35d96f3273df82f5fdc21851bf44..d1b61f0333e611b3b21d603294f2713519db9165 100644 (file)
--- 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 (file)
index 0000000..eabd3cc
--- /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 = <fun>
+|}]
+
+let g (type t') (x : t') = x
+
+let g' (x : ' t') = x
+
+[%%expect {|
+val g : ' t' -> ' t' = <fun>
+val g' : ' t' -> ' t' = <fun>
+|}]
+
+let h (type a'bc) (x : a'bc) = x
+
+let h' (x : ' a'bc) = x
+
+[%%expect {|
+val h : ' a'bc -> ' a'bc = <fun>
+val h' : ' a'bc -> ' a'bc = <fun>
+|}]
+
+let i (type fst snd) (x : fst) (y : snd) = (x, y)
+
+[%%expect {|
+val i : 'fst -> 'snd -> 'fst * 'snd = <fun>
+|}]
+
+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') =
+  <fun>
+|}]
+
+(* Variable names starting with _ are reserved for the compiler. *)
+let k (type _weak1) (x : _weak1) = x
+
+[%%expect {|
+val k : 'a -> 'a = <fun>
+|}]
+
+let l (type _') (x : _') = x
+
+[%%expect {|
+val l : 'a -> 'a = <fun>
+|}]

diff --git a/testsuite/tests/typing-misc/is_expansive.ml b/testsuite/tests/typing-misc/is_expansive.ml
new file mode 100644 (file)
index 0000000..3bab4f9
--- /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 = <fun>
+|}];;
+
+match [] with x -> (fun x -> x) | _ -> .;;
+[%%expect{|
+- : 'a -> 'a = <fun>
+|}];;

diff --git a/testsuite/tests/typing-misc/ocamltests b/testsuite/tests/typing-misc/ocamltests
index 1053da91c8fdfaeb9e43b1edfe2e503909dce246..6d4e684a1b33053e6ae76b43eeb543b3698ce74f 100644 (file)
--- 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 e6c88dd6f8f264a4964e08de704684c3ab106479..4ef27cb0a76eb772bc6b6b3d780df7ae2a1e7985 100644 (file)
--- 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 = <fun>
 |}]
+
+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 a3fa4eeb01fd798bc8b5124e27aff3b370eaeca2..4fb01c6401a79ae88f4ff9e985e6377562edd57d 100644 (file)
--- 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 2faf7c989a51b04d3bfcd9686e10150961b3fc11..3e1daa8218e7313084b21727f96b4ff0adb8ed9c 100644 (file)
--- 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 5dccf5ac9685f32aef0503c61f0273acf7435c60..95b64fb5042541ef453f8deb5358c91eec52fc10 100644 (file)
--- 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 =
   <fun>
-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 (file)
index 0000000..c4e42c7
--- /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 1d26860ba7c2257d1306ee523c3b966a565e2580..79f4c0af67acc052f09aad1b6f0a63cb759dc34c 100644 (file)
--- 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 0c2d2650796d7f1dce4df4b6aa87a1a4c1188b82..ff7efe727aac665a86bc1c59891735bd8e9dd2d7 100644 (file)
--- 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 b1dfd1c0451511057ca280d52b9320ca13b17aa4..40a4aac47c01cee6334e61993140dcd48ea0c4e3 100644 (file)
--- 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 (file)
index 0000000..9b2bee4
--- /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 (file)
index 0000000..b38a63f
--- /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 (file)
index 0000000..534a5fa
--- /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 (file)
index 0000000..c75821b
--- /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 ad10f664ec3e21e260e6c6f96165f26d2fcb2b65..684351eaac215b9a870215156c7b792d973d7a2f 100644 (file)
--- 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 (file)
index 0000000..12eff93
--- /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 = <here>
+       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 = <here>
+       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 = <here>
+       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 = <here>
+       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 = <here>
+       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 = <here>
+       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 = <here> 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 = <here>
+       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 = <here>
+       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 = <here>
+       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 = <here>
+       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 = <here>
+       Illegal permutation of runtime components in a module type.
+         For example, at position functor (X : <here>) -> ...,
+         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 = <here>
+       Illegal permutation of runtime components in a module type.
+         For example, at position functor (X) -> <here>,
+         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 = <here>
+       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 : <here>) : ... 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 f0b0ec57cff42f8920a4c9a148bbeb54cf8daf4d..886fcfc59317608d5be2d24a916d4ffa7c55fe4e 100644 (file)
--- 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 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/typing-modules/ocamltests b/testsuite/tests/typing-modules/ocamltests
index 34d5fbaa37c61063a43e0e90421fce9cc81b322f..e9784a257bc465e170b0a7a097b2d77dc92bf217 100644 (file)
--- 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 3fa0473555cb413fc0f27e79f25f6cb4cc94601a..97bbeebf1ecddde13053816cb8d79e86ae99dc2e 100644 (file)
--- 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 eec5440b7c83421504f72f190f74f5f02293e56b..75ba000f1f92255b53f2694f9244a506e4855d0b 100644 (file)
--- 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 (file)
index 0000000..57bfa17
--- /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 dc5c531293c26289e76d8cb00d9d07cd1fce309e..a5685448b5c3a59a077fb869e7e0f8e48136c65b 100644 (file)
--- 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 4d8f62d928d649a0b57705a5c378306ed1924b94..00cbde533d3fb5b4b4f85a714825a53974bdbc2d 100644 (file)
--- 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 6d0d832a9120f29bfaf61545743b3b3cc246c03b..b045c058700fa71de4014e3952e980a8ce34c2b0 100644 (file)
--- 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 842c3bf7225054dc55cbf043b4f95f09b2a6810c..3256e48a8bf716d7fb31c0672ab9f2cda797be83 100644 (file)
--- 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 8cfa9066b3e1d8a3c7da0ad69e6d150317aad932..bfbf6dd861bb951b4826a2a7a7b48bb317ff4e8d 100644 (file)
--- 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 358391a3a1ef21af9eb30c13268e7d0c5f440e4a..def5d7486739c58b7fe0a9661d74e34121ae224c 100644 (file)
--- 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 08c8719928c739d761ae4a95f0f36f7991e5b34e..46811961d74f621d40514d4b9cfb4bef1db128c1 100644 (file)
--- 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 0f22bccc6285d885bf6ab2e235c5fd8f1cba2080..989c6cebea76b36facef0f851af7d0a5004ae2c7 100644 (file)
--- 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 = <fun>
-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 c8f050c16494c7ad20c43162144db6850e8453a6..36002adc5c8a5acf294193edbc17237c3f48f38c 100644 (file)
--- 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 = <fun>
 |}];;
 
-(* 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 : <m:'a. [< `A of < > ] as 'a> :> <m:'a. [< `A of <p:int> ] as 'a>);;
 [%%expect {|
-Line 2, characters 2-88:
+Lines 2-3, characters 2-47:
 2 | ..(x : <m:'a. (<p:int;..> as 'a) -> int>
 3 |     :> <m:'b. (<p:int;q:int;..> 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 = <fun>
+|}]
+
+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 59ffd96f6f1277e175e43c4128009456dcb203e4..a4484494f1892d3e5f9a9418cb42b9b60fde2cc3 100644 (file)
--- 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 b83fdc6df82816079eb53667ffc78ca0bd5ca2c8..6b531a1ba4bab1fa49238b40fc4aeb4b2a248de8 100644 (file)
--- 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 46124ba43adb2b9d0934c4afacc673924ecee18b..4f9cd7e5d84a4eb8dc184e382731427eb33188d2 100644 (file)
--- 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 8bae4467f34e7a8009ab98751c492915b33cb0b4..0427ad2576e7ce0936abb41ad4ea0585125af08d 100644 (file)
--- 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 140acb494f1bf386caa8594858cdc14aaed6347c..1e333a05f6f486610435ca4555ecd878b2ab4bb6 100644 (file)
--- 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 5b1a60392268ecfbe937ea62ccd83030abaeedf7..911fb8a56a42c58cd230c39cd1c2596813aaafaa 100644 (file)
--- 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) = <fun>
+val property : unit -> ('t -> exn) * (exn -> 't option) = <fun>
 false
 true
 true
 false
-val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list = <fun>
+val sort_uniq : ('s -> 's -> int) -> 's list -> 's list = <fun>
 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 8ee1588cf45a93ef47095de952d22a63ceaecfac..ce79acd490b11036a03671b5393ecc665b4ea43f 100644 (file)
--- 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 4dff4e4659dc51a65e6b42dbf0edd6377bfd0b13..3ac3e27a6e2abd1a101ac3d705e5c9b748f67481 100644 (file)
--- 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 3a8d5a0159682abc51e93272840949fcdf83afa9..66c6f389388ea46af0037b6298d316facaf3c9b7 100644 (file)
--- 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 35b10046ad7eb8a8b289e10a25d11169a2d225b0..e2eaeb11b805ee206f9fa897cb0bb6cee4580ded 100644 (file)
--- 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 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/typing-warnings/pr6587.ml b/testsuite/tests/typing-warnings/pr6587.ml
index ed7ade443459aa4965317de0ba9d3ceb5886e1e2..665f6ed7e3a21e8e8373ae83f0245da0d97ed626 100644 (file)
--- 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 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/warnings/deprecated_module.mli b/testsuite/tests/warnings/deprecated_module.mli
old mode 100755 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/warnings/deprecated_module_assigment.ml b/testsuite/tests/warnings/deprecated_module_assigment.ml
old mode 100755 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/warnings/deprecated_module_use.ml b/testsuite/tests/warnings/deprecated_module_use.ml
old mode 100755 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/warnings/w04.compilers.reference b/testsuite/tests/warnings/w04.compilers.reference
index 3f091a392606cbae8f0a11fc9898eb429616b906..bb39fb4d9ea387ace8e416c89a742bbbaa1cef91 100644 (file)
--- 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 e833d2bbb88245eb2c3682d5cda05587cffa74d4..d0fac4daf4180d511e871517b028b89dbda0e837 100644 (file)
--- 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 e1d5fdbd7780c3247c07f95e83a80fa726f19daa..6b4abe2bc80e22ef778963e3056d744a5d7a34e6 100644 (file)
--- 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 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/warnings/w50.ml b/testsuite/tests/warnings/w50.ml
old mode 100755 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/warnings/w60.ml b/testsuite/tests/warnings/w60.ml
old mode 100755 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/warnings/w60.mli b/testsuite/tests/warnings/w60.mli
old mode 100755 (executable)
new mode 100644 (file)

diff --git a/testsuite/tests/win-unicode/mltest.compilers.reference b/testsuite/tests/win-unicode/mltest.compilers.reference
old mode 100755 (executable)
new mode 100644 (file)

diff --git a/testsuite/tools/Makefile b/testsuite/tools/Makefile
index 9027bf619559a2116cd29259149498b75bee176e..6e6370d75fa7aeaaf0e347eb6041a6d023c4abd5 100644 (file)
--- 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 73941acc2c6f50919be3861e72b17f21bb041316..8481388914504a3dbc4b32c5b40ab49ab327a567 100644 (file)
--- 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 673ded99770d6e6a8a1faceca067de27c11bc06f..d85cb59a94944c1f843f68a67b3ae77f40511c13 100644 (file)
--- 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 c96026b9e25d5e476a0135f01a5507a1830849a5..0a471a1b46d4c2c7af92c0a3cf7a0fbcc3792d29 100644 (file)
--- 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 ee0e0be4c9ae80adb26f78a60764c7a7da01758f..afefc4d83c174ffa5964a0a564ea765ded5885fe 100644 (file)
--- 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 108a0f6665817a95ce33257794d55e783ddb6ea0..d003171d23fc58be047b4305833b6d6e0a536a78 100644 (file)
--- 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 caeb4bc24a23edcada35dc9096830256c3de9d02..6da3c3e6b7d3c0ec9a6a1e810aff73be138d31c4 100755 (executable)
--- 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 a77c1ed1a43e3578fbb5af556582268c918a08de..a33b6b3a7fcb8618ee2993bcb52f63f2204a847f 100755 (executable)
--- 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 c6a211573cab8fccfe75317c2699899b1c7596ff..db9dfe83b9fae079cb493a3e589eba593d5b5847 100644 (file)
--- 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 da7259c26c9e7e900131b8999e0618c7e9b15415..d0d9098f87a4b45697b9cad1d9d8fc8a9ed50564 100755 (executable)
--- 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 (file)
index 0000000..f075e82
--- /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 adb54538421c0467b9254ae25c7708d39b0ae0b0..40826f4895db0c76f0504a74a691650a0b3481e6 100644 (file)
--- 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 3c2edfcc7c83da6902a90159b661628f047c7a5e..c72a21274aec438bdf64d578f8b612dc43df74be 100644 (file)
--- 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 <options> <files>\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 b5c0aee539394126a866906b4c7f1596868be7b3..d5bb84cac821009b9a98e2285c73500ed958109b 100644 (file)
--- 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 <file>   Read additional newline-terminated command line arguments\

diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml
index 480480d737b7e410385b31137f2293e777bb6fb2..888dbf5b58f511aa69b206478983fdc0dc78bddd 100644 (file)
--- 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 <options> <files>\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 4a846f1acd06689e2dede19b4de81b2b14eec1c7..dcb6f90f816551f55ff789acdb0dfc31928e6aa2 100755 (executable)
--- 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 1e221339f19028eaa70fbfc181220a2567aee1aa..0e3cfbc267446144e301ff4f0d4aa69f9ca72200 100644 (file)
--- 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 0dd02095dbd37ee644607db62d2f918ad24dc23d..2a9911bd6ec3dbf5eb30063fe4ea7439d237333f 100644 (file)
--- 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 <<EOF
+
+export WORKTREE=~/o/4.08
+  # must be the git worktree for the branch you are releasing
+
 export MAJOR=4
 export MINOR=08
 export BUGFIX=0
-export PLUSEXT=+beta1
+export PLUSEXT=+beta3
 
 export BRANCH=\$MAJOR.\$MINOR
 export VERSION=\$MAJOR.\$MINOR.\$BUGFIX\$PLUSEXT
@@ -39,7 +43,7 @@ export ARCHIVE_PATH="$OCAML_RELEASE_ARCHIVE_PATH"
 export WEB_HOST="$OCAML_RELEASE_WEB_HOST"
 export WEB_PATH="$OCAML_RELEASE_WEB_PATH"
 
-export DIST=$ARCHIVE_PATH/ocaml/ocaml-$MAJOR.$MINOR
+export DIST="\$ARCHIVE_PATH/ocaml/ocaml-\$MAJOR.\$MINOR"
 EOF
 source /tmp/env-$USER.sh
 echo $VERSION
@@ -49,6 +53,7 @@ echo $VERSION
 ## 1: check repository state
 
 ```
+cd $WORKTREE
 git status  # check that the local repo is in a clean state
 git pull
 ```
@@ -181,12 +186,11 @@ git commit -m "OPAM switches for $VERSION"
 ## 7: build the release archives
 
 ```
-cd .../ocaml
+cd $WORKTREE
 TMPDIR=/tmp/ocaml-release
 git checkout $VERSION
 git checkout-index -a -f --prefix=$TMPDIR/ocaml-$VERSION/
 cd $TMPDIR
-(cd ocaml-$VERSION && rm -rf experimental)
 gtar -c --owner 0 --group 0 -f ocaml-$VERSION.tar ocaml-$VERSION
 gzip -9 <ocaml-$VERSION.tar >ocaml-$VERSION.tar.gz
 xz <ocaml-$VERSION.tar >ocaml-$VERSION.tar.xz
@@ -195,6 +199,13 @@ xz <ocaml-$VERSION.tar >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+<VARIANT> --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 <VARIANT> 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 9a20e07a7ed713cc07f2e4feb1790691cde23a46..1c600414939a156e14ce65d0ec8ea7ac533694db 100644 (file)
--- 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 9170cb62ec6296eab0592e47d1fc2ac6865a1bac..5dfe97d0ddff6c98629a42af50df9fbfd639f72a 100644 (file)
--- 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 45918317124d986c5169bfe37507fd3cd0b79dd3..0d1f73921339f2677d728c18065978a0ff5ba895 100644 (file)
--- 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 cbc0fd56ea287fc6b585cab9a8714122eca6ec8f..0a96b5793fb09e6ad6a1aae307a4898ef8767534 100644 (file)
--- 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 <n> | <round>=<n>[,...]"
       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 c4518bcf1efb32403d33d703dd769c861e0aac7a..8469d84b658fe4ffc01b42a8469805bec70bedb5 100644 (file)
--- 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 "@[<hv 0>The files %s@ and %s@ \
                  disagree over interface %s@]@."
             user auth name;

diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index 1326d060f889a5a195eda53d66b64081043099d7..b1226b92ea38a8fd4455959b1c6069221c8a9b0b 100644 (file)
--- 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 ebe47cb8aff1f6c80689d1a8a13bb7044f5c07e4..735baebbbd1d69372d389a54493ff21eda02ca09 100644 (file)
--- 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 (executable)
new mode 100644 (file)

diff --git a/typing/cmi_format.ml b/typing/cmi_format.ml
deleted file mode 100644 (file)
index 2c85a9b..0000000
--- 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 (file)
index b42dc9c..0000000
--- 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 (file)
index 09c787d..0000000
--- 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 (file)
index 617bc1e..0000000
--- 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> := \{<cmi>\} <cmt magic> \{cmt infos\} \{<source info>\}
-    where <cmi> is the cmi file format:
-      <cmi> := <cmi magic> <cmi info>.
-    More precisely, the optional <cmi> 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 fb8f4c10516cf2ba9b40f473dc6caf6638a7db43..a6189ad46a2925b3d046abf648ea709661e637c0 100644 (file)
--- 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 15e70c991e39a57835b810844bec3ab1bd3ff9cb..450a5ec22917ef1715c6fdc5c5dea6abf91d8a7d 100644 (file)
--- 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 3a544a3f930f42a65128a99b741353663a9aa4cf..c807269d2a948b76b44e38227f42a303a2cbea67 100644 (file)
--- 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
-      "@[<hov>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
-        "@[<hov>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
-        "@[<hov>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 "@[@[<hov>";
       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 9fd1e8fd4062646355094ede1518d233223b718a..cf7490db839b70d00bb667c7fa0658621f36b2b1 100644 (file)
--- 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 98e99b8c4751706fca99c35617e9af068b0f9451..b5311b118ed936576196a268a45051cb4a68cafc 100644 (file)
--- 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 670dd947a54bc343efd803eaf73bf6f98754435b..01790075c1c63abd1548bbaff961bbc310cf0360 100644 (file)
--- 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
+        "@[<hv 2>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 "<here>"
+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 "@[<hv 2>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 "@[<hv 2>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 "<here>"
-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 "@[<hv 2>At position@ %a@]@ " context cxt
-
 let include_err ppf (cxt, env, err) =
   Printtyp.wrap_printing_env ~error:true env (fun () ->
-    fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) include_err err)
+    fprintf ppf "@[<v>%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 1996894e968c283453833a5b62ca80d19ccd56f6..f7ce4de7c79470cc6df972e6574b0cda10763cbc 100644 (file)
--- 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 ed6a4dbf7b0d983f259761751b5016cf6a2740ed..0db53346b2f63f6581cb93dd2231930f21ac87a2 100644 (file)
--- 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 ccf0dd35e2189a9a670950b409339547aa7861ac..74873f7b3f46b9d66411eec0d3dccdd398195075 100644 (file)
--- 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 (file)
index 0000000..29807e0
--- /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
+      "@[<hov>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
+        "@[<hov>Invalid import of %s, which uses recursive types.@ %s@]"
+        import "The compilation flag -rectypes is required"
+  | Depend_on_unsafe_string_unit(import) ->
+      fprintf ppf
+        "@[<hov>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 (file)
index 0000000..765a7b0
--- /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 dfc67a57bf62b06b18919e0bba3fd181ca0aa930..5df2e811f4d0e8e233221b35d5df48cdfe196d15 100644 (file)
--- 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 bddea430abbdfe0380276c7e15accac54e71103b..6a6ac7a9c8dd9138e20a4db7deaac55d22b2cdfd 100644 (file)
--- 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 (file)
index 0000000..042e9cd
--- /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 (file)
index 0000000..dc6f56f
--- /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 e87169aeac457753f7463e0866b9c0bdb48ade8e..64d99ee1e9f9914d32d022732069a81fa0eeb39c 100644 (file)
--- 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 = <fun>
-     ]}
-     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 = <fun>
-     ]}
-  *)
+     ]} *)
   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 "@[<v>@[<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
+            "@[<v>@[<2>This function has type@ %a@]\
+             @ @[It is applied to too many arguments;@ %s@]@]"
+            type_expr typ "maybe you forgot a `;'.";
       | _ ->
-          fprintf ppf "@[<v>@[<2>This expression has type@ %a@]@ %s@]"
+          Location.errorf ~loc "@[<v>@[<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
         "@[<v>@[<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 "@[<hov>Some record fields are undefined:%a@]"
+      Location.errorf ~loc "@[<hov>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
-        "@[<v>@[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
+          "@[<v>@[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 ".@.@[<hov>%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 ".@.@[<hov>%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 "@[<v>@[<2>This function should have type@ %a%t@]@,%s@]"
+      Location.errorf ~loc
+        "@[<v>@[<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 08f865f1755ed3f40d668c92721be50644c7748e..e28f75e01432613484ad069f02929accc3e38fc3 100644 (file)
--- 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 (file)
index 3c3fe34..0000000
--- 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 (file)
index 2e2d0d0..0000000
--- 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 b89f0f0d3786a39de6ac1fcfb93b738d6e9d9fed..93ed01eff39d9330c17cb1e3e340c3aa39cde2e8 100644 (file)
--- 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 ac895d39d793b3f1176a89b1f66ea94e16280c59..f74a57d8cc7c83c4c2955dbe30481bd2b16f771d 100644 (file)
--- 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 0fc8882ecea976ba78624527bf4a0b4fedb0d953..36501f0858939eacacbeed3abdd5dad85e15548b 100644 (file)
--- 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 b6cea61b42294c1baa29d98be7bd14bd380a4c0f..d726019b626a25b2fac2d6bcf46f38ebb0e65670 100644 (file)
--- 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 af2fd01fff948e093242db00af5075f2ab3a9e10..182847b5deab076f0757a2099199763e7764c162 100644 (file)
--- 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 b446d8da39a1f9d016319dcb010e747fe542459d..687529b39e2efb5f8f9df787b111e0ecbca3e365 100644 (file)
--- 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 d5cee6494e083cb79a2c3e6abf7df4565883093c..649faf380a5f010d0152a6e4611e41454567b749 100644 (file)
--- 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 c0a702804d8f28aeffb44b570b0c218590f2df15..5d85b6ca6095eb17b079596f5b1f07bd007f878d 100644 (file)
--- 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 9355f2eeb117937713b6e164dd2975326b53b250..1aaff70cc37a56dd79daa2137bd1f4f454f9d50d 100644 (file)
--- 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 cb8307829614731978748397361dafdab7c3967b..b089f61dec915831d0be090075fe415b61436443 100644 (file)
--- 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 025497a7fc141494a9b82172bc53d29e9ca2e820..a5619bde6ef29a97bb7140268630c45fe77c55ee 100644 (file)
--- 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 dbba5d1f5a3f01faac084715705dd05a46ff2c94..24fde86fe929026b231af0e1748eff27eb2e5459 100644 (file)
--- 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 af3e7e58b795c731fd34be4b741101d996977c75..5c8c542809ca18cf3325411c97caa82e83d57fd4 100644 (file)
--- 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 (file)
index 0000000..7cd6bf1
--- /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 (file)
index 0000000..689e741
--- /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 f9115fe6909bce3e130c0d81918be7f92fb18be6..2b073ce50d3ef99264ae3cae07712269647c3ec1 100644 (file)
--- 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 7005dcfbe716f8b5e6615c1f4709000e82e8d7a3..97d9fefaecd19c4f7dc355fd1ece941514d27b2d 100644 (file)
--- 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