diff --git a/.depend b/.depend index 377d89f85..20e57764f 100644 --- a/.depend +++ b/.depend @@ -1,5 +1,6 @@ +utils/arg_helper.cmi : utils/ccomp.cmi : -utils/clflags.cmi : utils/misc.cmi +utils/clflags.cmi : utils/numbers.cmi utils/misc.cmi utils/config.cmi : utils/consistbl.cmi : utils/identifiable.cmi : @@ -10,12 +11,16 @@ utils/tbl.cmi : utils/terminfo.cmi : utils/timings.cmi : utils/warnings.cmi : +utils/arg_helper.cmo : utils/misc.cmi utils/arg_helper.cmi +utils/arg_helper.cmx : utils/misc.cmx utils/arg_helper.cmi utils/ccomp.cmo : utils/misc.cmi utils/config.cmi utils/clflags.cmi \ utils/ccomp.cmi utils/ccomp.cmx : utils/misc.cmx utils/config.cmx utils/clflags.cmx \ utils/ccomp.cmi -utils/clflags.cmo : utils/misc.cmi utils/config.cmi utils/clflags.cmi -utils/clflags.cmx : utils/misc.cmx utils/config.cmx utils/clflags.cmi +utils/clflags.cmo : utils/numbers.cmi utils/misc.cmi utils/config.cmi \ + utils/arg_helper.cmi utils/clflags.cmi +utils/clflags.cmx : utils/numbers.cmx utils/misc.cmx utils/config.cmx \ + utils/arg_helper.cmx utils/clflags.cmi utils/config.cmo : utils/config.cmi utils/config.cmx : utils/config.cmi utils/consistbl.cmo : utils/consistbl.cmi @@ -36,16 +41,18 @@ utils/terminfo.cmo : utils/terminfo.cmi utils/terminfo.cmx : utils/terminfo.cmi utils/timings.cmo : utils/timings.cmi utils/timings.cmx : utils/timings.cmi -utils/warnings.cmo : utils/warnings.cmi -utils/warnings.cmx : utils/warnings.cmi +utils/warnings.cmo : utils/misc.cmi utils/warnings.cmi +utils/warnings.cmx : utils/misc.cmx utils/warnings.cmi parsing/ast_helper.cmi : parsing/parsetree.cmi parsing/longident.cmi \ parsing/location.cmi parsing/docstrings.cmi parsing/asttypes.cmi +parsing/ast_invariants.cmi : parsing/parsetree.cmi +parsing/ast_iterator.cmi : parsing/parsetree.cmi parsing/location.cmi parsing/ast_mapper.cmi : parsing/parsetree.cmi parsing/location.cmi parsing/asttypes.cmi : parsing/location.cmi parsing/attr_helper.cmi : parsing/parsetree.cmi parsing/location.cmi \ parsing/asttypes.cmi parsing/builtin_attributes.cmi : parsing/parsetree.cmi parsing/location.cmi \ - parsing/ast_mapper.cmi + parsing/ast_iterator.cmi parsing/docstrings.cmi : parsing/parsetree.cmi parsing/location.cmi parsing/lexer.cmi : parsing/parser.cmi parsing/location.cmi parsing/location.cmi : utils/warnings.cmi @@ -65,6 +72,16 @@ parsing/ast_helper.cmo : parsing/parsetree.cmi parsing/longident.cmi \ parsing/ast_helper.cmx : parsing/parsetree.cmi parsing/longident.cmx \ parsing/location.cmx parsing/docstrings.cmx parsing/asttypes.cmi \ parsing/ast_helper.cmi +parsing/ast_invariants.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \ + parsing/longident.cmi parsing/asttypes.cmi parsing/ast_iterator.cmi \ + parsing/ast_invariants.cmi +parsing/ast_invariants.cmx : parsing/syntaxerr.cmx parsing/parsetree.cmi \ + parsing/longident.cmx parsing/asttypes.cmi parsing/ast_iterator.cmx \ + parsing/ast_invariants.cmi +parsing/ast_iterator.cmo : parsing/parsetree.cmi parsing/location.cmi \ + parsing/ast_iterator.cmi +parsing/ast_iterator.cmx : parsing/parsetree.cmi parsing/location.cmx \ + parsing/ast_iterator.cmi parsing/ast_mapper.cmo : parsing/parsetree.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi utils/config.cmi \ utils/clflags.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \ @@ -78,10 +95,10 @@ parsing/attr_helper.cmo : parsing/parsetree.cmi parsing/location.cmi \ parsing/attr_helper.cmx : parsing/parsetree.cmi parsing/location.cmx \ parsing/asttypes.cmi parsing/attr_helper.cmi parsing/builtin_attributes.cmo : utils/warnings.cmi parsing/parsetree.cmi \ - parsing/location.cmi parsing/asttypes.cmi parsing/ast_mapper.cmi \ + parsing/location.cmi parsing/asttypes.cmi parsing/ast_iterator.cmi \ parsing/builtin_attributes.cmi parsing/builtin_attributes.cmx : utils/warnings.cmx parsing/parsetree.cmi \ - parsing/location.cmx parsing/asttypes.cmi parsing/ast_mapper.cmx \ + parsing/location.cmx parsing/asttypes.cmi parsing/ast_iterator.cmx \ parsing/builtin_attributes.cmi parsing/docstrings.cmo : utils/warnings.cmi parsing/parsetree.cmi \ parsing/location.cmi parsing/docstrings.cmi @@ -133,10 +150,10 @@ typing/cmt_format.cmi : typing/types.cmi typing/typedtree.cmi \ typing/ctype.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \ typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/datarepr.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi -typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/subst.cmi \ typing/path.cmi parsing/longident.cmi parsing/location.cmi \ typing/ident.cmi utils/consistbl.cmi parsing/asttypes.cmi +typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi typing/ident.cmi : utils/identifiable.cmi typing/includeclass.cmi : typing/types.cmi typing/env.cmi typing/ctype.cmi typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \ @@ -155,10 +172,10 @@ typing/path.cmi : typing/ident.cmi typing/predef.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi typing/primitive.cmi : parsing/parsetree.cmi typing/outcometree.cmi \ parsing/location.cmi -typing/printtyped.cmi : typing/typedtree.cmi typing/printtyp.cmi : typing/types.cmi typing/path.cmi \ typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi \ typing/env.cmi parsing/asttypes.cmi +typing/printtyped.cmi : typing/typedtree.cmi typing/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \ typing/annot.cmi typing/subst.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi @@ -174,11 +191,11 @@ typing/typedecl.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/includecore.cmi typing/ident.cmi typing/env.cmi \ parsing/asttypes.cmi -typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi -typing/typedtreeMap.cmi : typing/typedtree.cmi typing/typedtree.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/ident.cmi typing/env.cmi parsing/asttypes.cmi +typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi +typing/typedtreeMap.cmi : typing/typedtree.cmi typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/includemod.cmi typing/ident.cmi typing/env.cmi \ @@ -222,12 +239,6 @@ typing/datarepr.cmo : typing/types.cmi typing/path.cmi parsing/location.cmi \ typing/datarepr.cmx : typing/types.cmx typing/path.cmx parsing/location.cmx \ typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi \ typing/datarepr.cmi -typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \ - typing/path.cmi utils/misc.cmi typing/ident.cmi typing/env.cmi \ - parsing/asttypes.cmi typing/envaux.cmi -typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \ - typing/path.cmx utils/misc.cmx typing/ident.cmx typing/env.cmx \ - parsing/asttypes.cmi typing/envaux.cmi typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \ typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ @@ -240,6 +251,12 @@ typing/env.cmx : utils/warnings.cmx typing/types.cmx utils/tbl.cmx \ typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \ typing/cmi_format.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \ typing/btype.cmx parsing/asttypes.cmi typing/env.cmi +typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \ + typing/path.cmi utils/misc.cmi typing/ident.cmi typing/env.cmi \ + parsing/asttypes.cmi typing/envaux.cmi +typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \ + typing/path.cmx utils/misc.cmx typing/ident.cmx typing/env.cmx \ + parsing/asttypes.cmi typing/envaux.cmi typing/ident.cmo : utils/identifiable.cmi typing/ident.cmi typing/ident.cmx : utils/identifiable.cmx typing/ident.cmi typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \ @@ -304,12 +321,6 @@ typing/primitive.cmo : utils/warnings.cmi parsing/parsetree.cmi \ typing/primitive.cmx : utils/warnings.cmx parsing/parsetree.cmi \ typing/outcometree.cmi utils/misc.cmx parsing/location.cmx \ parsing/attr_helper.cmx typing/primitive.cmi -typing/printtyped.cmo : typing/typedtree.cmi parsing/printast.cmi \ - typing/path.cmi utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ - typing/ident.cmi parsing/asttypes.cmi typing/printtyped.cmi -typing/printtyped.cmx : typing/typedtree.cmx parsing/printast.cmx \ - typing/path.cmx utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ - typing/ident.cmx parsing/asttypes.cmi typing/printtyped.cmi typing/printtyp.cmo : typing/types.cmi typing/primitive.cmi \ typing/predef.cmi typing/path.cmi parsing/parsetree.cmi \ typing/outcometree.cmi typing/oprint.cmi utils/misc.cmi \ @@ -322,6 +333,12 @@ typing/printtyp.cmx : typing/types.cmx typing/primitive.cmx \ parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ typing/env.cmx typing/ctype.cmx utils/clflags.cmx typing/btype.cmx \ parsing/asttypes.cmi typing/printtyp.cmi +typing/printtyped.cmo : typing/typedtree.cmi parsing/printast.cmi \ + typing/path.cmi utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi parsing/asttypes.cmi typing/printtyped.cmi +typing/printtyped.cmx : typing/typedtree.cmx parsing/printast.cmx \ + typing/path.cmx utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ + typing/ident.cmx parsing/asttypes.cmi typing/printtyped.cmi typing/stypes.cmo : typing/typedtree.cmi typing/printtyp.cmi \ parsing/location.cmi utils/clflags.cmi typing/annot.cmi typing/stypes.cmi typing/stypes.cmx : typing/typedtree.cmx typing/printtyp.cmx \ @@ -338,8 +355,8 @@ typing/tast_mapper.cmx : typing/typedtree.cmx typing/env.cmx \ parsing/asttypes.cmi typing/tast_mapper.cmi typing/typeclass.cmo : utils/warnings.cmi typing/typetexp.cmi \ typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \ - typing/typecore.cmi parsing/syntaxerr.cmi typing/subst.cmi \ - typing/stypes.cmi typing/printtyp.cmi typing/predef.cmi typing/path.cmi \ + typing/typecore.cmi typing/subst.cmi typing/stypes.cmi \ + typing/printtyp.cmi typing/predef.cmi typing/path.cmi \ parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ parsing/location.cmi typing/includeclass.cmi typing/ident.cmi \ typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi utils/clflags.cmi \ @@ -347,57 +364,49 @@ typing/typeclass.cmo : utils/warnings.cmi typing/typetexp.cmi \ parsing/ast_helper.cmi typing/typeclass.cmi typing/typeclass.cmx : utils/warnings.cmx typing/typetexp.cmx \ typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \ - typing/typecore.cmx parsing/syntaxerr.cmx typing/subst.cmx \ - typing/stypes.cmx typing/printtyp.cmx typing/predef.cmx typing/path.cmx \ + typing/typecore.cmx typing/subst.cmx typing/stypes.cmx \ + typing/printtyp.cmx typing/predef.cmx typing/path.cmx \ parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ parsing/location.cmx typing/includeclass.cmx typing/ident.cmx \ typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx utils/clflags.cmx \ parsing/builtin_attributes.cmx typing/btype.cmx parsing/asttypes.cmi \ parsing/ast_helper.cmx typing/typeclass.cmi typing/typecore.cmo : utils/warnings.cmi typing/typetexp.cmi \ - typing/types.cmi typing/typedtree.cmi parsing/syntaxerr.cmi \ - typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi \ - typing/primitive.cmi typing/predef.cmi typing/path.cmi \ - parsing/parsetree.cmi typing/parmatch.cmi typing/oprint.cmi \ - utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ - typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi \ - utils/clflags.cmi parsing/builtin_attributes.cmi typing/btype.cmi \ - parsing/asttypes.cmi parsing/ast_helper.cmi typing/annot.cmi \ - typing/typecore.cmi + typing/types.cmi typing/typedtree.cmi typing/subst.cmi typing/stypes.cmi \ + typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \ + typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi \ + typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ + typing/cmt_format.cmi utils/clflags.cmi parsing/builtin_attributes.cmi \ + typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \ + typing/annot.cmi typing/typecore.cmi typing/typecore.cmx : utils/warnings.cmx typing/typetexp.cmx \ - typing/types.cmx typing/typedtree.cmx parsing/syntaxerr.cmx \ - typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx \ - typing/primitive.cmx typing/predef.cmx typing/path.cmx \ - parsing/parsetree.cmi typing/parmatch.cmx typing/oprint.cmx \ - utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ - typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx \ - utils/clflags.cmx parsing/builtin_attributes.cmx typing/btype.cmx \ - parsing/asttypes.cmi parsing/ast_helper.cmx typing/annot.cmi \ - typing/typecore.cmi + typing/types.cmx typing/typedtree.cmx typing/subst.cmx typing/stypes.cmx \ + typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \ + typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx \ + typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ + typing/cmt_format.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \ + typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \ + typing/annot.cmi typing/typecore.cmi typing/typedecl.cmo : utils/warnings.cmi typing/typetexp.cmi \ - typing/types.cmi typing/typedtree.cmi parsing/syntaxerr.cmi \ - typing/subst.cmi typing/printtyp.cmi typing/primitive.cmi \ - typing/predef.cmi typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \ + typing/types.cmi typing/typedtree.cmi typing/subst.cmi \ + typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \ + typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/includecore.cmi \ typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \ utils/clflags.cmi typing/btype.cmi parsing/attr_helper.cmi \ - parsing/asttypes.cmi parsing/ast_helper.cmi typing/typedecl.cmi + parsing/asttypes.cmi parsing/ast_iterator.cmi parsing/ast_helper.cmi \ + typing/typedecl.cmi typing/typedecl.cmx : utils/warnings.cmx typing/typetexp.cmx \ - typing/types.cmx typing/typedtree.cmx parsing/syntaxerr.cmx \ - typing/subst.cmx typing/printtyp.cmx typing/primitive.cmx \ - typing/predef.cmx typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \ + typing/types.cmx typing/typedtree.cmx typing/subst.cmx \ + typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \ + typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx typing/includecore.cmx \ typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \ utils/clflags.cmx typing/btype.cmx parsing/attr_helper.cmx \ - parsing/asttypes.cmi parsing/ast_helper.cmx typing/typedecl.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/typedtreeMap.cmo : typing/typedtree.cmi utils/misc.cmi \ - typing/typedtreeMap.cmi -typing/typedtreeMap.cmx : typing/typedtree.cmx utils/misc.cmx \ - typing/typedtreeMap.cmi + parsing/asttypes.cmi parsing/ast_iterator.cmx parsing/ast_helper.cmx \ + typing/typedecl.cmi typing/typedtree.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \ parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi \ @@ -406,6 +415,14 @@ typing/typedtree.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \ parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ parsing/location.cmx typing/ident.cmx typing/env.cmx parsing/asttypes.cmi \ typing/typedtree.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/typedtreeMap.cmo : typing/typedtree.cmi utils/misc.cmi \ + typing/typedtreeMap.cmi +typing/typedtreeMap.cmx : typing/typedtree.cmx utils/misc.cmx \ + typing/typedtreeMap.cmi typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \ typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \ typing/typeclass.cmi typing/subst.cmi typing/stypes.cmi \ @@ -414,7 +431,7 @@ typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \ parsing/location.cmi typing/includemod.cmi typing/ident.cmi \ typing/env.cmi typing/ctype.cmi utils/config.cmi typing/cmt_format.cmi \ utils/clflags.cmi parsing/builtin_attributes.cmi typing/btype.cmi \ - parsing/asttypes.cmi parsing/ast_mapper.cmi typing/annot.cmi \ + parsing/asttypes.cmi parsing/ast_iterator.cmi typing/annot.cmi \ typing/typemod.cmi typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ typing/typedtree.cmx typing/typedecl.cmx typing/typecore.cmx \ @@ -424,7 +441,7 @@ typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ parsing/location.cmx typing/includemod.cmx typing/ident.cmx \ typing/env.cmx typing/ctype.cmx utils/config.cmx typing/cmt_format.cmx \ utils/clflags.cmx parsing/builtin_attributes.cmx typing/btype.cmx \ - parsing/asttypes.cmi parsing/ast_mapper.cmx typing/annot.cmi \ + parsing/asttypes.cmi parsing/ast_iterator.cmx typing/annot.cmi \ typing/typemod.cmi typing/types.cmo : typing/primitive.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ @@ -433,19 +450,19 @@ typing/types.cmx : typing/primitive.cmx typing/path.cmx \ parsing/parsetree.cmi parsing/longident.cmx parsing/location.cmx \ typing/ident.cmx parsing/asttypes.cmi typing/types.cmi typing/typetexp.cmo : utils/warnings.cmi typing/types.cmi \ - typing/typedtree.cmi utils/tbl.cmi parsing/syntaxerr.cmi \ - typing/printtyp.cmi typing/predef.cmi typing/path.cmi \ - parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ - parsing/location.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \ - parsing/builtin_attributes.cmi typing/btype.cmi parsing/asttypes.cmi \ - parsing/ast_helper.cmi typing/typetexp.cmi + typing/typedtree.cmi utils/tbl.cmi typing/printtyp.cmi typing/predef.cmi \ + typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi typing/env.cmi \ + typing/ctype.cmi utils/clflags.cmi parsing/builtin_attributes.cmi \ + typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \ + typing/typetexp.cmi typing/typetexp.cmx : utils/warnings.cmx typing/types.cmx \ - typing/typedtree.cmx utils/tbl.cmx parsing/syntaxerr.cmx \ - typing/printtyp.cmx typing/predef.cmx typing/path.cmx \ - parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ - parsing/location.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \ - parsing/builtin_attributes.cmx typing/btype.cmx parsing/asttypes.cmi \ - parsing/ast_helper.cmx typing/typetexp.cmi + typing/typedtree.cmx utils/tbl.cmx typing/printtyp.cmx typing/predef.cmx \ + typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx typing/env.cmx \ + typing/ctype.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \ + typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \ + typing/typetexp.cmi typing/untypeast.cmo : typing/typedtree.cmi typing/path.cmi \ parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi \ @@ -655,11 +672,11 @@ bytecomp/translmod.cmx : typing/types.cmx typing/typedtree.cmx \ parsing/asttypes.cmi bytecomp/translmod.cmi bytecomp/translobj.cmo : typing/primitive.cmi utils/misc.cmi \ parsing/longident.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ - utils/clflags.cmi typing/btype.cmi parsing/asttypes.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/longident.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ - utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + utils/config.cmx utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ bytecomp/translobj.cmi bytecomp/typeopt.cmo : typing/types.cmi typing/typedtree.cmi \ typing/predef.cmi typing/path.cmi bytecomp/lambda.cmi typing/ident.cmi \ @@ -667,34 +684,51 @@ bytecomp/typeopt.cmo : typing/types.cmi typing/typedtree.cmi \ bytecomp/typeopt.cmx : typing/types.cmx typing/typedtree.cmx \ typing/predef.cmx typing/path.cmx bytecomp/lambda.cmx typing/ident.cmx \ typing/env.cmx typing/ctype.cmx typing/btype.cmx bytecomp/typeopt.cmi -asmcomp/asmgen.cmi : utils/timings.cmi bytecomp/lambda.cmi asmcomp/cmm.cmi +asmcomp/CSEgen.cmi : asmcomp/mach.cmi +asmcomp/asmgen.cmi : utils/timings.cmi bytecomp/lambda.cmi \ + middle_end/flambda.cmi asmcomp/cmm.cmi middle_end/backend_intf.cmi asmcomp/asmlibrarian.cmi : asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi -asmcomp/asmpackager.cmi : typing/env.cmi +asmcomp/asmpackager.cmi : typing/env.cmi middle_end/backend_intf.cmi asmcomp/branch_relaxation.cmi : asmcomp/linearize.cmi \ asmcomp/branch_relaxation_intf.cmo -asmcomp/build_export_info.cmi : asmcomp/export_info.cmi +asmcomp/build_export_info.cmi : middle_end/flambda.cmi \ + asmcomp/export_info.cmi middle_end/backend_intf.cmi asmcomp/clambda.cmi : bytecomp/lambda.cmi typing/ident.cmi \ bytecomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi -asmcomp/closure_offsets.cmi : -asmcomp/cmmgen.cmi : asmcomp/cmx_format.cmi asmcomp/cmm.cmi \ - asmcomp/clambda.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.cmi : bytecomp/lambda.cmi typing/ident.cmi \ bytecomp/debuginfo.cmi -asmcomp/cmx_format.cmi : asmcomp/clambda.cmi +asmcomp/cmmgen.cmi : asmcomp/cmx_format.cmi asmcomp/cmm.cmi \ + asmcomp/clambda.cmi +asmcomp/cmx_format.cmi : asmcomp/export_info.cmi asmcomp/clambda.cmi asmcomp/coloring.cmi : asmcomp/comballoc.cmi : asmcomp/mach.cmi -asmcomp/compilenv.cmi : utils/timings.cmi typing/ident.cmi \ - asmcomp/cmx_format.cmi asmcomp/clambda.cmi -asmcomp/CSEgen.cmi : asmcomp/mach.cmi +asmcomp/compilenv.cmi : utils/timings.cmi middle_end/base_types/symbol.cmi \ + middle_end/base_types/set_of_closures_id.cmi \ + middle_end/base_types/linkage_name.cmi typing/ident.cmi \ + middle_end/flambda.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.cmi : asmcomp/mach.cmi -asmcomp/emitaux.cmi : bytecomp/debuginfo.cmi asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi -asmcomp/export_info_for_pack.cmi : asmcomp/export_info.cmi -asmcomp/export_info.cmi : typing/ident.cmi -asmcomp/flambda_to_clambda.cmi : asmcomp/export_info.cmi asmcomp/clambda.cmi -asmcomp/import_approx.cmi : +asmcomp/emitaux.cmi : bytecomp/debuginfo.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.cmi : asmcomp/export_info.cmi \ + middle_end/base_types/compilation_unit.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.cmi : middle_end/base_types/symbol.cmi \ + middle_end/simple_value_approx.cmi asmcomp/interf.cmi : asmcomp/mach.cmi asmcomp/linearize.cmi : asmcomp/reg.cmi asmcomp/mach.cmi bytecomp/lambda.cmi \ bytecomp/debuginfo.cmi @@ -707,8 +741,8 @@ asmcomp/printlinear.cmi : asmcomp/linearize.cmi asmcomp/printmach.cmi : asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/proc.cmi : asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/reg.cmi : typing/ident.cmi asmcomp/cmm.cmi -asmcomp/reloadgen.cmi : asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/reload.cmi : asmcomp/mach.cmi +asmcomp/reloadgen.cmi : asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/schedgen.cmi : asmcomp/mach.cmi asmcomp/linearize.cmi asmcomp/scheduling.cmi : asmcomp/linearize.cmi asmcomp/selectgen.cmi : utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ @@ -723,38 +757,50 @@ asmcomp/x86_dsl.cmi : asmcomp/x86_ast.cmi asmcomp/x86_gas.cmi : asmcomp/x86_ast.cmi asmcomp/x86_masm.cmi : asmcomp/x86_ast.cmi asmcomp/x86_proc.cmi : asmcomp/x86_ast.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/arch.cmo : utils/clflags.cmi asmcomp/arch.cmx : utils/clflags.cmx -asmcomp/asmgen.cmo : bytecomp/translmod.cmi utils/timings.cmi \ - asmcomp/split.cmi asmcomp/spill.cmi asmcomp/selection.cmi \ - asmcomp/scheduling.cmi asmcomp/reload.cmi asmcomp/reg.cmi \ - asmcomp/proc.cmi asmcomp/printmach.cmi asmcomp/printlinear.cmi \ - asmcomp/printcmm.cmi asmcomp/printclambda.cmi typing/primitive.cmi \ - utils/misc.cmi asmcomp/mach.cmi parsing/location.cmi asmcomp/liveness.cmi \ - asmcomp/linearize.cmi asmcomp/interf.cmi asmcomp/emitaux.cmi \ +asmcomp/asmgen.cmo : asmcomp/un_anf.cmi bytecomp/translmod.cmi \ + utils/timings.cmi middle_end/base_types/symbol.cmi asmcomp/split.cmi \ + asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.cmi \ + asmcomp/reload.cmi asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \ + asmcomp/printlinear.cmi asmcomp/printcmm.cmi asmcomp/printclambda.cmi \ + typing/primitive.cmi utils/misc.cmi asmcomp/mach.cmi parsing/location.cmi \ + asmcomp/liveness.cmi middle_end/base_types/linkage_name.cmi \ + asmcomp/linearize.cmi bytecomp/lambda.cmi asmcomp/interf.cmi \ + asmcomp/flambda_to_clambda.cmi middle_end/flambda.cmi asmcomp/emitaux.cmi \ asmcomp/emit.cmi asmcomp/deadcode.cmi utils/config.cmi \ asmcomp/compilenv.cmi asmcomp/comballoc.cmi asmcomp/coloring.cmi \ asmcomp/cmmgen.cmi asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi \ - asmcomp/CSE.cmo asmcomp/asmgen.cmi -asmcomp/asmgen.cmx : bytecomp/translmod.cmx utils/timings.cmx \ - asmcomp/split.cmx asmcomp/spill.cmx asmcomp/selection.cmx \ - asmcomp/scheduling.cmx asmcomp/reload.cmx asmcomp/reg.cmx \ - asmcomp/proc.cmx asmcomp/printmach.cmx asmcomp/printlinear.cmx \ - asmcomp/printcmm.cmx asmcomp/printclambda.cmx typing/primitive.cmx \ - utils/misc.cmx asmcomp/mach.cmx parsing/location.cmx asmcomp/liveness.cmx \ - asmcomp/linearize.cmx asmcomp/interf.cmx asmcomp/emitaux.cmx \ + asmcomp/clambda.cmi asmcomp/CSE.cmo asmcomp/build_export_info.cmi \ + asmcomp/asmgen.cmi +asmcomp/asmgen.cmx : asmcomp/un_anf.cmx bytecomp/translmod.cmx \ + utils/timings.cmx middle_end/base_types/symbol.cmx asmcomp/split.cmx \ + asmcomp/spill.cmx asmcomp/selection.cmx asmcomp/scheduling.cmx \ + asmcomp/reload.cmx asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \ + asmcomp/printlinear.cmx asmcomp/printcmm.cmx asmcomp/printclambda.cmx \ + typing/primitive.cmx utils/misc.cmx asmcomp/mach.cmx parsing/location.cmx \ + asmcomp/liveness.cmx middle_end/base_types/linkage_name.cmx \ + asmcomp/linearize.cmx bytecomp/lambda.cmx asmcomp/interf.cmx \ + asmcomp/flambda_to_clambda.cmx middle_end/flambda.cmx asmcomp/emitaux.cmx \ asmcomp/emit.cmx asmcomp/deadcode.cmx utils/config.cmx \ asmcomp/compilenv.cmx asmcomp/comballoc.cmx asmcomp/coloring.cmx \ asmcomp/cmmgen.cmx asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx \ - asmcomp/CSE.cmx asmcomp/asmgen.cmi + asmcomp/clambda.cmx asmcomp/CSE.cmx asmcomp/build_export_info.cmx \ + asmcomp/asmgen.cmi asmcomp/asmlibrarian.cmo : utils/misc.cmi parsing/location.cmi \ - utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmx_format.cmi \ - utils/clflags.cmi asmcomp/clambda.cmi utils/ccomp.cmi asmcomp/asmlink.cmi \ - asmcomp/asmlibrarian.cmi + asmcomp/export_info.cmi utils/config.cmi asmcomp/compilenv.cmi \ + asmcomp/cmx_format.cmi utils/clflags.cmi asmcomp/clambda.cmi \ + utils/ccomp.cmi asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi asmcomp/asmlibrarian.cmx : utils/misc.cmx parsing/location.cmx \ - utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmx_format.cmi \ - utils/clflags.cmx asmcomp/clambda.cmx utils/ccomp.cmx asmcomp/asmlink.cmx \ - asmcomp/asmlibrarian.cmi + asmcomp/export_info.cmx utils/config.cmx asmcomp/compilenv.cmx \ + asmcomp/cmx_format.cmi utils/clflags.cmx asmcomp/clambda.cmx \ + utils/ccomp.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmi asmcomp/asmlink.cmo : utils/timings.cmi bytecomp/runtimedef.cmi \ utils/misc.cmi parsing/location.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi \ utils/consistbl.cmi utils/config.cmi asmcomp/compilenv.cmi \ @@ -766,28 +812,46 @@ asmcomp/asmlink.cmx : utils/timings.cmx bytecomp/runtimedef.cmx \ asmcomp/cmx_format.cmi asmcomp/cmmgen.cmx utils/clflags.cmx \ utils/ccomp.cmx asmcomp/asmgen.cmx asmcomp/asmlink.cmi asmcomp/asmpackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \ - utils/timings.cmi utils/misc.cmi parsing/location.cmi typing/ident.cmi \ - typing/env.cmi utils/config.cmi asmcomp/compilenv.cmi \ + utils/timings.cmi utils/misc.cmi middle_end/middle_end.cmi \ + parsing/location.cmi typing/ident.cmi asmcomp/export_info_for_pack.cmi \ + asmcomp/export_info.cmi typing/env.cmi utils/config.cmi \ + asmcomp/compilenv.cmi middle_end/base_types/compilation_unit.cmi \ asmcomp/cmx_format.cmi utils/clflags.cmi utils/ccomp.cmi \ asmcomp/asmlink.cmi asmcomp/asmgen.cmi asmcomp/asmpackager.cmi asmcomp/asmpackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \ - utils/timings.cmx utils/misc.cmx parsing/location.cmx typing/ident.cmx \ - typing/env.cmx utils/config.cmx asmcomp/compilenv.cmx \ + utils/timings.cmx utils/misc.cmx middle_end/middle_end.cmx \ + parsing/location.cmx typing/ident.cmx asmcomp/export_info_for_pack.cmx \ + asmcomp/export_info.cmx typing/env.cmx utils/config.cmx \ + asmcomp/compilenv.cmx middle_end/base_types/compilation_unit.cmx \ asmcomp/cmx_format.cmi utils/clflags.cmx utils/ccomp.cmx \ asmcomp/asmlink.cmx asmcomp/asmgen.cmx asmcomp/asmpackager.cmi -asmcomp/branch_relaxation_intf.cmo : asmcomp/linearize.cmi asmcomp/arch.cmo -asmcomp/branch_relaxation_intf.cmx : asmcomp/linearize.cmx asmcomp/arch.cmx asmcomp/branch_relaxation.cmo : utils/misc.cmi asmcomp/mach.cmi \ asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/branch_relaxation_intf.cmo \ asmcomp/branch_relaxation.cmi asmcomp/branch_relaxation.cmx : utils/misc.cmx asmcomp/mach.cmx \ asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/branch_relaxation_intf.cmx \ asmcomp/branch_relaxation.cmi -asmcomp/build_export_info.cmo : utils/misc.cmi typing/ident.cmi \ - asmcomp/export_info.cmi asmcomp/compilenv.cmi utils/clflags.cmi \ +asmcomp/branch_relaxation_intf.cmo : asmcomp/linearize.cmi asmcomp/arch.cmo +asmcomp/branch_relaxation_intf.cmx : asmcomp/linearize.cmx asmcomp/arch.cmx +asmcomp/build_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/base_types/set_of_closures_id.cmi utils/misc.cmi \ + middle_end/invariant_params.cmi middle_end/flambda_utils.cmi \ + middle_end/flambda.cmi asmcomp/export_info.cmi \ + middle_end/base_types/export_id.cmi asmcomp/compilenv.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 : utils/misc.cmx typing/ident.cmx \ - asmcomp/export_info.cmx asmcomp/compilenv.cmx utils/clflags.cmx \ +asmcomp/build_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/base_types/set_of_closures_id.cmx utils/misc.cmx \ + middle_end/invariant_params.cmx middle_end/flambda_utils.cmx \ + middle_end/flambda.cmx asmcomp/export_info.cmx \ + middle_end/base_types/export_id.cmx asmcomp/compilenv.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/clambda.cmo : bytecomp/lambda.cmi typing/ident.cmi \ bytecomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi @@ -805,50 +869,60 @@ asmcomp/closure.cmx : utils/warnings.cmx utils/tbl.cmx bytecomp/switch.cmx \ bytecomp/debuginfo.cmx asmcomp/compilenv.cmx utils/clflags.cmx \ asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \ asmcomp/closure.cmi -asmcomp/closure_offsets.cmo : utils/misc.cmi asmcomp/closure_offsets.cmi -asmcomp/closure_offsets.cmx : utils/misc.cmx asmcomp/closure_offsets.cmi -asmcomp/cmmgen.cmo : typing/types.cmi bytecomp/switch.cmi \ - asmcomp/strmatch.cmi asmcomp/proc.cmi typing/primitive.cmi utils/misc.cmi \ - bytecomp/lambda.cmi typing/ident.cmi bytecomp/debuginfo.cmi \ - utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmx_format.cmi \ - asmcomp/cmm.cmi utils/clflags.cmi asmcomp/clambda.cmi \ - parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/cmmgen.cmi -asmcomp/cmmgen.cmx : typing/types.cmx bytecomp/switch.cmx \ - asmcomp/strmatch.cmx asmcomp/proc.cmx typing/primitive.cmx utils/misc.cmx \ - bytecomp/lambda.cmx typing/ident.cmx bytecomp/debuginfo.cmx \ - utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmx_format.cmi \ - asmcomp/cmm.cmx utils/clflags.cmx asmcomp/clambda.cmx \ - parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/cmmgen.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_iterators.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_iterators.cmx \ + middle_end/flambda.cmx middle_end/base_types/closure_id.cmx \ + asmcomp/closure_offsets.cmi asmcomp/cmm.cmo : bytecomp/lambda.cmi typing/ident.cmi \ bytecomp/debuginfo.cmi asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/cmm.cmx : bytecomp/lambda.cmx typing/ident.cmx \ bytecomp/debuginfo.cmx asmcomp/arch.cmx asmcomp/cmm.cmi +asmcomp/cmmgen.cmo : asmcomp/un_anf.cmi typing/types.cmi bytecomp/switch.cmi \ + asmcomp/strmatch.cmi asmcomp/proc.cmi bytecomp/printlambda.cmi \ + typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \ + bytecomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \ + asmcomp/cmx_format.cmi asmcomp/cmm.cmi utils/clflags.cmi \ + asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \ + asmcomp/cmmgen.cmi +asmcomp/cmmgen.cmx : asmcomp/un_anf.cmx typing/types.cmx bytecomp/switch.cmx \ + asmcomp/strmatch.cmx asmcomp/proc.cmx bytecomp/printlambda.cmx \ + typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx \ + bytecomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \ + asmcomp/cmx_format.cmi asmcomp/cmm.cmx utils/clflags.cmx \ + asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \ + asmcomp/cmmgen.cmi asmcomp/coloring.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/coloring.cmi asmcomp/coloring.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/coloring.cmi asmcomp/comballoc.cmo : asmcomp/reg.cmi asmcomp/mach.cmi utils/config.cmi \ asmcomp/arch.cmo asmcomp/comballoc.cmi asmcomp/comballoc.cmx : asmcomp/reg.cmx asmcomp/mach.cmx utils/config.cmx \ asmcomp/arch.cmx asmcomp/comballoc.cmi -asmcomp/compilenv.cmo : utils/warnings.cmi utils/misc.cmi \ - parsing/location.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \ - asmcomp/cmx_format.cmi asmcomp/clambda.cmi asmcomp/compilenv.cmi -asmcomp/compilenv.cmx : utils/warnings.cmx utils/misc.cmx \ - parsing/location.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \ - asmcomp/cmx_format.cmi asmcomp/clambda.cmx asmcomp/compilenv.cmi -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/CSE.cmo : asmcomp/mach.cmi asmcomp/CSEgen.cmi asmcomp/arch.cmo -asmcomp/CSE.cmx : asmcomp/mach.cmx asmcomp/CSEgen.cmx asmcomp/arch.cmx +asmcomp/compilenv.cmo : utils/warnings.cmi middle_end/base_types/symbol.cmi \ + middle_end/base_types/set_of_closures_id.cmi utils/misc.cmi \ + parsing/location.cmi middle_end/base_types/linkage_name.cmi \ + typing/ident.cmi middle_end/flambda.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 asmcomp/clambda.cmi \ + asmcomp/compilenv.cmi +asmcomp/compilenv.cmx : utils/warnings.cmx middle_end/base_types/symbol.cmx \ + middle_end/base_types/set_of_closures_id.cmx utils/misc.cmx \ + parsing/location.cmx middle_end/base_types/linkage_name.cmx \ + typing/ident.cmx middle_end/flambda.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 asmcomp/clambda.cmx \ + asmcomp/compilenv.cmi asmcomp/deadcode.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ asmcomp/deadcode.cmi asmcomp/deadcode.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ asmcomp/deadcode.cmi -asmcomp/emitaux.cmo : asmcomp/linearize.cmi bytecomp/debuginfo.cmi \ - utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi -asmcomp/emitaux.cmx : asmcomp/linearize.cmx bytecomp/debuginfo.cmx \ - utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi asmcomp/emit.cmo : asmcomp/x86_proc.cmi asmcomp/x86_masm.cmi \ asmcomp/x86_gas.cmi asmcomp/x86_dsl.cmi asmcomp/x86_ast.cmi \ asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi \ @@ -863,24 +937,84 @@ asmcomp/emit.cmx : asmcomp/x86_proc.cmx asmcomp/x86_masm.cmx \ bytecomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \ asmcomp/cmm.cmx utils/clflags.cmx asmcomp/branch_relaxation.cmx \ asmcomp/arch.cmx asmcomp/emit.cmi -asmcomp/export_info_for_pack.cmo : utils/misc.cmi typing/ident.cmi \ - asmcomp/export_info.cmi asmcomp/export_info_for_pack.cmi -asmcomp/export_info_for_pack.cmx : utils/misc.cmx typing/ident.cmx \ - asmcomp/export_info.cmx asmcomp/export_info_for_pack.cmi -asmcomp/export_info.cmo : typing/ident.cmi asmcomp/export_info.cmi -asmcomp/export_info.cmx : typing/ident.cmx asmcomp/export_info.cmi -asmcomp/flambda_to_clambda.cmo : typing/primitive.cmi utils/numbers.cmi \ - utils/misc.cmi typing/ident.cmi asmcomp/export_info.cmi \ - bytecomp/debuginfo.cmi asmcomp/compilenv.cmi asmcomp/closure_offsets.cmi \ - utils/clflags.cmi asmcomp/clambda.cmi asmcomp/flambda_to_clambda.cmi -asmcomp/flambda_to_clambda.cmx : typing/primitive.cmx utils/numbers.cmx \ - utils/misc.cmx typing/ident.cmx asmcomp/export_info.cmx \ - bytecomp/debuginfo.cmx asmcomp/compilenv.cmx asmcomp/closure_offsets.cmx \ - utils/clflags.cmx asmcomp/clambda.cmx asmcomp/flambda_to_clambda.cmi -asmcomp/import_approx.cmo : utils/misc.cmi asmcomp/export_info.cmi \ - asmcomp/compilenv.cmi asmcomp/import_approx.cmi -asmcomp/import_approx.cmx : utils/misc.cmx asmcomp/export_info.cmx \ - asmcomp/compilenv.cmx asmcomp/import_approx.cmi +asmcomp/emitaux.cmo : asmcomp/linearize.cmi bytecomp/debuginfo.cmi \ + utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi +asmcomp/emitaux.cmx : asmcomp/linearize.cmx bytecomp/debuginfo.cmx \ + utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.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_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/base_types/set_of_closures_id.cmi utils/misc.cmi \ + middle_end/flambda_utils.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/base_types/set_of_closures_id.cmx utils/misc.cmx \ + middle_end/flambda_utils.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/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/base_types/set_of_closures_id.cmi typing/primitive.cmi \ + utils/numbers.cmi middle_end/base_types/mutable_variable.cmi \ + utils/misc.cmi middle_end/base_types/linkage_name.cmi typing/ident.cmi \ + middle_end/flambda_utils.cmi middle_end/flambda.cmi \ + asmcomp/export_info.cmi bytecomp/debuginfo.cmi asmcomp/compilenv.cmi \ + asmcomp/closure_offsets.cmi middle_end/base_types/closure_id.cmi \ + utils/clflags.cmi asmcomp/clambda.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/base_types/set_of_closures_id.cmx typing/primitive.cmx \ + utils/numbers.cmx middle_end/base_types/mutable_variable.cmx \ + utils/misc.cmx middle_end/base_types/linkage_name.cmx typing/ident.cmx \ + middle_end/flambda_utils.cmx middle_end/flambda.cmx \ + asmcomp/export_info.cmx bytecomp/debuginfo.cmx asmcomp/compilenv.cmx \ + asmcomp/closure_offsets.cmx middle_end/base_types/closure_id.cmx \ + utils/clflags.cmx asmcomp/clambda.cmx middle_end/allocated_const.cmx \ + asmcomp/flambda_to_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/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/closure_id.cmx asmcomp/import_approx.cmi asmcomp/interf.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ asmcomp/interf.cmi asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ @@ -933,14 +1067,14 @@ asmcomp/proc.cmx : asmcomp/x86_proc.cmx asmcomp/reg.cmx utils/misc.cmx \ asmcomp/proc.cmi asmcomp/reg.cmo : typing/ident.cmi asmcomp/cmm.cmi asmcomp/reg.cmi asmcomp/reg.cmx : typing/ident.cmx asmcomp/cmm.cmx asmcomp/reg.cmi -asmcomp/reloadgen.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ - asmcomp/reloadgen.cmi -asmcomp/reloadgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ - asmcomp/reloadgen.cmi asmcomp/reload.cmo : asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ asmcomp/cmm.cmi utils/clflags.cmi asmcomp/reload.cmi asmcomp/reload.cmx : asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \ asmcomp/cmm.cmx utils/clflags.cmx asmcomp/reload.cmi +asmcomp/reloadgen.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ + asmcomp/reloadgen.cmi +asmcomp/reloadgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ + asmcomp/reloadgen.cmi asmcomp/schedgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ asmcomp/schedgen.cmi @@ -975,14 +1109,16 @@ asmcomp/strmatch.cmo : bytecomp/lambda.cmi typing/ident.cmi asmcomp/cmm.cmi \ asmcomp/arch.cmo asmcomp/strmatch.cmi asmcomp/strmatch.cmx : bytecomp/lambda.cmx typing/ident.cmx asmcomp/cmm.cmx \ asmcomp/arch.cmx asmcomp/strmatch.cmi -asmcomp/un_anf.cmo : asmcomp/printclambda.cmi utils/misc.cmi \ - bytecomp/lambda.cmi typing/ident.cmi bytecomp/debuginfo.cmi \ - utils/config.cmi utils/clflags.cmi asmcomp/clambda.cmi \ - parsing/asttypes.cmi asmcomp/un_anf.cmi -asmcomp/un_anf.cmx : asmcomp/printclambda.cmx utils/misc.cmx \ - bytecomp/lambda.cmx typing/ident.cmx bytecomp/debuginfo.cmx \ - utils/config.cmx utils/clflags.cmx asmcomp/clambda.cmx \ - parsing/asttypes.cmi asmcomp/un_anf.cmi +asmcomp/un_anf.cmo : middle_end/semantics_of_primitives.cmi \ + asmcomp/printclambda.cmi utils/misc.cmi bytecomp/lambda.cmi \ + typing/ident.cmi bytecomp/debuginfo.cmi utils/config.cmi \ + utils/clflags.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \ + asmcomp/un_anf.cmi +asmcomp/un_anf.cmx : middle_end/semantics_of_primitives.cmx \ + asmcomp/printclambda.cmx utils/misc.cmx bytecomp/lambda.cmx \ + typing/ident.cmx bytecomp/debuginfo.cmx utils/config.cmx \ + utils/clflags.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \ + asmcomp/un_anf.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 \ @@ -999,13 +1135,709 @@ asmcomp/x86_proc.cmo : asmcomp/x86_ast.cmi utils/config.cmi \ utils/clflags.cmi utils/ccomp.cmi asmcomp/x86_proc.cmi asmcomp/x86_proc.cmx : asmcomp/x86_ast.cmi utils/config.cmx \ utils/clflags.cmx utils/ccomp.cmx asmcomp/x86_proc.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.cmi : +middle_end/augment_closures.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.cmi : bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/flambda.cmi middle_end/backend_intf.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 bytecomp/lambda.cmi \ + typing/ident.cmi +middle_end/effect_analysis.cmi : middle_end/flambda.cmi +middle_end/find_recursive_functions.cmi : middle_end/base_types/variable.cmi \ + middle_end/flambda.cmi middle_end/backend_intf.cmi +middle_end/flambda.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/static_exception.cmi \ + middle_end/base_types/set_of_closures_id.cmi utils/numbers.cmi \ + middle_end/base_types/mutable_variable.cmi bytecomp/lambda.cmi \ + utils/identifiable.cmi bytecomp/debuginfo.cmi \ + middle_end/base_types/closure_id.cmi parsing/asttypes.cmi \ + middle_end/allocated_const.cmi +middle_end/flambda_invariants.cmi : middle_end/flambda.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.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/flambda.cmi \ + middle_end/base_types/closure_id.cmi middle_end/backend_intf.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.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/backend_intf.cmi +middle_end/initialize_symbol_to_let_symbol.cmi : middle_end/flambda.cmi +middle_end/inline_and_simplify.cmi : middle_end/flambda.cmi \ + middle_end/backend_intf.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_id.cmi \ + middle_end/base_types/mutable_variable.cmi \ + middle_end/inlining_stats_types.cmi middle_end/inlining_cost.cmi \ + middle_end/freshening.cmi bytecomp/debuginfo.cmi \ + middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi +middle_end/inlining_cost.cmi : middle_end/flambda.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 \ + bytecomp/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 bytecomp/debuginfo.cmi \ + middle_end/base_types/closure_id.cmi +middle_end/inlining_stats.cmi : middle_end/inlining_stats_types.cmi \ + bytecomp/debuginfo.cmi middle_end/base_types/closure_id.cmi +middle_end/inlining_stats_types.cmi : middle_end/inlining_cost.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 \ + bytecomp/debuginfo.cmi middle_end/base_types/closure_id.cmi +middle_end/invariant_params.cmi : middle_end/base_types/variable.cmi \ + middle_end/flambda.cmi middle_end/backend_intf.cmi +middle_end/lift_code.cmi : middle_end/base_types/variable.cmi \ + middle_end/flambda.cmi +middle_end/lift_constants.cmi : middle_end/flambda.cmi \ + middle_end/backend_intf.cmi +middle_end/lift_let_to_initialize_symbol.cmi : middle_end/flambda.cmi \ + middle_end/backend_intf.cmi +middle_end/middle_end.cmi : utils/timings.cmi bytecomp/lambda.cmi \ + typing/ident.cmi middle_end/flambda.cmi middle_end/backend_intf.cmi +middle_end/ref_to_variables.cmi : middle_end/flambda.cmi +middle_end/remove_unused_arguments.cmi : middle_end/flambda.cmi \ + middle_end/backend_intf.cmi +middle_end/remove_unused_closure_vars.cmi : middle_end/flambda.cmi +middle_end/remove_unused_program_constructs.cmi : middle_end/flambda.cmi +middle_end/semantics_of_primitives.cmi : bytecomp/lambda.cmi +middle_end/share_constants.cmi : middle_end/flambda.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/freshening.cmi middle_end/flambda.cmi \ + middle_end/base_types/export_id.cmi middle_end/base_types/closure_id.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.cmi : middle_end/simple_value_approx.cmi \ + bytecomp/lambda.cmi middle_end/inlining_cost.cmi middle_end/flambda.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 \ + bytecomp/debuginfo.cmi +middle_end/unbox_closures.cmi : middle_end/base_types/variable.cmi \ + middle_end/flambda.cmi middle_end/backend_intf.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/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/flambda.cmx \ + parsing/asttypes.cmi middle_end/allocated_const.cmx \ + middle_end/alias_analysis.cmi +middle_end/allocated_const.cmo : middle_end/allocated_const.cmi +middle_end/allocated_const.cmx : middle_end/allocated_const.cmi +middle_end/augment_closures.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/simple_value_approx.cmi utils/numbers.cmi \ + middle_end/inline_and_simplify_aux.cmi utils/identifiable.cmi \ + middle_end/freshening.cmi middle_end/flambda_utils.cmi \ + middle_end/flambda_iterators.cmi middle_end/flambda.cmi \ + bytecomp/debuginfo.cmi middle_end/base_types/closure_id.cmi \ + utils/clflags.cmi middle_end/augment_closures.cmi +middle_end/augment_closures.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx \ + middle_end/simple_value_approx.cmx utils/numbers.cmx \ + middle_end/inline_and_simplify_aux.cmx utils/identifiable.cmx \ + middle_end/freshening.cmx middle_end/flambda_utils.cmx \ + middle_end/flambda_iterators.cmx middle_end/flambda.cmx \ + bytecomp/debuginfo.cmx middle_end/base_types/closure_id.cmx \ + utils/clflags.cmx middle_end/augment_closures.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/base_types/set_of_closures_id.cmi bytecomp/printlambda.cmi \ + typing/primitive.cmi typing/predef.cmi utils/numbers.cmi \ + middle_end/base_types/mutable_variable.cmi utils/misc.cmi \ + parsing/location.cmi middle_end/base_types/linkage_name.cmi \ + middle_end/lift_code.cmi bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/flambda_utils.cmi middle_end/flambda.cmi \ + bytecomp/debuginfo.cmi middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/closure_id.cmi \ + middle_end/closure_conversion_aux.cmi utils/clflags.cmi \ + middle_end/backend_intf.cmi parsing/asttypes.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/base_types/set_of_closures_id.cmx bytecomp/printlambda.cmx \ + typing/primitive.cmx typing/predef.cmx utils/numbers.cmx \ + middle_end/base_types/mutable_variable.cmx utils/misc.cmx \ + parsing/location.cmx middle_end/base_types/linkage_name.cmx \ + middle_end/lift_code.cmx bytecomp/lambda.cmx typing/ident.cmx \ + middle_end/flambda_utils.cmx middle_end/flambda.cmx \ + bytecomp/debuginfo.cmx middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/closure_id.cmx \ + middle_end/closure_conversion_aux.cmx utils/clflags.cmx \ + middle_end/backend_intf.cmi parsing/asttypes.cmi \ + middle_end/closure_conversion.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 typing/primitive.cmi \ + utils/numbers.cmi middle_end/base_types/mutable_variable.cmi \ + utils/misc.cmi bytecomp/lambda.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 typing/primitive.cmx \ + utils/numbers.cmx middle_end/base_types/mutable_variable.cmx \ + utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx \ + middle_end/closure_conversion_aux.cmi +middle_end/effect_analysis.cmo : middle_end/semantics_of_primitives.cmi \ + utils/misc.cmi bytecomp/lambda.cmi middle_end/flambda.cmi \ + middle_end/effect_analysis.cmi +middle_end/effect_analysis.cmx : middle_end/semantics_of_primitives.cmx \ + utils/misc.cmx bytecomp/lambda.cmx middle_end/flambda.cmx \ + middle_end/effect_analysis.cmi +middle_end/find_recursive_functions.cmo : middle_end/base_types/variable.cmi \ + utils/strongly_connected_components.cmi middle_end/flambda_utils.cmi \ + middle_end/flambda.cmi middle_end/find_recursive_functions.cmi +middle_end/find_recursive_functions.cmx : middle_end/base_types/variable.cmx \ + utils/strongly_connected_components.cmx middle_end/flambda_utils.cmx \ + middle_end/flambda.cmx middle_end/find_recursive_functions.cmi +middle_end/flambda.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_id.cmi bytecomp/printlambda.cmi \ + utils/numbers.cmi middle_end/base_types/mutable_variable.cmi \ + utils/misc.cmi bytecomp/lambda.cmi utils/identifiable.cmi \ + bytecomp/debuginfo.cmi middle_end/base_types/compilation_unit.cmi \ + middle_end/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/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_id.cmx bytecomp/printlambda.cmx \ + utils/numbers.cmx middle_end/base_types/mutable_variable.cmx \ + utils/misc.cmx bytecomp/lambda.cmx utils/identifiable.cmx \ + bytecomp/debuginfo.cmx middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/closure_id.cmx utils/clflags.cmx \ + parsing/asttypes.cmi middle_end/allocated_const.cmx \ + middle_end/flambda.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_id.cmi bytecomp/printlambda.cmi \ + utils/numbers.cmi middle_end/base_types/mutable_variable.cmi \ + utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/flambda_iterators.cmi middle_end/flambda.cmi \ + bytecomp/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_id.cmx bytecomp/printlambda.cmx \ + utils/numbers.cmx middle_end/base_types/mutable_variable.cmx \ + utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx \ + middle_end/flambda_iterators.cmx middle_end/flambda.cmx \ + bytecomp/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_iterators.cmo : middle_end/base_types/variable.cmi \ + utils/misc.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/flambda.cmx middle_end/flambda_iterators.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/base_types/mutable_variable.cmi utils/misc.cmi \ + middle_end/base_types/linkage_name.cmi middle_end/flambda_iterators.cmi \ + middle_end/flambda.cmi bytecomp/debuginfo.cmi \ + middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/closure_id.cmi middle_end/backend_intf.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/base_types/mutable_variable.cmx utils/misc.cmx \ + middle_end/base_types/linkage_name.cmx middle_end/flambda_iterators.cmx \ + middle_end/flambda.cmx bytecomp/debuginfo.cmx \ + middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/closure_id.cmx middle_end/backend_intf.cmi \ + middle_end/allocated_const.cmx middle_end/flambda_utils.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/base_types/set_of_closures_id.cmi \ + middle_end/base_types/mutable_variable.cmi utils/misc.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 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/base_types/set_of_closures_id.cmx \ + middle_end/base_types/mutable_variable.cmx utils/misc.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 middle_end/freshening.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 utils/numbers.cmi \ + utils/misc.cmi bytecomp/lambda.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/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 utils/numbers.cmx \ + utils/misc.cmx bytecomp/lambda.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/backend_intf.cmi \ + parsing/asttypes.cmi middle_end/inconstant_idents.cmi +middle_end/initialize_symbol_to_let_symbol.cmo : \ + middle_end/base_types/variable.cmi utils/misc.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/flambda.cmx \ + middle_end/initialize_symbol_to_let_symbol.cmi +middle_end/inline_and_simplify.cmo : utils/warnings.cmi \ + middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.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 typing/predef.cmi utils/misc.cmi \ + parsing/location.cmi bytecomp/lambda.cmi middle_end/invariant_params.cmi \ + middle_end/inlining_stats.cmi middle_end/inlining_decision.cmi \ + middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \ + typing/ident.cmi middle_end/freshening.cmi middle_end/flambda_utils.cmi \ + middle_end/flambda.cmi middle_end/effect_analysis.cmi \ + bytecomp/debuginfo.cmi middle_end/base_types/closure_id.cmi \ + utils/clflags.cmi middle_end/backend_intf.cmi \ + middle_end/augment_closures.cmi middle_end/allocated_const.cmi \ + middle_end/inline_and_simplify.cmi +middle_end/inline_and_simplify.cmx : utils/warnings.cmx \ + middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.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 typing/predef.cmx utils/misc.cmx \ + parsing/location.cmx bytecomp/lambda.cmx middle_end/invariant_params.cmx \ + middle_end/inlining_stats.cmx middle_end/inlining_decision.cmx \ + middle_end/inlining_cost.cmx middle_end/inline_and_simplify_aux.cmx \ + typing/ident.cmx middle_end/freshening.cmx middle_end/flambda_utils.cmx \ + middle_end/flambda.cmx middle_end/effect_analysis.cmx \ + bytecomp/debuginfo.cmx middle_end/base_types/closure_id.cmx \ + utils/clflags.cmx middle_end/backend_intf.cmi \ + middle_end/augment_closures.cmx middle_end/allocated_const.cmx \ + middle_end/inline_and_simplify.cmi +middle_end/inline_and_simplify_aux.cmo : 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_id.cmi utils/numbers.cmi \ + middle_end/base_types/mutable_variable.cmi utils/misc.cmi \ + middle_end/inlining_stats.cmi middle_end/inlining_cost.cmi \ + middle_end/freshening.cmi middle_end/base_types/compilation_unit.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/symbol.cmx \ + middle_end/base_types/static_exception.cmx \ + middle_end/simple_value_approx.cmx \ + middle_end/base_types/set_of_closures_id.cmx utils/numbers.cmx \ + middle_end/base_types/mutable_variable.cmx utils/misc.cmx \ + middle_end/inlining_stats.cmx middle_end/inlining_cost.cmx \ + middle_end/freshening.cmx middle_end/base_types/compilation_unit.cmx \ + utils/clflags.cmx middle_end/backend_intf.cmi \ + middle_end/inline_and_simplify_aux.cmi +middle_end/inlining_cost.cmo : middle_end/base_types/variable.cmi \ + typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \ + middle_end/flambda_iterators.cmi middle_end/flambda.cmi utils/clflags.cmi \ + middle_end/inlining_cost.cmi +middle_end/inlining_cost.cmx : middle_end/base_types/variable.cmx \ + typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \ + middle_end/flambda_iterators.cmx middle_end/flambda.cmx utils/clflags.cmx \ + middle_end/inlining_cost.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 utils/misc.cmi \ + middle_end/lift_code.cmi bytecomp/lambda.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_utils.cmi middle_end/flambda.cmi \ + middle_end/find_recursive_functions.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 utils/misc.cmx \ + middle_end/lift_code.cmx bytecomp/lambda.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_utils.cmx middle_end/flambda.cmx \ + middle_end/find_recursive_functions.cmx utils/clflags.cmx \ + middle_end/inlining_decision.cmi +middle_end/inlining_stats.cmo : utils/misc.cmi \ + middle_end/inlining_stats_types.cmi bytecomp/debuginfo.cmi \ + middle_end/base_types/closure_id.cmi utils/clflags.cmi \ + middle_end/inlining_stats.cmi +middle_end/inlining_stats.cmx : utils/misc.cmx \ + middle_end/inlining_stats_types.cmx bytecomp/debuginfo.cmx \ + middle_end/base_types/closure_id.cmx utils/clflags.cmx \ + middle_end/inlining_stats.cmi +middle_end/inlining_stats_types.cmo : middle_end/inlining_cost.cmi \ + middle_end/inlining_stats_types.cmi +middle_end/inlining_stats_types.cmx : middle_end/inlining_cost.cmx \ + middle_end/inlining_stats_types.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 utils/misc.cmi bytecomp/lambda.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/compilation_unit.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 utils/misc.cmx bytecomp/lambda.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/compilation_unit.cmx \ + middle_end/base_types/closure_id.cmx middle_end/inlining_transforms.cmi +middle_end/invariant_params.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/symbol.cmi utils/misc.cmi \ + middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \ + middle_end/flambda.cmi middle_end/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 utils/misc.cmx \ + middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \ + middle_end/flambda.cmx middle_end/base_types/closure_id.cmx \ + utils/clflags.cmx middle_end/backend_intf.cmi \ + middle_end/invariant_params.cmi +middle_end/lift_code.cmo : middle_end/base_types/variable.cmi \ + utils/strongly_connected_components.cmi \ + middle_end/simple_value_approx.cmi middle_end/inlining_cost.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/strongly_connected_components.cmx \ + middle_end/simple_value_approx.cmx middle_end/inlining_cost.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_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 \ + utils/strongly_connected_components.cmi \ + middle_end/simple_value_approx.cmi utils/misc.cmi \ + middle_end/base_types/linkage_name.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 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 \ + utils/strongly_connected_components.cmx \ + middle_end/simple_value_approx.cmx utils/misc.cmx \ + middle_end/base_types/linkage_name.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 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_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_utils.cmi \ + middle_end/flambda.cmi bytecomp/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 middle_end/flambda_utils.cmx \ + middle_end/flambda.cmx bytecomp/debuginfo.cmx parsing/asttypes.cmi \ + middle_end/lift_let_to_initialize_symbol.cmi +middle_end/middle_end.cmo : utils/warnings.cmi \ + middle_end/base_types/variable.cmi utils/timings.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/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/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 bytecomp/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 utils/timings.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/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/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 bytecomp/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/ref_to_variables.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/mutable_variable.cmi utils/misc.cmi \ + middle_end/flambda_iterators.cmi middle_end/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 utils/misc.cmx \ + middle_end/flambda_iterators.cmx middle_end/flambda.cmx \ + parsing/asttypes.cmi middle_end/ref_to_variables.cmi +middle_end/remove_unused_arguments.cmo : middle_end/base_types/variable.cmi \ + middle_end/invariant_params.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_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/invariant_params.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_id.cmx utils/clflags.cmx \ + middle_end/remove_unused_arguments.cmi +middle_end/remove_unused_closure_vars.cmo : \ + middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.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/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_program_constructs.cmo : \ + middle_end/base_types/symbol.cmi utils/misc.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 utils/misc.cmx middle_end/flambda.cmx \ + middle_end/effect_analysis.cmx \ + middle_end/remove_unused_program_constructs.cmi +middle_end/semantics_of_primitives.cmo : bytecomp/printlambda.cmi \ + utils/misc.cmi bytecomp/lambda.cmi middle_end/semantics_of_primitives.cmi +middle_end/semantics_of_primitives.cmx : bytecomp/printlambda.cmx \ + utils/misc.cmx bytecomp/lambda.cmx middle_end/semantics_of_primitives.cmi +middle_end/share_constants.cmo : middle_end/base_types/symbol.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/flambda_iterators.cmx middle_end/flambda.cmx \ + middle_end/share_constants.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 \ + utils/misc.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/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 \ + utils/misc.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/base_types/closure_id.cmx middle_end/allocated_const.cmx \ + middle_end/simple_value_approx.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/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/inlining_cost.cmx middle_end/simplify_boxed_integer_ops.cmi +middle_end/simplify_common.cmo : middle_end/simple_value_approx.cmi \ + bytecomp/lambda.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/inlining_cost.cmx \ + middle_end/effect_analysis.cmx middle_end/simplify_common.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 utils/misc.cmi bytecomp/lambda.cmi \ + middle_end/inlining_cost.cmi middle_end/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 utils/misc.cmx bytecomp/lambda.cmx \ + middle_end/inlining_cost.cmx middle_end/flambda.cmx utils/clflags.cmx \ + parsing/asttypes.cmi middle_end/simplify_primitives.cmi +middle_end/unbox_closures.cmo : middle_end/base_types/variable.cmi \ + middle_end/simple_value_approx.cmi middle_end/inline_and_simplify_aux.cmi \ + middle_end/flambda_utils.cmi middle_end/flambda.cmi \ + bytecomp/debuginfo.cmi middle_end/base_types/closure_id.cmi \ + utils/clflags.cmi middle_end/backend_intf.cmi \ + middle_end/unbox_closures.cmi +middle_end/unbox_closures.cmx : middle_end/base_types/variable.cmx \ + middle_end/simple_value_approx.cmx middle_end/inline_and_simplify_aux.cmx \ + middle_end/flambda_utils.cmx middle_end/flambda.cmx \ + bytecomp/debuginfo.cmx middle_end/base_types/closure_id.cmx \ + utils/clflags.cmx middle_end/backend_intf.cmi \ + middle_end/unbox_closures.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.cmi : \ + middle_end/base_types/closure_element.cmi +middle_end/base_types/compilation_unit.cmi : \ + middle_end/base_types/linkage_name.cmi utils/identifiable.cmi \ + typing/ident.cmi +middle_end/base_types/export_id.cmi : utils/identifiable.cmi \ + middle_end/base_types/compilation_unit.cmi +middle_end/base_types/id_types.cmi : utils/identifiable.cmi +middle_end/base_types/linkage_name.cmi : utils/identifiable.cmi +middle_end/base_types/mutable_variable.cmi : utils/identifiable.cmi \ + typing/ident.cmi middle_end/base_types/compilation_unit.cmi +middle_end/base_types/set_of_closures_id.cmi : utils/identifiable.cmi \ + middle_end/base_types/compilation_unit.cmi +middle_end/base_types/static_exception.cmi : utils/identifiable.cmi +middle_end/base_types/symbol.cmi : middle_end/base_types/linkage_name.cmi \ + utils/identifiable.cmi middle_end/base_types/compilation_unit.cmi +middle_end/base_types/tag.cmi : utils/identifiable.cmi +middle_end/base_types/var_within_closure.cmi : \ + middle_end/base_types/closure_element.cmi +middle_end/base_types/variable.cmi : utils/identifiable.cmi typing/ident.cmi \ + middle_end/base_types/compilation_unit.cmi +middle_end/base_types/closure_element.cmo : \ + middle_end/base_types/variable.cmi \ + middle_end/base_types/closure_element.cmi +middle_end/base_types/closure_element.cmx : \ + middle_end/base_types/variable.cmx \ + middle_end/base_types/closure_element.cmi +middle_end/base_types/closure_id.cmo : \ + middle_end/base_types/closure_element.cmi \ + middle_end/base_types/closure_id.cmi +middle_end/base_types/closure_id.cmx : \ + middle_end/base_types/closure_element.cmx \ + middle_end/base_types/closure_id.cmi +middle_end/base_types/compilation_unit.cmo : utils/misc.cmi \ + middle_end/base_types/linkage_name.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 utils/identifiable.cmx \ + typing/ident.cmx middle_end/base_types/compilation_unit.cmi +middle_end/base_types/export_id.cmo : 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 : 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/id_types.cmo : utils/identifiable.cmi \ + middle_end/base_types/id_types.cmi +middle_end/base_types/id_types.cmx : utils/identifiable.cmx \ + middle_end/base_types/id_types.cmi +middle_end/base_types/linkage_name.cmo : utils/identifiable.cmi \ + middle_end/base_types/linkage_name.cmi +middle_end/base_types/linkage_name.cmx : utils/identifiable.cmx \ + middle_end/base_types/linkage_name.cmi +middle_end/base_types/mutable_variable.cmo : utils/identifiable.cmi \ + typing/ident.cmi middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/mutable_variable.cmi +middle_end/base_types/mutable_variable.cmx : utils/identifiable.cmx \ + typing/ident.cmx middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/mutable_variable.cmi +middle_end/base_types/set_of_closures_id.cmo : 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 : 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/static_exception.cmo : utils/numbers.cmi \ + bytecomp/lambda.cmi middle_end/base_types/static_exception.cmi +middle_end/base_types/static_exception.cmx : utils/numbers.cmx \ + bytecomp/lambda.cmx middle_end/base_types/static_exception.cmi +middle_end/base_types/symbol.cmo : utils/misc.cmi \ + middle_end/base_types/linkage_name.cmi utils/identifiable.cmi \ + middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/symbol.cmi +middle_end/base_types/symbol.cmx : utils/misc.cmx \ + middle_end/base_types/linkage_name.cmx utils/identifiable.cmx \ + middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/symbol.cmi +middle_end/base_types/tag.cmo : utils/numbers.cmi utils/misc.cmi \ + utils/identifiable.cmi middle_end/base_types/tag.cmi +middle_end/base_types/tag.cmx : utils/numbers.cmx utils/misc.cmx \ + utils/identifiable.cmx middle_end/base_types/tag.cmi +middle_end/base_types/var_within_closure.cmo : \ + 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/base_types/closure_element.cmx \ + middle_end/base_types/var_within_closure.cmi +middle_end/base_types/variable.cmo : utils/misc.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 utils/identifiable.cmx \ + typing/ident.cmx middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/variable.cmi driver/compenv.cmi : driver/compile.cmi : driver/compmisc.cmi : typing/env.cmi driver/errors.cmi : -driver/main_args.cmi : driver/main.cmi : -driver/optcompile.cmi : +driver/main_args.cmi : +driver/optcompile.cmi : middle_end/backend_intf.cmi driver/opterrors.cmi : driver/optmain.cmi : driver/pparse.cmi : parsing/parsetree.cmi @@ -1041,8 +1873,6 @@ driver/compmisc.cmx : typing/typemod.cmx utils/misc.cmx \ parsing/asttypes.cmi driver/compmisc.cmi driver/errors.cmo : parsing/location.cmi driver/errors.cmi driver/errors.cmx : parsing/location.cmx driver/errors.cmi -driver/main_args.cmo : utils/warnings.cmi driver/main_args.cmi -driver/main_args.cmx : utils/warnings.cmx driver/main_args.cmi driver/main.cmo : utils/warnings.cmi utils/timings.cmi utils/misc.cmi \ driver/main_args.cmi parsing/location.cmi utils/config.cmi \ driver/compmisc.cmi driver/compile.cmi driver/compenv.cmi \ @@ -1053,44 +1883,50 @@ driver/main.cmx : utils/warnings.cmx utils/timings.cmx utils/misc.cmx \ driver/compmisc.cmx driver/compile.cmx driver/compenv.cmx \ utils/clflags.cmx bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \ bytecomp/bytelibrarian.cmx driver/main.cmi +driver/main_args.cmo : utils/warnings.cmi utils/clflags.cmi \ + driver/main_args.cmi +driver/main_args.cmx : utils/warnings.cmx utils/clflags.cmx \ + driver/main_args.cmi driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \ typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \ utils/timings.cmi typing/stypes.cmi bytecomp/simplif.cmi \ typing/printtyped.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \ parsing/printast.cmi parsing/pprintast.cmi driver/pparse.cmi \ - utils/misc.cmi typing/includemod.cmi typing/env.cmi utils/config.cmi \ - driver/compmisc.cmi asmcomp/compilenv.cmi driver/compenv.cmi \ - utils/clflags.cmi utils/ccomp.cmi parsing/builtin_attributes.cmi \ - asmcomp/asmgen.cmi driver/optcompile.cmi + utils/misc.cmi middle_end/middle_end.cmi typing/includemod.cmi \ + typing/env.cmi utils/config.cmi driver/compmisc.cmi asmcomp/compilenv.cmi \ + driver/compenv.cmi utils/clflags.cmi utils/ccomp.cmi \ + parsing/builtin_attributes.cmi asmcomp/asmgen.cmi driver/optcompile.cmi driver/optcompile.cmx : utils/warnings.cmx typing/typemod.cmx \ typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \ utils/timings.cmx typing/stypes.cmx bytecomp/simplif.cmx \ typing/printtyped.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \ parsing/printast.cmx parsing/pprintast.cmx driver/pparse.cmx \ - utils/misc.cmx typing/includemod.cmx typing/env.cmx utils/config.cmx \ - driver/compmisc.cmx asmcomp/compilenv.cmx driver/compenv.cmx \ - utils/clflags.cmx utils/ccomp.cmx parsing/builtin_attributes.cmx \ - asmcomp/asmgen.cmx driver/optcompile.cmi + utils/misc.cmx middle_end/middle_end.cmx typing/includemod.cmx \ + typing/env.cmx utils/config.cmx driver/compmisc.cmx asmcomp/compilenv.cmx \ + driver/compenv.cmx utils/clflags.cmx utils/ccomp.cmx \ + parsing/builtin_attributes.cmx asmcomp/asmgen.cmx driver/optcompile.cmi driver/opterrors.cmo : parsing/location.cmi driver/opterrors.cmi driver/opterrors.cmx : parsing/location.cmx driver/opterrors.cmi driver/optmain.cmo : utils/warnings.cmi utils/timings.cmi \ asmcomp/printmach.cmi driver/optcompile.cmi utils/misc.cmi \ - driver/main_args.cmi parsing/location.cmi utils/config.cmi \ - driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \ + driver/main_args.cmi parsing/location.cmi asmcomp/import_approx.cmi \ + utils/config.cmi driver/compmisc.cmi asmcomp/compilenv.cmi \ + driver/compenv.cmi utils/clflags.cmi middle_end/backend_intf.cmi \ asmcomp/asmpackager.cmi asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi \ asmcomp/arch.cmo driver/optmain.cmi driver/optmain.cmx : utils/warnings.cmx utils/timings.cmx \ asmcomp/printmach.cmx driver/optcompile.cmx utils/misc.cmx \ - driver/main_args.cmx parsing/location.cmx utils/config.cmx \ - driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \ + driver/main_args.cmx parsing/location.cmx asmcomp/import_approx.cmx \ + utils/config.cmx driver/compmisc.cmx asmcomp/compilenv.cmx \ + driver/compenv.cmx utils/clflags.cmx middle_end/backend_intf.cmi \ asmcomp/asmpackager.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx \ asmcomp/arch.cmx driver/optmain.cmi driver/pparse.cmo : utils/timings.cmi parsing/parse.cmi utils/misc.cmi \ parsing/location.cmi utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \ - parsing/ast_mapper.cmi driver/pparse.cmi + parsing/ast_mapper.cmi parsing/ast_invariants.cmi driver/pparse.cmi driver/pparse.cmx : utils/timings.cmx parsing/parse.cmx utils/misc.cmx \ parsing/location.cmx utils/config.cmx utils/clflags.cmx utils/ccomp.cmx \ - parsing/ast_mapper.cmx driver/pparse.cmi + parsing/ast_mapper.cmx parsing/ast_invariants.cmx driver/pparse.cmi toplevel/genprintval.cmi : typing/types.cmi typing/path.cmi \ typing/outcometree.cmi typing/env.cmi toplevel/opttopdirs.cmi : parsing/longident.cmi @@ -1136,11 +1972,13 @@ toplevel/opttoploop.cmo : utils/warnings.cmi typing/types.cmi \ parsing/printast.cmi typing/predef.cmi parsing/pprintast.cmi \ driver/pparse.cmi typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \ typing/outcometree.cmi typing/oprint.cmi utils/misc.cmi \ - parsing/longident.cmi parsing/location.cmi parsing/lexer.cmi \ - typing/includemod.cmi typing/ident.cmi toplevel/genprintval.cmi \ + middle_end/middle_end.cmi parsing/longident.cmi parsing/location.cmi \ + parsing/lexer.cmi bytecomp/lambda.cmi typing/includemod.cmi \ + asmcomp/import_approx.cmi typing/ident.cmi toplevel/genprintval.cmi \ typing/env.cmi utils/config.cmi driver/compmisc.cmi asmcomp/compilenv.cmi \ - utils/clflags.cmi typing/btype.cmi parsing/ast_helper.cmi \ - asmcomp/asmlink.cmi asmcomp/asmgen.cmi toplevel/opttoploop.cmi + utils/clflags.cmi typing/btype.cmi middle_end/backend_intf.cmi \ + parsing/asttypes.cmi parsing/ast_helper.cmi asmcomp/asmlink.cmi \ + asmcomp/asmgen.cmi asmcomp/arch.cmo toplevel/opttoploop.cmi toplevel/opttoploop.cmx : utils/warnings.cmx typing/types.cmx \ typing/typemod.cmx typing/typedtree.cmx typing/typecore.cmx \ bytecomp/translmod.cmx utils/timings.cmx bytecomp/simplif.cmx \ @@ -1148,11 +1986,13 @@ toplevel/opttoploop.cmx : utils/warnings.cmx typing/types.cmx \ parsing/printast.cmx typing/predef.cmx parsing/pprintast.cmx \ driver/pparse.cmx typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \ typing/outcometree.cmi typing/oprint.cmx utils/misc.cmx \ - parsing/longident.cmx parsing/location.cmx parsing/lexer.cmx \ - typing/includemod.cmx typing/ident.cmx toplevel/genprintval.cmx \ + middle_end/middle_end.cmx parsing/longident.cmx parsing/location.cmx \ + parsing/lexer.cmx bytecomp/lambda.cmx typing/includemod.cmx \ + asmcomp/import_approx.cmx typing/ident.cmx toplevel/genprintval.cmx \ typing/env.cmx utils/config.cmx driver/compmisc.cmx asmcomp/compilenv.cmx \ - utils/clflags.cmx typing/btype.cmx parsing/ast_helper.cmx \ - asmcomp/asmlink.cmx asmcomp/asmgen.cmx toplevel/opttoploop.cmi + utils/clflags.cmx typing/btype.cmx middle_end/backend_intf.cmi \ + parsing/asttypes.cmi parsing/ast_helper.cmx asmcomp/asmlink.cmx \ + asmcomp/asmgen.cmx asmcomp/arch.cmx toplevel/opttoploop.cmi toplevel/opttopmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \ toplevel/opttoploop.cmi toplevel/opttopdirs.cmi utils/misc.cmi \ driver/main_args.cmi parsing/location.cmi utils/config.cmi \ diff --git a/.gitattributes b/.gitattributes index 7836b6f21..94b2ca301 100644 --- a/.gitattributes +++ b/.gitattributes @@ -44,6 +44,11 @@ ocamldoc/ocamldoc.sty ocaml-typo=missing-header *.sh.in text eol=lf *.awk text eol=lf +# Test suite command fragments +*.checker text eol=lf +*.precheck text eol=lf +*.runner text eol=lf + configure text eol=lf config/auto-aux/hasgot text eol=lf config/auto-aux/hasgot2 text eol=lf @@ -79,3 +84,7 @@ manual/tools/htmlcut text eol=lf manual/tools/htmltbl text eol=lf manual/tools/htmlthread text eol=lf manual/tools/texexpand text eol=lf + +# Checking out the parsetree test files with \r\n endings causes all the +# locations to change, so use \n endings only, even on Windows +testsuite/tests/parsing/*.ml text eol=lf diff --git a/.gitignore b/.gitignore index 9c0da6d5f..1256e279f 100644 --- a/.gitignore +++ b/.gitignore @@ -17,6 +17,7 @@ .DS_Store *.out *.out.dSYM +*.swp # local to root directory @@ -133,6 +134,8 @@ /ocamlbuild/ocamlbuild_config.ml /ocamlbuild/lexers.ml /ocamlbuild/glob_lexer.ml +/ocamlbuild/ocamlbuild.native +/ocamlbuild/ocamlbuild.byte /ocamldoc/ocamldoc /ocamldoc/ocamldoc.opt @@ -213,6 +216,8 @@ /testsuite/**/program /testsuite/**/_log +/testsuite/_retries + /testsuite/tests/asmcomp/codegen /testsuite/tests/asmcomp/parsecmm.ml /testsuite/tests/asmcomp/parsecmm.mli @@ -238,6 +243,8 @@ /testsuite/tests/lib-threads/*.byt +/testsuite/tests/opaque/*/*.mli + /testsuite/tests/runtime-errors/*.bytecode /testsuite/tests/tool-debugger/**/compiler-libs @@ -245,10 +252,20 @@ /testsuite/tests/tool-debugger/no_debug_event/out /testsuite/tests/tool-debugger/no_debug_event/c +/testsuite/tests/tool-ocamldep-modalias/*.byt* +/testsuite/tests/tool-ocamldep-modalias/*.opt* +/testsuite/tests/tool-ocamldep-modalias/depend.mk +/testsuite/tests/tool-ocamldep-modalias/depend.mk2 +/testsuite/tests/tool-ocamldep-modalias/depend.mod +/testsuite/tests/tool-ocamldep-modalias/depend.mod2 +/testsuite/tests/tool-ocamldep-modalias/depend.mod3 + /testsuite/tests/tool-ocamldoc/*.html /testsuite/tests/tool-ocamldoc/*.sty /testsuite/tests/tool-ocamldoc/*.css +/testsuite/tests/tool-ocamldoc-2/ocamldoc.sty + /testsuite/tests/tool-lexyacc/scanner.ml /testsuite/tests/tool-lexyacc/grammar.mli /testsuite/tests/tool-lexyacc/grammar.ml diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 000000000..938e0dbed --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "flexdll"] + path = flexdll + url = https://github.com/alainfrisch/flexdll.git diff --git a/.merlin b/.merlin index 0442978ec..38628a474 100644 --- a/.merlin +++ b/.merlin @@ -1,6 +1,12 @@ S ./asmcomp B ./asmcomp +S ./middle_end +B ./middle_end + +S ./middle_end/base_types +B ./middle_end/base_types + S ./bytecomp B ./bytecomp diff --git a/.travis-ci.sh b/.travis-ci.sh index d73705c2f..aaf2feccd 100644 --- a/.travis-ci.sh +++ b/.travis-ci.sh @@ -29,11 +29,12 @@ control. ------------------------------------------------------------------------ EOF mkdir -p $PREFIX - ./configure --prefix $PREFIX + ./configure --prefix $PREFIX -with-debug-runtime -with-instrumented-runtime export PATH=$PREFIX/bin:$PATH make world.opt make install (cd testsuite && make all) + (cd testsuite && make USE_RUNTIME="d" all) mkdir external-packages cd external-packages git clone git://github.com/ocaml/camlp4 diff --git a/.travis.yml b/.travis.yml index b0a323af8..b5b1acc66 100644 --- a/.travis.yml +++ b/.travis.yml @@ -12,6 +12,8 @@ sudo: false language: c +git: + submodules: false script: bash -ex .travis-ci.sh matrix: include: diff --git a/Changes b/Changes index 6c65dcb67..a6e9c32d8 100644 --- a/Changes +++ b/Changes @@ -10,7 +10,7 @@ Language features: Namely, the redundancy checker now checks whether the uncovered pattern of the pattern is actually inhabited, exploding at most one wild card. This is also done for exhaustiveness when there is only one case. - Additionnally, one can now write unreachable cases, of the form, + Additionally, one can now write unreachable cases, of the form, "pat -> .", which are treated by the redundancy check. (Jacques Garrigue) - PR#6374: allow "_ t" as a short-hand for "(_, _, ..) t" for n-ary type constructors (Alain Frisch) @@ -24,6 +24,8 @@ Language features: - GPR#88: allow field punning in object copying expressions: {< x; y; >} is sugar for {< x = x; y = y; >} (Jeremy Yallop) +- GPR#112: octal escape sequences for char and string literals + (Rafaël Bocquet) - GPR#167: allow to annotate externals' arguments and result types so they can be unboxed or untagged. Supports untagging int and unboxing int32, int64, nativeint and float. @@ -58,6 +60,9 @@ Language features: - PR#6681 GPR#326: signature items are now accepted as payloads for extension and attributes, using the syntax [%foo: SIG ] or [@foo: SIG ]. (Alain Frisch and Gabriel Radanne) +* GPR#234: allow "[]" as a user-defined constructor. Demand parenthesis + around "::" when using "::" as user-defined constructor. + (Runhang Li, review by Damien Doligez) Compilers: - PR#4080, PR#6537, PR#5333: fix stack overflow in the compiler when -pack'ing @@ -84,6 +89,8 @@ Compilers: (Jérémie Dimino, Alain Frisch) * PR#6438: Pattern guard disables exhaustiveness check (Alain Frisch) +- PR#6920: fix debug informations around uses of %apply or %revapply + (Jérémie Dimino) - PR#6939: Segfault with improper use of let-rec (Alain Frisch) - PR#6943: native-code generator for POWER/PowerPC 64 bits, both in big-endian (ppc64) and little-endian (ppc64le) configuration. @@ -101,8 +108,8 @@ Compilers: - PR#7067: Performance regression in the native compiler for long nested structures (Alain Frisch, report by Daniel Bünzli, review by Jacques Garrigue) -- PR#7097: Strange syntax error message around illegal packaged module signature - constraints (Alain Frisch, report by Jun Furuse) +- PR#7097: Strange syntax error message around illegal packaged module + signature constraints (Alain Frisch, report by Jun Furuse) - GPR#17: some cmm optimizations of integer operations with constants (Stephen Dolan, review by Pierre Chambart) - GPR#109: new unboxing strategy for float and int references (Vladimir Brankov, @@ -111,6 +118,8 @@ Compilers: (Vladimir Brankov, review by Alain Frisch) - GPR#115: More precise typing of values at the C-- and Mach level,. (Xavier Leroy, review by Pierre Chambart) +- GPR#132: Flambda: new intermediate language and "middle-end" optimizers + (Pierre Chambart, Mark Shinwell, Leo White) - GPR#207: Colors in compiler messages (warnings, errors) (Simon Cruanes, review by Gabriel Scherer) - GPR#258: more precise information on PowerPC instruction sizes @@ -136,7 +145,14 @@ Compilers: - GPR#319: add warning for missing cmx files, and extend -opaque option to mli files. (Leo White) -- PR#6920: fix debug informations around uses of %apply or %revapply +- GPR#388: OCAML_FLEXLINK environment variable allows overriding flexlink + command (David Allsopp) +- GPR#407: don't display the name of compiled .c files when calling the + Microsoft C Compiler (same as the assembler). + (David Allsopp) +- GPR#431: permit constant float arrays to be eligible for pattern match + branch merging (Pierre Chambart) +- GPR#392: put all parsetree invariants in a new module Ast_invariants (Jérémie Dimino) Runtime system: @@ -227,10 +243,14 @@ Standard library: * Sys.time (and [@@noalloc]) * Pervasives.ldexp (and [@@noalloc]) * Pervasives.compare for float, nativeint, int32, int64. - (Bobot François) + (François Bobot) - GPR#329: Add exists, for_all, mem and memq functions in Array (Bernhard Schommer) +- GPR#337: Add [Hashtbl.filter_map_inplace] (Alain Frisch) - GPR#356: Add [Format.kasprintf] (Jérémie Dimino, Mark Shinwell) +- GPR#22: Add the Ephemeron module that implements ephemerons and weak + hash table (François Bobot, review by Damien Doligez, Daniel Bünzli, + Alain Frisch, Pierre Chambart) Type system: - PR#5545: Type annotations on methods cannot control the choice of abbreviation @@ -272,6 +292,9 @@ Other libraries: Before, a handled signal could cause Unix.sleep to return early. Now, the sleep is restarted until the given time is elapsed. (Xavier Leroy) +- PR#6263: add kind_size_in_bytes and size_in_bytes functions + to Bigarray module. + (Runhang Li, review by Mark Shinwell) - PR#6289: Unix.utimes uses the current time only if both arguments are exactly 0.0. Also, use sub-second resolution if available. (Xavier Leroy, report by Christophe Troestler) @@ -299,7 +322,7 @@ OCamlbuild: (Vincent Laporte) OCamldep: -- GRP#286: add support for module aliases +- GPR#286: add support for module aliases (jacques Garrigue) Manual: @@ -440,6 +463,12 @@ Bug fixes: Mark Shinwell) - GPR#283: Fix memory leaks in intern.c when OOM is raised (Marc Lasson, review by Alain Frisch) +- GPR#22: Fix the cleaning of weak pointers. In very rare cases + accessing a value during the cleaning of the weak pointers could + result in the value being removed from one weak arrays and kept in + another one. That breaks the property that a value is removed from a + weak pointer only when it is dead and garbage collected. (François + Bobot, review by Damien Doligez) - GPR#313: Prevent quadratic cases in CSE (Pierre Chambart, review by Xavier Leroy) - PR#6795, PR#6996: Make ocamldep report errors passed in @@ -449,6 +478,10 @@ Bug fixes: (Jérémie Dimino, Thomas Refis) - GPR#405: fix compilation under Visual Studio 2015 (David Allsopp) +- GPR#441: better type error location in presence of type constraints + (Thomas Refis, report by Arseniy Alekseyev) +- PR#7111: reject empty let bindings instead of printing incorrect syntax + (Jérémie Dimino) Features wishes: - PR#4518, GPR#29: change location format for reporting errors in ocamldoc @@ -515,10 +548,18 @@ Features wishes: (Hugo Heuzard) - GPR#308: add experimental support for NetBSD/arm (verified on RaspberryPi) (Rich Neswold) +- GPR#335: Type error messages specify if a type is abstract + because no corresponding cmi could be found. (Hugo Heuzard) - GPR#365: prevent printing just a single type variable on one side of a type error clash. (Hugo Heuzard) - GPR#383: configure: define _ALL_SOURCE for build on AIX7.1 (tkob) +- GPR#401: automatically retry failed test directories in the testsuite + (David Allsopp) + +Build system: +- GPR#388: FlexDLL added as a Git submodule and bootstrappable with the compiler + (David Allsopp) OCaml 4.02.3 (27 Jul 2015): --------------------------- diff --git a/Makefile b/Makefile index 860e3e491..2c1545e53 100644 --- a/Makefile +++ b/Makefile @@ -252,6 +252,10 @@ installopt: cd asmrun; $(MAKE) install cp ocamlopt $(INSTALL_BINDIR)/ocamlopt$(EXE) cd stdlib; $(MAKE) installopt + cp middle_end/*.cmi middle_end/*.cmt middle_end/*.cmti \ + $(INSTALL_COMPLIBDIR) + cp middle_end/base_types/*.cmi middle_end/base_types/*.cmt \ + middle_end/base_types/*.cmti $(INSTALL_COMPLIBDIR) cp asmcomp/*.cmi asmcomp/*.cmt asmcomp/*.cmti $(INSTALL_COMPLIBDIR) cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(INSTALL_COMPLIBDIR) if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKE) installopt); \ @@ -314,8 +318,9 @@ ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) # The native-code compiler -compilerlibs/ocamloptcomp.cma: $(ASMCOMP) - $(CAMLC) -a -o $@ $(ASMCOMP) +compilerlibs/ocamloptcomp.cma: $(MIDDLE_END) $(ASMCOMP) + $(CAMLC) -a -o $@ $(MIDDLE_END) $(ASMCOMP) + partialclean:: rm -f compilerlibs/ocamloptcomp.cma @@ -414,6 +419,7 @@ utils/config.ml: utils/config.mlp config/Makefile -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ -e 's|%%HOST%%|$(HOST)|' \ -e 's|%%TARGET%%|$(TARGET)|' \ + -e 's|%%FLAMBDA%%|$(FLAMBDA)|' \ utils/config.mlp > utils/config.ml partialclean:: @@ -466,8 +472,8 @@ partialclean:: # The native-code compiler compiled with itself -compilerlibs/ocamloptcomp.cmxa: $(ASMCOMP:.cmo=.cmx) - $(CAMLOPT) -a -o $@ $(ASMCOMP:.cmo=.cmx) +compilerlibs/ocamloptcomp.cmxa: $(MIDDLE_END:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx) + $(CAMLOPT) -a -o $@ $(MIDDLE_END:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx) partialclean:: rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a @@ -480,7 +486,7 @@ ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ partialclean:: rm -f ocamlopt.opt -$(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx): ocamlopt +$(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(MIDDLE_END:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx): ocamlopt # The numeric opcodes @@ -780,12 +786,13 @@ clean:: $(CAMLOPT) $(COMPFLAGS) -c $< partialclean:: - for d in utils parsing typing bytecomp asmcomp driver toplevel tools; \ + for d in utils parsing typing bytecomp asmcomp middle_end middle_end/base_types driver toplevel tools; \ do rm -f $$d/*.cm[ioxt] $$d/*.cmti $$d/*.annot $$d/*.[so] $$d/*~; done rm -f *~ depend: beforedepend - (for d in utils parsing typing bytecomp asmcomp driver toplevel; \ + (for d in utils parsing typing bytecomp asmcomp middle_end \ + middle_end/base_types driver toplevel; \ do $(CAMLDEP) $(DEPFLAGS) $$d/*.mli $$d/*.ml; \ done) > .depend diff --git a/Makefile.nt b/Makefile.nt index 3d469361d..74dd17a7b 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -18,6 +18,48 @@ include Makefile.shared defaultentry: @echo "Please refer to the installation instructions in file README.win32.adoc." +FLEXDLL_SUBMODULE_PRESENT:=$(wildcard flexdll/Makefile) +BOOT_FLEXLINK_CMD=$(if $(FLEXDLL_SUBMODULE_PRESENT),FLEXLINK_CMD="../boot/ocamlrun ../flexdll/flexlink.exe") +CAMLOPT:=$(if $(FLEXDLL_SUBMODULE_PRESENT),OCAML_FLEXLINK="boot/ocamlrun flexdll/flexlink.exe") $(CAMLOPT) + +# FlexDLL sources missing error messages +# Different git mechanism displayed depending on whether this source tree came +# from a git clone or a source tarball. + +# Displayed in all cases +flexdll-common-err: + @echo In order to bootstrap FlexDLL, you need to place the sources in flexdll + @echo This can either be done by downloading a source tarball from + @echo \ http://alain.frisch.fr/flexdll.html + +flexdll/Makefile: $(if $(wildcard flexdll/Makefile),,$(if $(wildcard .git),flexdll-common-err,flexdll-repo)) + @echo or by checking out the flexdll submodule with + @echo \ git submodule update --init + @false + +flexdll-repo: flexdll-common-err + @echo or by cloning the git repository + @echo \ git clone https://github.com/alainfrisch/flexdll.git + @echo + @false + +# Bootstrapping FlexDLL - leaves a bytecode image of flexlink.exe in flexdll/ +flexdll: flexdll/Makefile + cd byterun ; $(MAKEREC) BOOTSTRAPPING_FLEXLINK=yes ocamlrun$(EXE) + cp byterun/ocamlrun.exe boot/ocamlrun.exe + cd stdlib ; $(MAKEREC) COMPILER=../boot/ocamlc stdlib.cma std_exit.cmo + cd stdlib ; cp stdlib.cma std_exit.cmo *.cmi ../boot + cd flexdll ; $(MAKECMD) MSVC_DETECT=0 TOOLCHAIN=$(TOOLCHAIN) TOOLPREF=$(TOOLPREF) CHAINS=$(FLEXDLL_CHAIN) NATDYNLINK=false OCAMLOPT="../boot/ocamlrun ../boot/ocamlc -I ../boot" flexlink.exe support + cd byterun ; $(MAKEREC) clean + $(MAKEREC) partialclean + +flexlink.opt: + cd flexdll ; \ + mv flexlink.exe flexlink ; \ + $(MAKECMD) OCAML_FLEXLINK="../boot/ocamlrun ./flexlink" MSVC_DETECT=0 TOOLCHAIN=$(TOOLCHAIN) TOOLPREF=$(TOOLPREF) OCAMLOPT="../ocamlopt.opt -I ../stdlib" flexlink.exe ; \ + mv flexlink.exe flexlink.opt ; \ + mv flexlink flexlink.exe + # Recompile the system using the bootstrap compiler all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \ otherlibraries $(OCAMLBUILDBYTE) $(WITH_DEBUGGER) \ @@ -60,11 +102,11 @@ LIBFILES=stdlib.cma std_exit.cmo *.cmi camlheader # Start up the system from the distribution compiler coldstart: - cd byterun ; $(MAKEREC) all + cd byterun ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) all cp byterun/ocamlrun.exe boot/ocamlrun.exe - cd yacc ; $(MAKEREC) all + cd yacc ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) all cp yacc/ocamlyacc.exe boot/ocamlyacc.exe - cd stdlib ; $(MAKEREC) COMPILER=../boot/ocamlc all + cd stdlib ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) COMPILER=../boot/ocamlc all cd stdlib ; cp $(LIBFILES) ../boot # Build the core system: the minimum needed to make depend and bootstrap @@ -126,8 +168,10 @@ opt: $(MAKEREC) otherlibrariesopt ocamltoolsopt # Native-code versions of the tools +# If the submodule is initialised, then opt.opt will build a native flexlink opt.opt: core opt-core ocamlc.opt all ocamlopt.opt ocamllex.opt \ - ocamltoolsopt ocamltoolsopt.opt otherlibrariesopt $(OCAMLBUILDNATIVE) $(OCAMLDOC_OPT) + ocamltoolsopt ocamltoolsopt.opt otherlibrariesopt $(OCAMLBUILDNATIVE) \ + $(OCAMLDOC_OPT) $(if $(wildcard flexdll/Makefile),flexlink.opt) # Complete build using fast compilers world.opt: coldstart opt.opt @@ -177,17 +221,29 @@ installbyt: else :; fi if test -n "$(WITH_OCAMLBUILD)"; then (cd ocamlbuild; $(MAKE) install); \ else :; fi + if test -n "$(FLEXDLL_SUBMODULE_PRESENT)"; then $(MAKEREC) install-flexdll; \ + else :; fi cp config/Makefile $(INSTALL_LIBDIR)/Makefile.config cp README.adoc $(INSTALL_DISTRIB)/Readme.general.txt cp README.win32.adoc $(INSTALL_DISTRIB)/Readme.windows.txt cp LICENSE $(INSTALL_DISTRIB)/License.txt cp Changes $(INSTALL_DISTRIB)/Changes.txt +install-flexdll: +# The $(if ...) installs the correct .manifest file for MSVC and MSVC64 +# (GNU make doesn't have ifeq as a function, hence slightly convoluted use of filter-out) + cp flexdll/flexlink.exe $(if $(filter-out mingw,$(TOOLCHAIN)),flexdll/default$(filter-out _i386,_$(ARCH)).manifest) $(INSTALL_BINDIR)/ + cp flexdll/flexdll_*.$(O) $(INSTALL_LIBDIR) + # Installation of the native-code compiler installopt: cd asmrun ; $(MAKEREC) install cp ocamlopt $(INSTALL_BINDIR)/ocamlopt.exe cd stdlib ; $(MAKEREC) installopt + cp middle_end/*.cmi middle_end/*.cmt middle_end/*.cmti \ + $(INSTALL_COMPLIBDIR) + cp middle_end/base_types/*.cmi middle_end/base_types/*.cmt \ + middle_end/base_types/*.cmti $(INSTALL_COMPLIBDIR) cp asmcomp/*.cmi asmcomp/*.cmt asmcomp/*.cmti $(INSTALL_COMPLIBDIR) cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(INSTALL_COMPLIBDIR) if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKEREC) installopt); fi @@ -198,6 +254,7 @@ installopt: done if test -f ocamlopt.opt ; then $(MAKEREC) installoptopt; fi cd tools; $(MAKEREC) installopt + if test -f ocamlopt.opt -a -f flexdll/flexlink.opt ; then cp -f flexdll/flexlink.opt $(INSTALL_BINDIR)/flexlink.exe ; fi installoptopt: cp ocamlc.opt $(INSTALL_BINDIR)/ocamlc.opt$(EXE) @@ -237,8 +294,8 @@ partialclean:: # The native-code compiler -compilerlibs/ocamloptcomp.cma: $(ASMCOMP) - $(CAMLC) -a -o $@ $(ASMCOMP) +compilerlibs/ocamloptcomp.cma: $(MIDDLE_END) $(ASMCOMP) + $(CAMLC) -a -o $@ $(MIDDLE_END) $(ASMCOMP) partialclean:: rm -f compilerlibs/ocamloptcomp.cma @@ -313,6 +370,8 @@ utils/config.ml: utils/config.mlp config/Makefile -e 's|%%CC_PROFILE%%||' \ -e 's|%%HOST%%|$(HOST)|' \ -e 's|%%TARGET%%|$(TARGET)|' \ + -e 's|%%FLAMBDA%%|$(FLAMBDA)|' \ + -e 's|%%FLEXLINK_FLAGS%%|$(FLEXLINK_FLAGS)|' \ utils/config.mlp > utils/config.ml partialclean:: @@ -365,8 +424,8 @@ partialclean:: # The native-code compiler compiled with itself -compilerlibs/ocamloptcomp.cmxa: $(ASMCOMP:.cmo=.cmx) - $(CAMLOPT) -a -o $@ $(ASMCOMP:.cmo=.cmx) +compilerlibs/ocamloptcomp.cmxa: $(MIDDLE_END:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx) + $(CAMLOPT) -a -o $@ $(MIDDLE_END:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx) partialclean:: rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) @@ -379,7 +438,7 @@ ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ partialclean:: rm -f ocamlopt.opt -$(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx): ocamlopt +$(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(MIDDLE_END:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx): ocamlopt # The numeric opcodes @@ -489,7 +548,7 @@ partialclean:: runtime: makeruntime stdlib/libcamlrun.$(A) makeruntime: - cd byterun ; $(MAKEREC) all + cd byterun ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) all stdlib/libcamlrun.$(A): byterun/libcamlrun.$(A) cp byterun/libcamlrun.$(A) stdlib/libcamlrun.$(A) clean:: @@ -515,11 +574,11 @@ alldepend:: # The library library: - cd stdlib ; $(MAKEREC) all + cd stdlib ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) all library-cross: - cd stdlib ; $(MAKEREC) CAMLRUN=../byterun/ocamlrun all + cd stdlib ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) CAMLRUN=../byterun/ocamlrun all libraryopt: - cd stdlib ; $(MAKEREC) allopt + cd stdlib ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) allopt partialclean:: cd stdlib ; $(MAKEREC) clean alldepend:: @@ -537,7 +596,7 @@ alldepend:: cd lex ; $(MAKEREC) depend ocamlyacc: - cd yacc ; $(MAKEREC) all + cd yacc ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) all clean:: cd yacc ; $(MAKEREC) clean @@ -608,7 +667,7 @@ ocamlbuild.byte: ocamlc otherlibraries cd ocamlbuild && $(MAKE) all ocamlbuild.native: ocamlopt otherlibrariesopt - cd ocamlbuild && $(MAKE) allopt + cd ocamlbuild && $(if $(FLEXDLL_SUBMODULE_PRESENT),OCAML_FLEXLINK="../boot/ocamlrun ../flexdll/flexlink.exe") $(MAKE) allopt partialclean:: cd ocamlbuild && $(MAKE) clean @@ -640,12 +699,16 @@ partialclean:: rm -f typing/*.cm* typing/*.$(O) typing/*.$(S) rm -f bytecomp/*.cm* bytecomp/*.$(O) bytecomp/*.$(S) rm -f asmcomp/*.cm* asmcomp/*.$(O) asmcomp/*.$(S) + rm -f middle_end/*.cm* middle_end/*.$(O) middle_end/*.$(S) + rm -f middle_end/base_types/*.cm* middle_end/base_types/*.$(O) \ + middle_end/base_types/*.$(S) rm -f driver/*.cm* driver/*.$(O) driver/*.$(S) rm -f toplevel/*.cm* toplevel/*.$(O) toplevel/*.$(S) rm -f tools/*.cm* tools/*.$(O) tools/*.$(S) depend: beforedepend - (for d in utils parsing typing bytecomp asmcomp driver toplevel; \ + (for d in utils parsing typing bytecomp asmcomp middle_end \ + middle_end/base_types driver toplevel; \ do $(CAMLDEP) $(DEPFLAGS) $$d/*.mli $$d/*.ml; \ done) > .depend @@ -671,5 +734,6 @@ distclean: .PHONY: ocamltoolsopt.opt ocamlyacc opt-core opt opt.opt otherlibraries .PHONY: otherlibrariesopt promote promote-cross .PHONY: restore runtime runtimeopt makeruntimeopt world world.opt +.PHONY: flexdll flexlink.opt flexdll-common-err flexdll-repo include .depend diff --git a/Makefile.shared b/Makefile.shared index d3a846b49..542ec3569 100755 --- a/Makefile.shared +++ b/Makefile.shared @@ -20,7 +20,7 @@ include stdlib/StdlibModules CAMLC=$(CAMLRUN) boot/ocamlc -g -nostdlib -I boot CAMLOPT=$(CAMLRUN) ./ocamlopt -g -nostdlib -I stdlib -I otherlibs/dynlink COMPFLAGS=-strict-sequence -principal -w +33..39+48+50 -warn-error A -bin-annot \ - -safe-string $(INCLUDES) + -safe-string -strict-formats $(INCLUDES) LINKFLAGS= YACCFLAGS=-v @@ -33,13 +33,12 @@ OCAMLBUILDNATIVE=$(WITH_OCAMLBUILD:=.native) OCAMLDOC_OPT=$(WITH_OCAMLDOC:=.opt) -INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \ - -I toplevel +INCLUDES=-I utils -I parsing -I typing -I bytecomp -I middle_end \ + -I middle_end/base_types -I asmcomp -I driver -I toplevel -UTILS=utils/config.cmo utils/clflags.cmo \ - utils/misc.cmo \ - utils/identifiable.cmo utils/numbers.cmo \ - utils/tbl.cmo utils/timings.cmo \ +UTILS=utils/config.cmo utils/misc.cmo \ + utils/identifiable.cmo utils/numbers.cmo utils/arg_helper.cmo \ + utils/clflags.cmo utils/tbl.cmo utils/timings.cmo \ utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \ utils/consistbl.cmo \ utils/strongly_connected_components.cmo @@ -49,8 +48,8 @@ PARSING=parsing/location.cmo parsing/longident.cmo \ parsing/syntaxerr.cmo parsing/parser.cmo \ parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \ parsing/pprintast.cmo \ - parsing/ast_mapper.cmo parsing/attr_helper.cmo \ - parsing/builtin_attributes.cmo + parsing/ast_mapper.cmo parsing/ast_iterator.cmo parsing/attr_helper.cmo \ + parsing/builtin_attributes.cmo parsing/ast_invariants.cmo TYPING=typing/ident.cmo typing/path.cmo \ typing/primitive.cmo typing/types.cmo \ @@ -105,8 +104,17 @@ ASMCOMP=\ asmcomp/arch.cmo \ asmcomp/cmm.cmo asmcomp/printcmm.cmo \ asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \ - asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \ - asmcomp/closure.cmo asmcomp/strmatch.cmo asmcomp/cmmgen.cmo \ + asmcomp/clambda.cmo asmcomp/printclambda.cmo \ + asmcomp/export_info.cmo \ + asmcomp/export_info_for_pack.cmo \ + asmcomp/compilenv.cmo \ + asmcomp/closure.cmo \ + asmcomp/build_export_info.cmo \ + asmcomp/closure_offsets.cmo \ + asmcomp/flambda_to_clambda.cmo \ + asmcomp/import_approx.cmo \ + asmcomp/un_anf.cmo \ + asmcomp/strmatch.cmo asmcomp/cmmgen.cmo \ asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \ asmcomp/comballoc.cmo \ asmcomp/CSEgen.cmo asmcomp/CSE.cmo \ @@ -123,6 +131,58 @@ ASMCOMP=\ asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo \ driver/opterrors.cmo driver/optcompile.cmo +MIDDLE_END=\ + middle_end/base_types/tag.cmo \ + middle_end/base_types/linkage_name.cmo \ + middle_end/base_types/compilation_unit.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/closure_element.cmo \ + middle_end/base_types/closure_id.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/semantics_of_primitives.cmo \ + middle_end/allocated_const.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/augment_closures.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 + TOPLEVEL=toplevel/genprintval.cmo toplevel/toploop.cmo \ toplevel/trace.cmo toplevel/topdirs.cmo toplevel/topmain.cmo diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index b51ee0439..df8c57de9 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -12,6 +12,8 @@ (* From lambda to assembly code *) +[@@@ocaml.warning "+a-4-9-40-41-42"] + open Format open Config open Clflags @@ -35,8 +37,39 @@ let pass_dump_linear_if ppf flag message phrase = if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase; phrase -let clambda_dump_if ppf ulambda = - if !dump_clambda then Printclambda.clambda ppf ulambda; ulambda +let flambda_raw_clambda_dump_if ppf + ({ Flambda_to_clambda. expr = ulambda; preallocated_blocks = _; + structured_constants; exported = _; } as input) = + if !dump_rawclambda then + begin + Format.fprintf ppf "@.clambda (before Un_anf):@."; + Printclambda.clambda ppf ulambda; + Symbol.Map.iter (fun sym cst -> + Format.fprintf ppf "%a:@ %a@." + Symbol.print sym + Printclambda.structured_constant cst) + structured_constants + end; + if !dump_cmm then Format.fprintf ppf "@.cmm:@."; + input + +type clambda_and_constants = + Clambda.ulambda * + Clambda.preallocated_block list * + Clambda.preallocated_constant list + +let raw_clambda_dump_if ppf ((ulambda, _, structured_constants):clambda_and_constants) = + if !dump_rawclambda then + begin + Format.fprintf ppf "@.clambda (before Un_anf):@."; + Printclambda.clambda ppf ulambda; + List.iter (fun {Clambda.symbol; definition} -> + Format.fprintf ppf "%s:@ %a@." + symbol + Printclambda.structured_constant definition) + structured_constants + end; + if !dump_cmm then Format.fprintf ppf "@.cmm:@." let rec regalloc ppf round fd = if round > 50 then @@ -100,7 +133,8 @@ let compile_genfuns ppf f = | _ -> ()) (Cmmgen.generic_functions true [Compilenv.current_unit_infos ()]) -let compile_unit ~source_provenance asm_filename keep_asm obj_filename gen = +let compile_unit ~source_provenance _output_prefix asm_filename keep_asm + obj_filename gen = let create_asm = keep_asm || not !Emitaux.binary_backend_available in Emitaux.create_asm_file := create_asm; try @@ -124,20 +158,15 @@ let compile_unit ~source_provenance asm_filename keep_asm obj_filename gen = remove_file obj_filename; raise exn -let gen_implementation ?toplevel ~source_provenance ppf (size, lam) = - let main_module_block = - { - Clambda.symbol = Compilenv.make_symbol None; - exported = true; - tag = 0; - size; - } - in +let set_export_info (ulambda, prealloc, structured_constants, export) = + Compilenv.set_export_info export; + (ulambda, prealloc, structured_constants) + +let end_gen_implementation ?toplevel ~source_provenance ppf + (clambda:clambda_and_constants) = Emit.begin_assembly (); - Timings.(time (Clambda source_provenance)) (Closure.intro size) lam - ++ clambda_dump_if ppf - ++ Timings.(time (Cmm source_provenance)) - (fun clam -> Cmmgen.compunit (clam, [main_module_block], [])) + clambda + ++ Timings.(time (Cmm source_provenance)) Cmmgen.compunit ++ Timings.(time (Compile_phrases source_provenance)) (List.iter (compile_phrase ppf)) ++ (fun () -> ()); @@ -156,14 +185,69 @@ let gen_implementation ?toplevel ~source_provenance ppf (size, lam) = ); Emit.end_assembly () -let compile_implementation ?toplevel ~source_provenance prefixname ppf (size, lam) = +let flambda_gen_implementation ?toplevel ~source_provenance ~backend ppf + (program:Flambda.program) = + let export = Build_export_info.build_export_info ~backend program in + let (clambda, preallocated, constants) = + Timings.time (Flambda_pass ("backend", source_provenance)) (fun () -> + (program, export) + ++ Flambda_to_clambda.convert + ++ flambda_raw_clambda_dump_if ppf + ++ (fun { Flambda_to_clambda. expr; preallocated_blocks; + structured_constants; exported; } -> + (* "init_code" following the name used in + [Cmmgen.compunit_and_constants]. *) + Un_anf.apply expr ~what:"init_code", preallocated_blocks, + structured_constants, exported) + ++ set_export_info) () + in + let constants = + List.map (fun (symbol, definition) -> + { Clambda.symbol = Linkage_name.to_string (Symbol.label symbol); + exported = true; + definition }) + (Symbol.Map.bindings constants) + in + end_gen_implementation ?toplevel ~source_provenance ppf + (clambda, preallocated, constants) + +let lambda_gen_implementation ?toplevel ~source_provenance ppf + (lambda:Lambda.program) = + let clambda = Closure.intro lambda.main_module_block_size lambda.code in + let preallocated_block = + Clambda.{ + symbol = Compilenv.make_symbol None; + exported = true; + tag = 0; + size = lambda.main_module_block_size; + } + in + let clambda_and_constants = + clambda, [preallocated_block], [] + in + raw_clambda_dump_if ppf clambda_and_constants; + end_gen_implementation ?toplevel ~source_provenance ppf clambda_and_constants + +let compile_implementation_gen ?toplevel ~source_provenance prefixname + ppf gen_implementation program = let asmfile = if !keep_asm_file || !Emitaux.binary_backend_available then prefixname ^ ext_asm else Filename.temp_file "camlasm" ext_asm in - compile_unit ~source_provenance asmfile !keep_asm_file (prefixname ^ ext_obj) - (fun () -> gen_implementation ?toplevel ~source_provenance ppf (size, lam)) + compile_unit ~source_provenance prefixname asmfile !keep_asm_file + (prefixname ^ ext_obj) (fun () -> + gen_implementation ?toplevel ~source_provenance ppf program) + +let compile_implementation_clambda ?toplevel ~source_provenance prefixname + ppf (program:Lambda.program) = + compile_implementation_gen ?toplevel ~source_provenance prefixname + ppf lambda_gen_implementation program + +let compile_implementation_flambda ?toplevel ~source_provenance prefixname + ~backend ppf (program:Flambda.program) = + compile_implementation_gen ?toplevel ~source_provenance prefixname + ppf (flambda_gen_implementation ~backend) program (* Error report *) diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli index 939e21f90..721010b9d 100644 --- a/asmcomp/asmgen.mli +++ b/asmcomp/asmgen.mli @@ -12,10 +12,19 @@ (* From lambda to assembly code *) -val compile_implementation : +val compile_implementation_flambda : ?toplevel:(string -> bool) -> source_provenance:Timings.source_provenance -> - string -> Format.formatter -> int * Lambda.lambda -> unit + string -> + backend:(module Backend_intf.S) -> + Format.formatter -> Flambda.program -> unit + +val compile_implementation_clambda : + ?toplevel:(string -> bool) -> + source_provenance:Timings.source_provenance -> + string -> + Format.formatter -> Lambda.program -> unit + val compile_phrase : Format.formatter -> Cmm.phrase -> unit @@ -26,5 +35,6 @@ val report_error: Format.formatter -> error -> unit val compile_unit: source_provenance:Timings.source_provenance -> + string(*prefixname*) -> string(*asm file*) -> bool(*keep asm*) -> string(*obj file*) -> (unit -> unit) -> unit diff --git a/asmcomp/asmlibrarian.ml b/asmcomp/asmlibrarian.ml index 968e1de74..aadc9ed7e 100644 --- a/asmcomp/asmlibrarian.ml +++ b/asmcomp/asmlibrarian.ml @@ -22,6 +22,12 @@ type error = exception Error of error +let default_ui_export_info = + if Config.flambda then + Cmx_format.Flambda Export_info.empty + else + Cmx_format.Clambda Clambda.Value_unknown + let read_info name = let filename = try @@ -34,7 +40,7 @@ let read_info name = since the compiler will go looking directly for .cmx files. The linker, which is the only one that reads .cmxa files, does not need the approximation. *) - info.ui_approx <- Clambda.Value_unknown; + info.ui_export_info <- default_ui_export_info; (Filename.chop_suffix filename ".cmx" ^ ext_obj, (info, crc)) let create_archive file_list lib_name = diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 296aef62c..3697e6520 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -268,7 +268,7 @@ let link_shared ppf objfiles output_name = then output_name ^ ".startup" ^ ext_asm else Filename.temp_file "camlstartup" ext_asm in let startup_obj = output_name ^ ".startup" ^ ext_obj in - Asmgen.compile_unit ~source_provenance:Timings.Startup + Asmgen.compile_unit ~source_provenance:Timings.Startup output_name startup !Clflags.keep_startup_file startup_obj (fun () -> make_shared_startup_file ppf @@ -327,7 +327,7 @@ let link ppf objfiles output_name = then output_name ^ ".startup" ^ ext_asm else Filename.temp_file "camlstartup" ext_asm in let startup_obj = Filename.temp_file "camlstartup" ext_obj in - Asmgen.compile_unit ~source_provenance:Timings.Startup + Asmgen.compile_unit ~source_provenance:Timings.Startup output_name startup !Clflags.keep_startup_file startup_obj (fun () -> make_startup_file ppf units_tolink); Misc.try_finally diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index 8f71cd77a..cbd19b708 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -75,7 +75,8 @@ let check_units members = (* Make the .o file for the package *) -let make_package_object ppf members targetobj targetname coercion = +let make_package_object ppf members targetobj targetname coercion + ~backend = let objtemp = if !Clflags.keep_asm_file then chop_extension_if_any targetobj ^ ".pack" ^ Config.ext_obj @@ -91,10 +92,32 @@ let make_package_object ppf members targetobj targetname coercion = | PM_intf -> None | PM_impl _ -> Some(Ident.create_persistent m.pm_name)) members in - Asmgen.compile_implementation ~source_provenance:(Timings.Pack targetname) - (chop_extension_if_any objtemp) ppf - (Translmod.transl_store_package - components (Ident.create_persistent targetname) coercion); + let module_ident = Ident.create_persistent targetname in + let source_provenance = Timings.Pack targetname in + let prefixname = chop_extension_if_any objtemp in + if Config.flambda then begin + let size, lam = + Translmod.transl_package_flambda + components module_ident coercion + in + let flam = + Middle_end.middle_end ppf + ~source_provenance + ~prefixname + ~backend + ~size + ~module_ident + ~module_initializer:lam + in + Asmgen.compile_implementation_flambda ~source_provenance + prefixname ~backend ppf flam; + end else begin + let main_module_block_size, code = + Translmod.transl_store_package + components (Ident.create_persistent targetname) coercion in + Asmgen.compile_implementation_clambda ~source_provenance + prefixname ppf { Lambda.code; main_module_block_size; } + end; let objfiles = List.map (fun m -> chop_extension_if_any m.pm_file ^ Config.ext_obj) @@ -107,6 +130,18 @@ let make_package_object ppf members targetobj targetname coercion = (* Make the .cmx file for the package *) +let get_export_info ui = + assert(Config.flambda); + match ui.ui_export_info with + | Clambda _ -> assert false + | Flambda info -> info + +let get_approx ui = + assert(not Config.flambda); + match ui.ui_export_info with + | Flambda _ -> assert false + | Clambda info -> info + let build_package_cmx members cmxfile = let unit_names = List.map (fun m -> m.pm_name) members in @@ -122,7 +157,42 @@ let build_package_cmx members cmxfile = (fun m accu -> match m.pm_kind with PM_intf -> accu | PM_impl info -> info :: accu) members [] in + let pack_units = + List.fold_left + (fun set info -> + let unit_id = Compilenv.unit_id_from_name info.ui_name in + Compilation_unit.Set.add + (Compilenv.unit_for_global unit_id) set) + Compilation_unit.Set.empty units in + let units = + if Config.flambda then + List.map (fun info -> + { info with + ui_export_info = + Flambda + (Export_info_for_pack.import_for_pack ~pack_units + ~pack:(Compilenv.current_unit ()) + (get_export_info info)) }) + units + else + units + in let ui = Compilenv.current_unit_infos() in + let ui_export_info = + if Config.flambda then + let ui_export_info = + List.fold_left (fun acc info -> + Export_info.merge acc (get_export_info info)) + (Export_info_for_pack.import_for_pack ~pack_units + ~pack:(Compilenv.current_unit ()) + (get_export_info ui)) + units + in + Flambda ui_export_info + else + Clambda (get_approx ui) + in + Export_info_for_pack.clear_import_state (); let pkg_infos = { ui_name = ui.ui_name; ui_symbol = ui.ui_symbol; @@ -134,7 +204,6 @@ let build_package_cmx members cmxfile = filter(Asmlink.extract_crc_interfaces()); ui_imports_cmx = filter(Asmlink.extract_crc_implementations()); - ui_approx = ui.ui_approx; ui_curry_fun = union(List.map (fun info -> info.ui_curry_fun) units); ui_apply_fun = @@ -143,25 +212,26 @@ let build_package_cmx members cmxfile = union(List.map (fun info -> info.ui_send_fun) units); ui_force_link = List.exists (fun info -> info.ui_force_link) units; + ui_export_info; } in Compilenv.write_unit_info pkg_infos cmxfile (* Make the .cmx and the .o for the package *) let package_object_files ppf files targetcmx - targetobj targetname coercion = + targetobj targetname coercion ~backend = let pack_path = match !Clflags.for_package with | None -> targetname | Some p -> p ^ "." ^ targetname in let members = map_left_right (read_member_info pack_path) files in check_units members; - make_package_object ppf members targetobj targetname coercion; + make_package_object ppf members targetobj targetname coercion ~backend; build_package_cmx members targetcmx (* The entry point *) -let package_files ppf initial_env files targetcmx = +let package_files ppf initial_env files targetcmx ~backend = let files = List.map (fun f -> @@ -181,6 +251,7 @@ let package_files ppf initial_env files targetcmx = let coercion = Typemod.package_units initial_env files targetcmi targetname in package_object_files ppf files targetcmx targetobj targetname coercion + ~backend with x -> remove_file targetcmx; remove_file targetobj; raise x diff --git a/asmcomp/asmpackager.mli b/asmcomp/asmpackager.mli index 4d47f5c28..0021554e9 100644 --- a/asmcomp/asmpackager.mli +++ b/asmcomp/asmpackager.mli @@ -13,7 +13,13 @@ (* "Package" a set of .cmx/.o files into one .cmx/.o file having the original compilation units as sub-modules. *) -val package_files: Format.formatter -> Env.t -> string list -> string -> unit +val package_files + : Format.formatter + -> Env.t + -> string list + -> string + -> backend:(module Backend_intf.S) + -> unit type error = Illegal_renaming of string * string * string diff --git a/asmcomp/build_export_info.ml b/asmcomp/build_export_info.ml index cf4bed4bd..716e30d63 100644 --- a/asmcomp/build_export_info.ml +++ b/asmcomp/build_export_info.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module Env : sig type t @@ -494,12 +496,6 @@ let build_export_info ~(backend : (module Backend_intf.S)) let _global_symbol, env = describe_program (Env.Global.create_empty ()) program in - let globals = - let root_approx : Export_info.approx = - Value_symbol (Compilenv.current_unit_symbol ()) - in - Ident.Map.singleton (Compilenv.current_unit_id ()) root_approx - in let sets_of_closures = Flambda_utils.all_function_decls_indexed_by_set_of_closures_id program in @@ -540,7 +536,7 @@ let build_export_info ~(backend : (module Backend_intf.S)) let values = Export_info.nest_eid_map unnested_values in - Export_info.create ~values ~globals + Export_info.create ~values ~symbol_id:(Env.Global.symbol_to_export_id_map env) ~offset_fun:Closure_id.Map.empty ~offset_fv:Var_within_closure.Map.empty diff --git a/asmcomp/build_export_info.mli b/asmcomp/build_export_info.mli index c98df74d4..a0f8b571c 100644 --- a/asmcomp/build_export_info.mli +++ b/asmcomp/build_export_info.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** Construct export information, for emission into .cmx files, from an Flambda program. *) diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index dccecbc93..1beb69ecd 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -119,7 +119,7 @@ let prim_size prim args = | Praise _ -> 4 | Pstringlength -> 5 | Pstringrefs | Pstringsets -> 6 - | Pmakearray kind -> 5 + List.length args + | 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 @@ -1160,7 +1160,12 @@ and close_functions fenv cenv fun_defs = in let threshold = match inline_attribute with - | Default_inline -> !Clflags.inline_threshold + n + | 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 in diff --git a/asmcomp/closure_offsets.ml b/asmcomp/closure_offsets.ml index 4a1d3e278..57a5428ba 100644 --- a/asmcomp/closure_offsets.ml +++ b/asmcomp/closure_offsets.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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; diff --git a/asmcomp/closure_offsets.mli b/asmcomp/closure_offsets.mli index dbebffce7..1612953a5 100644 --- a/asmcomp/closure_offsets.mli +++ b/asmcomp/closure_offsets.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** Assign numerical offsets, within closure blocks, for code pointers and environment entries. *) diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 59c0d4799..7a2b18810 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -434,12 +434,6 @@ let safe_mod_bi = let test_bool = function Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c - | Cop(Clsl, [c; Cconst_int 1]) -> c - | Cconst_int n -> - if n = 1 then - Cconst_int 0 - else - Cconst_int 1 | c -> Cop(Ccmpi Cne, [c; Cconst_int 1]) (* Float *) @@ -699,9 +693,9 @@ let rec expr_size env = function expr_size env body | Uprim(Pmakeblock(tag, mut), args, _) -> RHS_block (List.length args) - | Uprim(Pmakearray(Paddrarray | Pintarray), args, _) -> + | Uprim(Pmakearray((Paddrarray | Pintarray), _), args, _) -> RHS_block (List.length args) - | Uprim(Pmakearray(Pfloatarray), args, _) -> + | Uprim(Pmakearray(Pfloatarray, _), args, _) -> RHS_floatblock (List.length args) | Uprim (Pduprecord ((Record_regular | Record_inlined _), sz), _, _) -> RHS_block sz @@ -709,6 +703,10 @@ let rec expr_size env = function RHS_block (sz + 1) | Uprim (Pduprecord (Record_float, sz), _, _) -> RHS_floatblock sz + | Uprim (Pccall { prim_name; _ }, closure::_, _) + when prim_name = "caml_check_value_is_closure" -> + (* Used for "-clambda-checks". *) + expr_size env closure | Usequence(exp, exp') -> expr_size env exp' | _ -> RHS_nonrec @@ -1516,19 +1514,27 @@ let rec transl env e = make_alloc tag (List.map (transl env) args) | (Pccall prim, args) -> transl_ccall env prim args dbg - | (Pmakearray kind, []) -> + | (Pduparray (kind, _), [Uprim (Pmakearray (kind', _), args, _dbg)]) -> + (* We arrive here in two cases: + 1. When using Closure, all the time. + 2. When using Flambda, if a float array longer than + [Translcore.use_dup_for_constant_arrays_bigger_than] turns out + to be non-constant. + If for some reason Flambda fails to lift a constant array we + could in theory also end up here. + Note that [kind] above is unconstrained, but with the current + state of [Translcore], we will in fact only get here with + [Pfloatarray]s. *) + assert (kind = kind'); + transl_make_array env kind args + | (Pduparray _, [arg]) -> + let prim_obj_dup = + Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true + in + transl_ccall env prim_obj_dup [arg] dbg + | (Pmakearray (kind, _), []) -> transl_structured_constant (Uconst_block(0, [])) - | (Pmakearray kind, args) -> - begin match kind with - Pgenarray -> - Cop(Cextcall("caml_make_array", typ_val, true, Debuginfo.none), - [make_alloc 0 (List.map (transl env) args)]) - | Paddrarray | Pintarray -> - make_alloc 0 (List.map (transl env) args) - | Pfloatarray -> - make_float_alloc Obj.double_array_tag - (List.map (transl_unbox_float env) args) - end + | (Pmakearray (kind, _), args) -> transl_make_array env kind args | (Pbigarrayref(unsafe, num_dims, elt_kind, layout), arg1 :: argl) -> let elt = bigarray_get unsafe elt_kind layout @@ -1678,6 +1684,17 @@ let rec transl env e = | Uunreachable -> Cop(Cload Word_int, [Cconst_int 0]) +and transl_make_array env kind args = + match kind with + | Pgenarray -> + Cop(Cextcall("caml_make_array", typ_val, true, Debuginfo.none), + [make_alloc 0 (List.map (transl env) args)]) + | Paddrarray | Pintarray -> + make_alloc 0 (List.map (transl env) args) + | Pfloatarray -> + make_float_alloc Obj.double_array_tag + (List.map (transl_unbox_float env) args) + and transl_ccall env prim args dbg = let transl_arg native_repr arg = match native_repr with @@ -1815,8 +1832,8 @@ and transl_prim_1 env p arg dbg = tag_int (Cop(Cextcall("caml_bswap16_direct", typ_int, false, Debuginfo.none), [untag_int (transl env arg)])) - | _ -> - fatal_error "Cmmgen.transl_prim_1" + | prim -> + fatal_errorf "Cmmgen.transl_prim_1: %a" Printlambda.primitive prim and transl_prim_2 env p arg1 arg2 dbg = match p with @@ -2087,8 +2104,8 @@ and transl_prim_2 env p arg1 arg2 dbg = tag_int (Cop(Ccmpi(transl_comparison cmp), [transl_unbox_int env bi arg1; transl_unbox_int env bi arg2])) - | _ -> - fatal_error "Cmmgen.transl_prim_2" + | prim -> + fatal_errorf "Cmmgen.transl_prim_2: %a" Printlambda.primitive prim and transl_prim_3 env p arg1 arg2 arg3 dbg = match p with @@ -2224,8 +2241,8 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg = (Cconst_int 7)) idx (unaligned_set_64 ba_data idx newval)))))) - | _ -> - fatal_error "Cmmgen.transl_prim_3" + | prim -> + fatal_errorf "Cmmgen.transl_prim_3: %a" Printlambda.primitive prim and transl_unbox_float env = function Uconst(Uconst_ref(_, Some (Uconst_float f))) -> Cconst_float f @@ -2413,9 +2430,15 @@ and transl_letrec env bindings cont = (* Translate a function definition *) let transl_function f = + let body = + if Config.flambda then + Un_anf.apply f.body ~what:f.label + else + f.body + in Cfunction {fun_name = f.label; fun_args = List.map (fun id -> (id, typ_val)) f.params; - fun_body = transl empty_env f.body; + fun_body = transl empty_env body; fun_fast = !Clflags.optimize_for_speed; fun_dbg = f.dbg; } @@ -2517,9 +2540,21 @@ and emit_boxed_int64_constant n cont = (* Emit constant closures *) -let emit_constant_closure symb fundecls clos_vars cont = +let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont = + let closure_symbol f = + if Config.flambda then + cdefine_symbol (f.label ^ "_closure", global_symb) + else + [] + in match fundecls with - [] -> assert false + [] -> + (* This should probably not happen: dead code has normally been + eliminated and a closure cannot be accessed without going through + a [Project_closure], which depends on the function. *) + assert (clos_vars = []); + cdefine_symbol symb @ + List.fold_right emit_constant clos_vars cont | f1 :: remainder -> let rec emit_others pos = function [] -> @@ -2527,11 +2562,13 @@ let emit_constant_closure symb fundecls clos_vars cont = | f2 :: rem -> if f2.arity = 1 || f2.arity = 0 then Cint(infix_header pos) :: + (closure_symbol f2) @ Csymbol_address f2.label :: cint_const f2.arity :: emit_others (pos + 3) rem else Cint(infix_header pos) :: + (closure_symbol f2) @ Csymbol_address(curry_function f2.arity) :: cint_const f2.arity :: Csymbol_address f2.label :: @@ -2539,6 +2576,7 @@ let emit_constant_closure symb fundecls clos_vars cont = Cint(black_closure_header (fundecls_size fundecls + List.length clos_vars)) :: cdefine_symbol symb @ + (closure_symbol f1) @ if f1.arity = 1 || f1.arity = 0 then Csymbol_address f1.label :: cint_const f1.arity :: @@ -2583,9 +2621,9 @@ let transl_all_functions_and_emit_all_constants cont = in aux StringSet.empty cont -(* Build the table of GC roots for toplevel modules *) +(* Build the NULL terminated array of gc roots *) -let emit_module_roots_table ~symbols cont = +let emit_gc_roots_table ~symbols cont = let table_symbol = Compilenv.make_symbol (Some "gc_roots") in Cdata(Cglobal_symbol table_symbol :: Cdefine_symbol table_symbol :: @@ -2621,7 +2659,7 @@ let emit_preallocated_blocks preallocated_blocks cont = List.map (fun ({ Clambda.symbol }:Clambda.preallocated_block) -> symbol) preallocated_blocks in - let c1 = emit_module_roots_table ~symbols cont in + let c1 = emit_gc_roots_table ~symbols cont in List.fold_left preallocate_block c1 preallocated_blocks (* Translate a compilation unit *) diff --git a/asmcomp/cmx_format.mli b/asmcomp/cmx_format.mli index 51aa04408..71878cb4b 100644 --- a/asmcomp/cmx_format.mli +++ b/asmcomp/cmx_format.mli @@ -1,14 +1,21 @@ -(***********************************************************************) -(* *) -(* 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 Q Public License version 1.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 *) @@ -22,6 +29,10 @@ 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 *) @@ -29,10 +40,10 @@ type unit_infos = mutable ui_imports_cmi: (string * Digest.t option) list; (* Interfaces imported *) mutable ui_imports_cmx:(string * Digest.t option) list; (* Infos imported *) - mutable ui_approx: Clambda.value_approximation; (* Approx of the structure*) 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 diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index fd5fe5071..f5e2f3b88 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -1,20 +1,28 @@ -(***********************************************************************) -(* *) -(* 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 Q Public License version 1.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 Misc -open Clambda open Cmx_format type error = @@ -26,6 +34,12 @@ 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 + : Flambda.function_declarations Set_of_closures_id.Tbl.t) let sourcefile = ref None @@ -54,17 +68,25 @@ 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_approx = Value_unknown; ui_curry_fun = []; ui_apply_fun = []; ui_send_fun = []; - ui_force_link = false } + ui_force_link = false; + ui_export_info = default_ui_export_info } let symbolname_for_pack pack name = match pack with @@ -80,9 +102,23 @@ let symbolname_for_pack pack name = 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 ~source_provenance:file 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 sourcefile := Some file; current_unit.ui_name <- name; @@ -95,7 +131,16 @@ let reset ?packname ~source_provenance:file name = current_unit.ui_send_fun <- []; current_unit.ui_force_link <- false; Hashtbl.clear exported_constants; - structured_constants := structured_constants_empty + 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 @@ -187,18 +232,26 @@ let cache_unit_info ui = (* Return the approximation of a global identifier *) -let toplevel_approx = Hashtbl.create 16 +let get_clambda_approx ui = + assert(not Config.flambda); + match ui.ui_export_info with + | Flambda _ -> assert false + | Clambda approx -> approx -let record_global_approx_toplevel id = - Hashtbl.add toplevel_approx current_unit.ui_name current_unit.ui_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_exn id then Value_unknown + if Ident.is_predef_exn id then Clambda.Value_unknown else try Hashtbl.find toplevel_approx (Ident.name id) with Not_found -> match get_global_info id with - | None -> Value_unknown - | Some ui -> ui.ui_approx + | None -> Clambda.Value_unknown + | Some ui -> get_clambda_approx ui (* Return the symbol used to refer to a global identifier *) @@ -217,8 +270,61 @@ let symbol_for_global id = (* 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_exn id then + Symbol.unsafe_create predefined_exception_compilation_unit sym_label + else + Symbol.unsafe_create (unit_for_global id) sym_label + let set_global_approx approx = - current_unit.ui_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_exn id + || not (Ident.global id) + then invalid_arg (Format.asprintf "approx_for_global %a" Ident.print id); + let modname = Ident.name id in + try Hashtbl.find export_infos_table modname with + | Not_found -> + let exported = match get_global_info id with + | None -> Export_info.empty + | Some ui -> get_flambda_export_info ui in + Hashtbl.add export_infos_table modname exported; + merged_environment := Export_info.merge !merged_environment exported; + exported + +let approx_env () = !merged_environment (* Record that a currying function or application function is needed *) @@ -227,6 +333,7 @@ let need_curry_fun n = 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 @@ -249,14 +356,19 @@ let save_unit_info filename = current_unit.ui_imports_cmi <- Env.imports(); write_unit_info current_unit filename +let current_unit_linkage_name () = + Linkage_name.create (make_symbol ~unitname:current_unit.ui_symbol None) +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.unsafe_create (current_unit ()) (current_unit_linkage_name ()) let const_label = ref 0 -let new_const_label () = - incr const_label; - !const_label - let new_const_symbol () = incr const_label; make_symbol (Some (string_of_int !const_label)) @@ -302,6 +414,24 @@ let structured_constants () = }) (!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.unsafe_create 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)) + (* Error report *) open Format diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index 0fd9dfac9..62b00acde 100644 --- a/asmcomp/compilenv.mli +++ b/asmcomp/compilenv.mli @@ -1,34 +1,63 @@ -(***********************************************************************) -(* *) -(* 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 Q Public License version 1.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 + : Flambda.function_declarations Set_of_closures_id.Tbl.t + (* flambda-only *) + val reset: ?packname:string -> source_provenance:Timings.source_provenance -> 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 *) + (* 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_build: unit -> Timings.source_provenance (* Return the kind of build source being compiled. If it is a file compilation it also provides the filename. *) +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). @@ -40,16 +69,36 @@ 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 *) - + (* 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 *) + (* 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 *) + (* 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 *) + (* Record the current approximation for the current toplevel phrase + clambda-only *) +val set_export_info: Export_info.t -> unit + (* Record the informations of the unit being compiled + flambda-only *) +val approx_env: unit -> Export_info.t + (* Returns all the information loaded from extenal compilation units + flambda-only *) +val approx_for_global: Compilation_unit.t -> Export_info.t + (* Loads the exported information declaring the compilation_unit + flambda-only *) val need_curry_fun: int -> unit val need_apply_fun: int -> unit @@ -58,7 +107,13 @@ val need_send_fun: int -> unit message sending) function with the given arity *) val new_const_symbol : unit -> string -val new_const_label : unit -> int +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 -> @@ -68,11 +123,13 @@ 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. *) diff --git a/asmcomp/export_info.ml b/asmcomp/export_info.ml index 2f629b2a7..10caf0ffd 100644 --- a/asmcomp/export_info.ml +++ b/asmcomp/export_info.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + type value_string_contents = | Contents of string | Unknown_or_mutable @@ -133,7 +135,6 @@ type t = { sets_of_closures : Flambda.function_declarations Set_of_closures_id.Map.t; closures : Flambda.function_declarations Closure_id.Map.t; values : descr Export_id.Map.t Compilation_unit.Map.t; - globals : approx Ident.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; @@ -145,7 +146,6 @@ let empty : t = { sets_of_closures = Set_of_closures_id.Map.empty; closures = Closure_id.Map.empty; values = Compilation_unit.Map.empty; - globals = Ident.Map.empty; symbol_id = Symbol.Map.empty; offset_fun = Closure_id.Map.empty; offset_fv = Var_within_closure.Map.empty; @@ -153,13 +153,12 @@ let empty : t = { invariant_params = Set_of_closures_id.Map.empty; } -let create ~sets_of_closures ~closures ~values ~globals ~symbol_id +let create ~sets_of_closures ~closures ~values ~symbol_id ~offset_fun ~offset_fv ~constant_sets_of_closures ~invariant_params = { sets_of_closures; closures; values; - globals; symbol_id; offset_fun; offset_fv; @@ -186,7 +185,6 @@ let merge (t1 : t) (t2 : t) : t = in let int_eq (i : int) j = i = j in { values = eidmap_disjoint_union ~eq:equal_descr t1.values t2.values; - globals = Ident.Map.disjoint_union t1.globals t2.globals; sets_of_closures = Set_of_closures_id.Map.disjoint_union t1.sets_of_closures t2.sets_of_closures; @@ -314,9 +312,6 @@ let print_approx ppf (t : t) = print_approx approx) bound_vars in - let print_approxs id approx = - fprintf ppf "%a -> %a;@ " Ident.print id print_approx approx - in let rec print_recorded_symbols () = if not (Queue.is_empty symbols_to_print) then begin let sym = Queue.pop symbols_to_print in @@ -331,7 +326,6 @@ let print_approx ppf (t : t) = end in fprintf ppf "@[Globals:@ "; - Ident.Map.iter print_approxs t.globals; fprintf ppf "@]@ @[Symbols:@ "; print_recorded_symbols (); fprintf ppf "@]" diff --git a/asmcomp/export_info.mli b/asmcomp/export_info.mli index 5568be61d..3909e9652 100644 --- a/asmcomp/export_info.mli +++ b/asmcomp/export_info.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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. *) @@ -80,9 +82,6 @@ type t = private { (** Code of exported functions indexed by closure IDs. *) values : descr Export_id.Map.t Compilation_unit.Map.t; (** Structure of exported values. *) - globals : approx Ident.Map.t; - (** Global variables provided by the unit: usually only the top-level - module identifier, but packs may contain more than one. *) symbol_id : Export_id.t Symbol.Map.t; (** Associates symbols and values. *) offset_fun : int Closure_id.Map.t; @@ -104,7 +103,6 @@ val create : sets_of_closures:Flambda.function_declarations Set_of_closures_id.Map.t -> closures:Flambda.function_declarations Closure_id.Map.t -> values:descr Export_id.Map.t Compilation_unit.Map.t - -> globals:approx Ident.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 diff --git a/asmcomp/export_info_for_pack.ml b/asmcomp/export_info_for_pack.ml index 9d6dfe139..3d62f84ee 100644 --- a/asmcomp/export_info_for_pack.ml +++ b/asmcomp/export_info_for_pack.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + let rename_id_state = Export_id.Tbl.create 100 (* Rename export identifiers' compilation units to denote that they now @@ -115,7 +117,6 @@ let import_eidmap_for_pack units pack f map = 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_approx = import_approx_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 sets_of_closures = @@ -123,15 +124,8 @@ let import_for_pack ~pack_units ~pack (exp : Export_info.t) = (import_function_declarations_for_pack pack_units pack) exp.sets_of_closures in - (* The only reachable global identifier of a pack is the pack itself. *) - let globals = - Ident.Map.filter (fun unit _ -> - Ident.same (Compilation_unit.get_persistent_ident pack) unit) - exp.globals - in Export_info.create ~sets_of_closures ~closures:(Flambda_utils.make_closure_map' sets_of_closures) - ~globals:(Ident.Map.map import_approx globals) ~offset_fun:exp.offset_fun ~offset_fv:exp.offset_fv ~values:(import_eidmap import_descr exp.values) diff --git a/asmcomp/export_info_for_pack.mli b/asmcomp/export_info_for_pack.mli index 8ffe3098b..811a741d3 100644 --- a/asmcomp/export_info_for_pack.mli +++ b/asmcomp/export_info_for_pack.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** Transformations on export information that are only used for the building of packs. *) diff --git a/asmcomp/flambda_to_clambda.ml b/asmcomp/flambda_to_clambda.ml index dcecaaecd..42945d948 100644 --- a/asmcomp/flambda_to_clambda.ml +++ b/asmcomp/flambda_to_clambda.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + type for_one_or_more_units = { fun_offset_table : int Closure_id.Map.t; fv_offset_table : int Var_within_closure.Map.t; @@ -660,6 +662,7 @@ let convert (program, exported) : result = List.map (fun (symbol, tag, fields) -> { Clambda. symbol = Linkage_name.to_string (Symbol.label symbol); + exported = true; tag = Tag.to_int tag; size = List.length fields; }) diff --git a/asmcomp/flambda_to_clambda.mli b/asmcomp/flambda_to_clambda.mli index e6c6023b6..2c2bd9da6 100644 --- a/asmcomp/flambda_to_clambda.mli +++ b/asmcomp/flambda_to_clambda.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + type result = { expr : Clambda.ulambda; preallocated_blocks : Clambda.preallocated_block list; diff --git a/asmcomp/import_approx.ml b/asmcomp/import_approx.ml index 40565b4ac..69628235f 100644 --- a/asmcomp/import_approx.ml +++ b/asmcomp/import_approx.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module A = Simple_value_approx let import_set_of_closures = diff --git a/asmcomp/import_approx.mli b/asmcomp/import_approx.mli index 185b8ff32..eb4ab705c 100644 --- a/asmcomp/import_approx.mli +++ b/asmcomp/import_approx.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** Create simple value approximations from the export information in .cmx files. *) diff --git a/asmcomp/un_anf.ml b/asmcomp/un_anf.ml index ec753445d..c8f1ac888 100644 --- a/asmcomp/un_anf.ml +++ b/asmcomp/un_anf.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-30-40-41-42"] + (* We say that an [Ident.t] is "linear" iff: (a) it is used exactly once; (b) it is never assigned to (using [Uassign]). @@ -731,20 +733,17 @@ and un_anf_array ident_info env clams : Clambda.ulambda array = Array.map (un_anf ident_info env) clams let apply clam ~what = - if not Config.flambda then clam - else begin - let ident_info = make_ident_info clam in - let let_bound_vars_that_can_be_moved = - let_bound_vars_that_can_be_moved ident_info clam - in - let clam = - substitute_let_moveable let_bound_vars_that_can_be_moved - Ident.Map.empty clam - in - let ident_info = make_ident_info clam in - let clam = un_anf ident_info Ident.Map.empty clam in - if !Clflags.dump_clambda then begin - Format.eprintf "@.un-anf (%s):@ %a@." what Printclambda.clambda clam - end; - clam - end + let ident_info = make_ident_info clam in + let let_bound_vars_that_can_be_moved = + let_bound_vars_that_can_be_moved ident_info clam + in + let clam = + substitute_let_moveable let_bound_vars_that_can_be_moved + Ident.Map.empty clam + in + let ident_info = make_ident_info clam in + let clam = un_anf ident_info Ident.Map.empty clam in + if !Clflags.dump_clambda then begin + Format.eprintf "@.un-anf (%s):@ %a@." what Printclambda.clambda clam + end; + clam diff --git a/asmrun/Makefile b/asmrun/Makefile index 32c00597b..32479e1be 100644 --- a/asmrun/Makefile +++ b/asmrun/Makefile @@ -29,7 +29,7 @@ COBJS=startup_aux.o startup.o \ gc_ctrl.o terminfo.o md5.o obj.o lexing.o printexc.o callback.o weak.o \ compact.o finalise.o custom.o $(UNIX_OR_WIN32).o backtrace_prim.o \ backtrace.o \ - natdynlink.o debugger.o meta.o dynlink.o + natdynlink.o debugger.o meta.o dynlink.o clambda_checks.o ASMOBJS=$(ARCH).o diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt index 4a1056f6c..8a6b8407a 100644 --- a/asmrun/Makefile.nt +++ b/asmrun/Makefile.nt @@ -25,7 +25,7 @@ COBJS=startup_aux.$(O) startup.$(O) \ md5.$(O) obj.$(O) lexing.$(O) win32.$(O) printexc.$(O) callback.$(O) \ weak.$(O) compact.$(O) finalise.$(O) custom.$(O) globroots.$(O) \ backtrace_prim.$(O) backtrace.$(O) \ - natdynlink.$(O) debugger.$(O) meta.$(O) dynlink.$(O) + natdynlink.$(O) debugger.$(O) meta.$(O) dynlink.$(O) clambda_checks.$(O) LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \ compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \ diff --git a/asmrun/signals_asm.c b/asmrun/signals_asm.c index 3dd32b625..a0b71b63a 100644 --- a/asmrun/signals_asm.c +++ b/asmrun/signals_asm.c @@ -67,7 +67,6 @@ extern char caml_system__code_begin, caml_system__code_end; void caml_garbage_collection(void) { - CAMLassert (caml_young_ptr >= caml_young_alloc_start); caml_young_limit = caml_young_trigger; if (caml_requested_major_slice || caml_requested_minor_gc || caml_young_ptr - caml_young_trigger < Max_young_whsize){ diff --git a/boot/ocamlc b/boot/ocamlc index 21f16c8c5..c893a8f7e 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamldep b/boot/ocamldep index 92571f5e7..6432b6b2a 100755 Binary files a/boot/ocamldep and b/boot/ocamldep differ diff --git a/boot/ocamllex b/boot/ocamllex index 63cfe7bec..080b27d4d 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 8e2ff27f5..403b27ab6 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -153,10 +153,11 @@ let rec size_of_lambda = function | Llet(str, id, arg, body) -> size_of_lambda body | Lletrec(bindings, body) -> size_of_lambda body | Lprim(Pmakeblock(tag, mut), args) -> RHS_block (List.length args) - | Lprim (Pmakearray (Paddrarray|Pintarray), args) -> + | Lprim (Pmakearray ((Paddrarray|Pintarray), _), args) -> RHS_block (List.length args) - | Lprim (Pmakearray Pfloatarray, args) -> RHS_floatblock (List.length args) - | Lprim (Pmakearray Pgenarray, args) -> assert false + | Lprim (Pmakearray (Pfloatarray, _), args) -> + RHS_floatblock (List.length args) + | Lprim (Pmakearray (Pgenarray, _), args) -> assert false | Lprim (Pduprecord ((Record_regular | Record_inlined _), size), args) -> RHS_block size | Lprim (Pduprecord (Record_extension, size), args) -> @@ -632,7 +633,7 @@ let rec comp_expr env exp sz cont = (Kpush:: Kconst (Const_base (Const_int n)):: Kaddint::cont) - | Lprim(Pmakearray kind, args) -> + | Lprim(Pmakearray (kind, _), args) -> begin match kind with Pintarray | Paddrarray -> comp_args env args sz (Kmakeblock(List.length args, 0) :: cont) @@ -645,6 +646,16 @@ let rec comp_expr env exp sz cont = (Kmakeblock(List.length args, 0) :: Kccall("caml_make_array", 1) :: cont) end + | Lprim (Pduparray (kind, mutability), [Lprim (Pmakearray (kind', _), args)]) -> + assert (kind = kind'); + comp_expr env (Lprim (Pmakearray (kind, mutability), args)) sz cont + | Lprim (Pduparray _, [arg]) -> + let prim_obj_dup = + Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true + in + comp_expr env (Lprim (Pccall prim_obj_dup, [arg])) sz cont + | Lprim (Pduparray _, _) -> + Misc.fatal_error "Bytegen.comp_expr: Pduparray takes exactly one arg" (* Integer first for enabling futher optimization (cf. emitcode.ml) *) | Lprim (Pintcomp c, [arg ; (Lconst _ as k)]) -> let p = Pintcomp (commute_comparison c) diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index d8493ab32..b54a3689f 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -265,8 +265,7 @@ let package_files ppf initial_env files targetfile = try let coercion = Typemod.package_units initial_env files targetcmi targetname in - let ret = package_object_files ppf files targetfile targetname coercion in - ret + package_object_files ppf files targetfile targetname coercion with x -> remove_file targetfile; raise x diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index 1a9678286..f74b6568e 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -77,7 +77,8 @@ type primitive = (* String operations *) | Pstringlength | Pstringrefu | Pstringsetu | Pstringrefs | Pstringsets (* Array operations *) - | Pmakearray of array_kind + | Pmakearray of array_kind * mutable_flag + | Pduparray of array_kind * mutable_flag | Parraylength of array_kind | Parrayrefu of array_kind | Parraysetu of array_kind @@ -242,6 +243,10 @@ and lambda_event_kind = | Lev_after of Types.type_expr | Lev_function +type program = + { code : lambda; + main_module_block_size : int; } + let const_unit = Const_pointer 0 let lambda_unit = Lconst const_unit @@ -274,7 +279,7 @@ let make_key e = try Ident.find_same id env with Not_found -> e end - | Lconst (Const_base (Const_string _)|Const_float_array _) -> + | Lconst (Const_base (Const_string _)) -> (* Mutable constants are not shared *) raise Not_simple | Lconst _ -> e diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index 23ab36604..389a45b0e 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -80,7 +80,11 @@ type primitive = (* String operations *) | Pstringlength | Pstringrefu | Pstringsetu | Pstringrefs | Pstringsets (* Array operations *) - | Pmakearray of array_kind + | 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 @@ -255,6 +259,12 @@ and lambda_event_kind = | Lev_after of Types.type_expr | Lev_function +type program = + { code : lambda; + main_module_block_size : int; } +(* Lambda code for the Closure middle-end. The main module block size + is required for preallocating the block *) + (* Sharing key *) val make_key: lambda -> lambda option diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index a34b9c2aa..c8f297828 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -177,7 +177,10 @@ let primitive ppf = function | Pstringrefs -> fprintf ppf "string.get" | Pstringsets -> fprintf ppf "string.set" | Parraylength k -> fprintf ppf "array.length[%s]" (array_kind k) - | Pmakearray k -> fprintf ppf "makearray[%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) @@ -313,6 +316,7 @@ let name_of_primitive = function | Pstringsets -> "Pstringsets" | Parraylength _ -> "Parraylength" | Pmakearray _ -> "Pmakearray" + | Pduparray _ -> "Pduparray" | Parrayrefu _ -> "Parrayrefu" | Parraysetu _ -> "Parraysetu" | Parrayrefs _ -> "Parrayrefs" @@ -528,3 +532,5 @@ and sequence ppf = function 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 index 2748cb9e0..de6d335d7 100644 --- a/bytecomp/printlambda.mli +++ b/bytecomp/printlambda.mli @@ -16,5 +16,6 @@ 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 diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml index 90dfde253..85b777bed 100644 --- a/bytecomp/switch.ml +++ b/bytecomp/switch.ml @@ -375,8 +375,7 @@ let ok_inter = ref false let rec opt_count top cases = let key = make_key cases in try - let r = Hashtbl.find t key in - r + Hashtbl.find t key with | Not_found -> let r = @@ -813,8 +812,7 @@ let do_zyva (low,high) arg cases actions = *) let n_clusters,k = comp_clusters s in let clusters = make_clusters s n_clusters k in - let r = c_test {arg=arg ; off=0} clusters in - r + c_test {arg=arg ; off=0} clusters let abstract_shared actions = let handlers = ref (fun x -> x) in diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index cf63d7d8b..8e8fb6a9f 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -30,6 +30,8 @@ type error = 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) : @@ -444,8 +446,8 @@ let check_recursive_lambda idlist lam = let idlist' = add_letrec bindings idlist in List.for_all (fun (id, arg) -> check idlist' arg) bindings && check_top idlist' body - | Lprim (Pmakearray (Pgenarray), args) -> false - | Lprim (Pmakearray Pfloatarray, args) -> + | Lprim (Pmakearray (Pgenarray, _), args) -> false + | Lprim (Pmakearray (Pfloatarray, _), args) -> List.for_all (check idlist) args | Lsequence (lam1, lam2) -> check idlist lam1 && check_top idlist lam2 | Levent (lam, _) -> check_top idlist lam @@ -464,8 +466,8 @@ let check_recursive_lambda idlist lam = check idlist' body | Lprim(Pmakeblock(tag, mut), args) -> List.for_all (check idlist) args - | Lprim (Pmakearray Pfloatarray, _) -> false - | Lprim(Pmakearray(_), args) -> + | Lprim (Pmakearray (Pfloatarray, _), _) -> false + | Lprim (Pmakearray _, args) -> List.for_all (check idlist) args | Lsequence (lam1, lam2) -> check idlist lam1 && check idlist lam2 | Levent (lam, _) -> check idlist lam @@ -849,20 +851,43 @@ and transl_exp0 e = 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 <= 4 then raise Not_constant; - let cl = List.map extract_constant ll in - let master = - match kind with - | Paddrarray | Pintarray -> - Lconst(Const_block(0, cl)) - | Pfloatarray -> - Lconst(Const_float_array(List.map extract_float cl)) - | Pgenarray -> - raise Not_constant in (* can this really happen? *) - Lprim(Pccall prim_obj_dup, [master]) + 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) in + Lprim (Pduparray (kind, Mutable), [imm_array]) + | 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]) + end with Not_constant -> - Lprim(Pmakearray kind, ll) + Lprim(Pmakearray (kind, Mutable), ll) end | Texp_ifthenelse(cond, ifso, Some ifnot) -> Lifthenelse(transl_exp cond, @@ -1203,7 +1228,7 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr = match repres with Record_regular -> Lprim(Pmakeblock(0, mut), ll) | Record_inlined tag -> Lprim(Pmakeblock(tag, mut), ll) - | Record_float -> Lprim(Pmakearray Pfloatarray, ll) + | Record_float -> Lprim(Pmakearray (Pfloatarray, mut), ll) | Record_extension -> let path = match all_labels.(0).lbl_res.desc with diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 7f30b5fea..8a77cb817 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -566,13 +566,13 @@ let transl_implementation_flambda module_name (str, cc) = Hashtbl.clear used_primitives; let module_id = Ident.create_persistent module_name in let body, size = - transl_label_init + Translobj.transl_label_init (fun () -> transl_struct [] cc (global_path module_id) str) in - module_id, (wrap_globals body, size) + (module_id, size), wrap_globals body let transl_implementation module_name (str, cc) = - let module_id, (module_initializer, _size) = + let (module_id, _size), module_initializer = transl_implementation_flambda module_name (str, cc) in Lprim (Psetglobal module_id, [module_initializer]) @@ -907,7 +907,8 @@ let transl_store_implementation module_name (str, restr) = transl_store_subst := Ident.empty; let (i, r) = transl_store_gen module_name (str, restr) false in transl_store_subst := s; - (i, wrap_globals r) + { Lambda.main_module_block_size = i; + code = wrap_globals r; } (* Compile a toplevel phrase *) @@ -1024,6 +1025,19 @@ let get_component = function None -> Lconst const_unit | Some id -> Lprim(Pgetglobal id, []) +let transl_package_flambda component_names target_name 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 Strict coercion + (Lprim(Pmakeblock(0, Immutable), List.map get_component component_names)) + let transl_package component_names target_name coercion = let components = Lprim(Pmakeblock(0, Immutable), List.map get_component component_names) in diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli index 1d84aaabd..b63fa8719 100644 --- a/bytecomp/translmod.mli +++ b/bytecomp/translmod.mli @@ -19,13 +19,20 @@ open Lambda val transl_implementation: string -> structure * module_coercion -> lambda val transl_store_phrases: string -> structure -> int * lambda val transl_store_implementation: - string -> structure * module_coercion -> int * lambda + string -> structure * module_coercion -> Lambda.program + +val transl_implementation_flambda: + string -> structure * module_coercion -> (Ident.t * int) * lambda + 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 -> Ident.t -> module_coercion -> int * lambda + val toplevel_name: Ident.t -> string val nat_toplevel_name: Ident.t -> Ident.t * int diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index 5fe306e21..10bd5397e 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -107,7 +107,26 @@ let transl_label_init_general f = reset_labels (); expr, size +let transl_label_init_flambda f = + assert(Config.flambda); + let method_cache_id = Ident.create "method_cache" in + method_cache := Lvar method_cache_id; + (* Calling f (usualy 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, method_cache_id, + Lprim (Pccall prim_makearray, [int !method_count; int 0]), + 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, [])]); let expr = f arg in let (size, expr) = @@ -123,7 +142,10 @@ let transl_store_label_init glob size f arg = size, lam let transl_label_init f = - transl_label_init_general f + if !Clflags.native_code then + transl_label_init_flambda f + else + transl_label_init_general f (* Share classes *) diff --git a/byterun/Makefile.nt b/byterun/Makefile.nt index 257e36441..07a7bf323 100644 --- a/byterun/Makefile.nt +++ b/byterun/Makefile.nt @@ -15,13 +15,20 @@ include Makefile.common CFLAGS=-DOCAML_STDLIB_DIR='"$(LIBDIR)"' $(IFLEXDIR) +ifdef BOOTSTRAPPING_FLEXLINK +MAKE_OCAMLRUN=$(MKEXE_BOOT) +CFLAGS:=-DBOOTSTRAPPING_FLEXLINK $(CFLAGS) +else +MAKE_OCAMLRUN=$(MKEXE) -o $(1) $(2) +endif + DBGO=d.$(O) OBJS=$(COMMONOBJS:.o=.$(O)) win32.$(O) main.$(O) DOBJS=$(OBJS:.$(O)=.$(DBGO)) instrtrace.$(DBGO) ocamlrun$(EXE): libcamlrun.$(A) prims.$(O) - $(MKEXE) -o ocamlrun$(EXE) prims.$(O) $(call SYSLIB,ws2_32) \ - $(EXTRALIBS) libcamlrun.$(A) + $(call MAKE_OCAMLRUN,ocamlrun$(EXE),prims.$(O) libcamlrun.$(A) \ + $(call SYSLIB,ws2_32) $(EXTRALIBS)) ocamlrund$(EXE): libcamlrund.$(A) prims.$(O) main.$(O) $(MKEXE) -o ocamlrund$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) \ diff --git a/byterun/caml/config.h b/byterun/caml/config.h index 58f2f4266..1245aa451 100644 --- a/byterun/caml/config.h +++ b/byterun/caml/config.h @@ -19,6 +19,9 @@ /* */ #include "../../config/m.h" #include "../../config/s.h" +#ifdef BOOTSTRAPPING_FLEXLINK +#undef SUPPORT_DYNAMIC_LINKING +#endif /* */ #ifndef CAML_NAME_SPACE diff --git a/byterun/caml/major_gc.h b/byterun/caml/major_gc.h index 53027a7b2..50ad36ccd 100644 --- a/byterun/caml/major_gc.h +++ b/byterun/caml/major_gc.h @@ -38,13 +38,23 @@ extern uintnat caml_dependent_size, caml_dependent_allocated; extern uintnat caml_fl_wsz_at_phase_change; #define Phase_mark 0 -#define Phase_sweep 1 -#define Phase_idle 2 -#define Subphase_roots 10 -#define Subphase_main 11 -#define Subphase_weak1 12 -#define Subphase_weak2 13 -#define Subphase_final 14 +#define Phase_clean 1 +#define Phase_sweep 2 +#define Phase_idle 3 + +/* Subphase of mark */ +#define Subphase_mark_roots 10 +/* Subphase_mark_roots: At the end of this subphase all the global + roots are marked. */ +#define Subphase_mark_main 11 +/* Subphase_mark_main: At the end of this subphase all the value alive at + the start of this subphase and created during it are marked. */ +#define Subphase_mark_final 12 +/* Subphase_mark_final: At the start of this subphase register which + value with an ocaml finalizer are not marked, the associated + finalizer will be run later. So we mark now these value as alive, + since they must be available for their finalizer. + */ CAMLextern char *caml_heap_start; extern uintnat total_heap_size; diff --git a/byterun/caml/minor_gc.h b/byterun/caml/minor_gc.h index 04f6f9953..6e46a5e10 100644 --- a/byterun/caml/minor_gc.h +++ b/byterun/caml/minor_gc.h @@ -25,17 +25,26 @@ CAMLextern value *caml_young_trigger; extern asize_t caml_minor_heap_wsz; extern int caml_in_minor_collection; -struct caml_ref_table { - value **base; - value **end; - value **threshold; - value **ptr; - value **limit; - asize_t size; - asize_t reserve; +#define CAML_TABLE_STRUCT(t) { \ + t *base; \ + t *end; \ + t *threshold; \ + t *ptr; \ + t *limit; \ + asize_t size; \ + asize_t reserve; \ +} + +struct caml_ref_table CAML_TABLE_STRUCT(value *); +CAMLextern struct caml_ref_table caml_ref_table, caml_finalize_table; + +struct caml_ephe_ref_elt { + value ephe; /* an ephemeron in major heap */ + mlsize_t offset; /* the offset that points in the minor heap */ }; -CAMLextern struct caml_ref_table caml_ref_table, caml_weak_ref_table, - caml_finalize_table; + +struct caml_ephe_ref_table CAML_TABLE_STRUCT(struct caml_ephe_ref_elt); +CAMLextern struct caml_ephe_ref_table caml_ephe_ref_table; extern void caml_set_minor_heap_size (asize_t); /* size in bytes */ extern void caml_empty_minor_heap (void); @@ -43,6 +52,9 @@ CAMLextern void caml_gc_dispatch (void); CAMLextern void garbage_collection (void); /* def in asmrun/signals_asm.c */ extern void caml_realloc_ref_table (struct caml_ref_table *); extern void caml_alloc_table (struct caml_ref_table *, asize_t, asize_t); +extern void caml_realloc_ephe_ref_table (struct caml_ephe_ref_table *); +extern void caml_alloc_ephe_table (struct caml_ephe_ref_table *, + asize_t, asize_t); extern void caml_oldify_one (value, value *); extern void caml_oldify_mopup (void); @@ -62,4 +74,17 @@ static inline void add_to_ref_table (struct caml_ref_table *tbl, value *p) *tbl->ptr++ = p; } +static inline void add_to_ephe_ref_table (struct caml_ephe_ref_table *tbl, + value ar, mlsize_t offset) +{ + struct caml_ephe_ref_elt *ephe_ref; + if (tbl->ptr >= tbl->limit){ + CAMLassert (tbl->ptr == tbl->limit); + caml_realloc_ephe_ref_table (tbl); + } + ephe_ref = tbl->ptr++; + ephe_ref->ephe = ar; + ephe_ref->offset = offset; +} + #endif /* CAML_MINOR_GC_H */ diff --git a/byterun/caml/weak.h b/byterun/caml/weak.h index 0cf4b8b2b..fd12188c2 100644 --- a/byterun/caml/weak.h +++ b/byterun/caml/weak.h @@ -18,7 +18,69 @@ #include "mlvalues.h" -extern value caml_weak_list_head; -extern value caml_weak_none; +extern value caml_ephe_list_head; +extern value caml_ephe_none; + + +/** The first field 0: weak list; + second field 1: data; + others 2..: keys; + + A weak pointer is an ephemeron with the data at caml_ephe_none + */ + +#define CAML_EPHE_LINK_OFFSET 0 +#define CAML_EPHE_DATA_OFFSET 1 +#define CAML_EPHE_FIRST_KEY 2 + + +/* In the header, in order to let major_gc.c + and weak.c see the body of the function */ +static inline void caml_ephe_clean (value v){ + value child; + int release_data = 0; + mlsize_t size, i; + header_t hd; + Assert(caml_gc_phase == Phase_clean); + + hd = Hd_val (v); + size = Wosize_hd (hd); + for (i = 2; i < size; i++){ + child = Field (v, i); + ephemeron_again: + if (child != caml_ephe_none + && Is_block (child) && Is_in_heap_or_young (child)){ + if (Tag_val (child) == Forward_tag){ + value f = Forward_val (child); + if (Is_block (f)) { + if (!Is_in_value_area(f) || Tag_val (f) == Forward_tag + || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag){ + /* Do not short-circuit the pointer. */ + }else{ + Field (v, i) = child = f; + if (Is_block (f) && Is_young (f)) + add_to_ephe_ref_table(&caml_ephe_ref_table, v, i); + goto ephemeron_again; + } + } + } + if (Is_white_val (child) && !Is_young (child)){ + release_data = 1; + Field (v, i) = caml_ephe_none; + } + } + } + + child = Field (v, 1); + if(child != caml_ephe_none){ + if (release_data){ + Field (v, 1) = caml_ephe_none; + } else { + /* The mark phase must have marked it */ + Assert( !(Is_block (child) && Is_in_heap (child) + && Is_white_val (child)) ); + } + } +} #endif /* CAML_WEAK_H */ diff --git a/byterun/compact.c b/byterun/compact.c index 07ffabb31..b317149f7 100644 --- a/byterun/compact.c +++ b/byterun/compact.c @@ -221,7 +221,7 @@ static void do_compaction (void) } /* Invert weak pointers. */ { - value *pp = &caml_weak_list_head; + value *pp = &caml_ephe_list_head; value p; word q; size_t sz, i; @@ -233,7 +233,7 @@ static void do_compaction (void) while (Ecolor (q) == 0) q = * (word *) q; sz = Wosize_ehd (q); for (i = 1; i < sz; i++){ - if (Field (p,i) != caml_weak_none){ + if (Field (p,i) != caml_ephe_none){ invert_pointer_at ((word *) &(Field (p,i))); } } @@ -402,7 +402,7 @@ void caml_compact_heap (void) CAMLassert (caml_young_ptr == caml_young_alloc_end); CAMLassert (caml_ref_table.ptr == caml_ref_table.base); - CAMLassert (caml_weak_ref_table.ptr == caml_weak_ref_table.base); + CAMLassert (caml_ephe_ref_table.ptr == caml_ephe_ref_table.base); do_compaction (); CAML_INSTR_TIME (tmr, "compact/main"); diff --git a/byterun/major_gc.c b/byterun/major_gc.c index 23dd9b2c1..f9f48a10f 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -44,7 +44,8 @@ uintnat caml_percent_free; uintnat caml_major_heap_increment; CAMLexport char *caml_heap_start; char *caml_gc_sweep_hp; -int caml_gc_phase; /* always Phase_mark, Phase_sweep, or Phase_idle */ +int caml_gc_phase; /* always Phase_mark, Pase_clean, + Phase_sweep, or Phase_idle */ static value *gray_vals; static value *gray_vals_cur, *gray_vals_end; static asize_t gray_vals_size; @@ -59,8 +60,47 @@ extern char *caml_fl_merge; /* Defined in freelist.c. */ static char *markhp, *chunk, *limit; -int caml_gc_subphase; /* Subphase_{main,weak1,weak2,final} */ -static value *weak_prev; +int caml_gc_subphase; /* Subphase_{mark_roots,mark_main,mark_final} */ + +/** + Ephemerons: + During mark phase the list caml_ephe_list_head of ephemerons + is iterated by different pointers that follow the invariants: + caml_ephe_list_head ->* ephes_checked_if_pure ->* ephes_to_check ->* null + | | | + (1) (2) (3) + + At the start of mark phase, (1) and (2) are empty. + + In mark phase: + - the ephemerons in (1) have a data alive or none + (nb: new ephemerons are added in this part by weak.c) + - the ephemerons in (2) have at least a white key or are white + if ephe_list_pure is true, otherwise they are in an unknown state and + must be checked again. + - the ephemerons in (3) are in an unknown state and must be checked + + At the end of mark phase, (3) is empty and ephe_list_pure is true. + The ephemeron in (1) and (2) will be cleaned (white keys and datas + replaced by none or the ephemeron is removed from the list if it is white) + in clean phase. + + In clean phase: + caml_ephe_list_head ->* ephes_to_check ->* null + | | + (1) (3) + + In clean phase, (2) is not used, ephes_to_check is initialized at + caml_ephe_list_head: + - the ephemerons in (1) are clean. + - the ephemerons in (3) should be cleaned or removed if white. + + */ +static int ephe_list_pure; +/** The ephemerons is pure if since the start of its iteration + no value have been darken. */ +static value *ephes_checked_if_pure; +static value *ephes_to_check; int caml_major_window = 1; double caml_major_ring[Max_major_window] = { 0. }; @@ -126,6 +166,7 @@ void caml_darken (value v, value *p /* not used */) #endif CAMLassert (!Is_blue_hd (h)); if (Is_white_hd (h)){ + ephe_list_pure = 0; if (t < No_scan_tag){ Hd_val (v) = Grayhd_hd (h); *gray_vals_cur++ = v; @@ -144,8 +185,11 @@ static void start_cycle (void) caml_gc_message (0x01, "Starting new major GC cycle\n", 0); caml_darken_all_roots_start (); caml_gc_phase = Phase_mark; - caml_gc_subphase = Subphase_roots; + caml_gc_subphase = Subphase_mark_roots; markhp = NULL; + ephe_list_pure = 1; + ephes_checked_if_pure = &caml_ephe_list_head; + ephes_to_check = &caml_ephe_list_head; #ifdef DEBUG ++ major_gc_counter; caml_heap_check (); @@ -159,25 +203,179 @@ static void start_cycle (void) static value current_value = 0; static mlsize_t current_index = 0; +/* For instrumentation */ #ifdef CAML_INSTR #define INSTR(x) x #else #define INSTR(x) /**/ #endif +static void init_sweep_phase(void) +{ + /* Phase_clean is done. */ + /* Initialise the sweep phase. */ + caml_gc_sweep_hp = caml_heap_start; + caml_fl_init_merge (); + caml_gc_phase = Phase_sweep; + chunk = caml_heap_start; + caml_gc_sweep_hp = chunk; + limit = chunk + Chunk_size (chunk); + caml_fl_wsz_at_phase_change = caml_fl_cur_wsz; + if (caml_major_gc_hook) (*caml_major_gc_hook)(); +} + +/* auxillary function of mark_slice */ +static inline value* mark_slice_darken(value *gray_vals_ptr, value v, int i, + int in_ephemeron, int *slice_pointers) +{ + value child; + header_t chd; + + child = Field (v, i); + +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + if (Is_block (child) + && ! Is_young (child) + && Wosize_val (child) > 0 /* Atoms never need to be marked. */ + /* Closure blocks contain code pointers at offsets that cannot + be reliably determined, so we always use the page table when + marking such values. */ + && (!(Tag_val (v) == Closure_tag || Tag_val (v) == Infix_tag) || + Is_in_heap (child))) { +#else + if (Is_block (child) && Is_in_heap (child)) { +#endif + INSTR (++ *slice_pointers;) + chd = Hd_val (child); + if (Tag_hd (chd) == Forward_tag){ + value f = Forward_val (child); + if ((in_ephemeron && Is_long(f)) || + (Is_block (f) + && (!Is_in_value_area(f) || Tag_val (f) == Forward_tag + || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag))){ + /* Do not short-circuit the pointer. */ + }else{ + /* The variable child is not changed because it must be mark alive */ + Field (v, i) = f; + if (Is_block (f) && Is_young (f) && !Is_young (child)){ + if(in_ephemeron){ + add_to_ephe_ref_table (&caml_ephe_ref_table, v, i); + }else{ + add_to_ref_table (&caml_ref_table, &Field (v, i)); + } + } + } + } + else if (Tag_hd(chd) == Infix_tag) { + child -= Infix_offset_val(child); + chd = Hd_val(child); + } +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + /* See [caml_darken] for a description of this assertion. */ + CAMLassert (Is_in_heap (child) || Is_black_hd (chd)); +#endif + if (Is_white_hd (chd)){ + ephe_list_pure = 0; + Hd_val (child) = Grayhd_hd (chd); + *gray_vals_ptr++ = child; + if (gray_vals_ptr >= gray_vals_end) { + gray_vals_cur = gray_vals_ptr; + realloc_gray_vals (); + gray_vals_ptr = gray_vals_cur; + } + } + } + + return gray_vals_ptr; +} + +static value* mark_ephe_aux (value *gray_vals_ptr, intnat *work, + int *slice_pointers) +{ + value v, data, key; + header_t hd; + mlsize_t size, i; + + v = *ephes_to_check; + hd = Hd_val(v); + Assert(Tag_val (v) == Abstract_tag); + data = Field(v,CAML_EPHE_DATA_OFFSET); + if ( data != caml_ephe_none && + Is_block (data) && Is_in_heap (data) && Is_white_val (data)){ + + int alive_data = 1; + + /* The liveness of the ephemeron is one of the condition */ + if (Is_white_hd (hd)) alive_data = 0; + + /* The liveness of the keys not caml_ephe_none is the other condition */ + size = Wosize_hd (hd); + for (i = CAML_EPHE_FIRST_KEY; alive_data && i < size; i++){ + key = Field (v, i); + ephemeron_again: + if (key != caml_ephe_none && + Is_block (key) && Is_in_heap (key)){ + if (Tag_val (key) == Forward_tag){ + value f = Forward_val (key); + if (Is_long (f) || + (Is_block (f) && + (!Is_in_value_area(f) || Tag_val (f) == Forward_tag + || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag))){ + /* Do not short-circuit the pointer. */ + }else{ + Field (v, i) = key = f; + goto ephemeron_again; + } + } + if (Is_white_val (key)){ + alive_data = 0; + } + } + } + *work -= Whsize_wosize(i); + + if (alive_data){ + gray_vals_ptr = mark_slice_darken(gray_vals_ptr,v, + CAML_EPHE_DATA_OFFSET, + /*in_ephemeron=*/1, + slice_pointers); + } else { /* not triggered move to the next one */ + ephes_to_check = &Field(v,CAML_EPHE_LINK_OFFSET); + return gray_vals_ptr; + } + } else { /* a simily weak pointer or an already alive data */ + *work -= 1; + } + + /* all keys black or data none or black + move the ephemerons from (3) to the end of (1) */ + if ( ephes_checked_if_pure == ephes_to_check ) { + /* corner case and optim */ + ephes_checked_if_pure = &Field(v,CAML_EPHE_LINK_OFFSET); + ephes_to_check = ephes_checked_if_pure; + } else { + /* - remove v from the list (3) */ + *ephes_to_check = Field(v,CAML_EPHE_LINK_OFFSET); + /* - insert it at the end of (1) */ + Field(v,CAML_EPHE_LINK_OFFSET) = *ephes_checked_if_pure; + *ephes_checked_if_pure = v; + ephes_checked_if_pure = &Field(v,CAML_EPHE_LINK_OFFSET); + } + return gray_vals_ptr; +} + + + static void mark_slice (intnat work) { value *gray_vals_ptr; /* Local copy of [gray_vals_cur] */ - value v, child; - header_t hd, chd; + value v; + header_t hd; mlsize_t size, i, start, end; /* [start] is a local copy of [current_index] */ -#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS - int marking_closure = 0; -#endif #ifdef CAML_INSTR int slice_fields = 0; - int slice_pointers = 0; #endif + int slice_pointers = 0; /** gcc removes it when not in CAML_INSTR */ caml_gc_message (0x40, "Marking %ld words\n", work); caml_gc_message (0x40, "Subphase = %ld\n", caml_gc_subphase); @@ -192,10 +390,6 @@ static void mark_slice (intnat work) } if (v != 0){ hd = Hd_val(v); -#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS - marking_closure = - (Tag_hd (hd) == Closure_tag || Tag_hd (hd) == Infix_tag); -#endif Assert (Is_gray_hd (hd)); size = Wosize_hd (hd); end = start + work; @@ -207,49 +401,9 @@ static void mark_slice (intnat work) INSTR (if (size > end) CAML_INSTR_INT ("major/mark/slice/remain", size - end);) for (i = start; i < end; i++){ - child = Field (v, i); -#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS - if (Is_block (child) - && ! Is_young (child) - && Wosize_val (child) > 0 /* Atoms never need to be marked. */ - /* Closure blocks contain code pointers at offsets that cannot - be reliably determined, so we always use the page table when - marking such values. */ - && (!marking_closure || Is_in_heap (child))) { -#else - if (Is_block (child) && Is_in_heap (child)) { -#endif - INSTR (++ slice_pointers;) - chd = Hd_val (child); - if (Tag_hd (chd) == Forward_tag){ - value f = Forward_val (child); - if (Is_block (f) - && (!Is_in_value_area(f) || Tag_val (f) == Forward_tag - || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){ - /* Do not short-circuit the pointer. */ - }else{ - Field (v, i) = f; - if (Is_block (f) && Is_young (f) && !Is_young (child)) - add_to_ref_table (&caml_ref_table, &Field (v, i)); - } - }else if (Tag_hd(chd) == Infix_tag) { - child -= Infix_offset_val(child); - chd = Hd_val(child); - } -#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS - /* See [caml_darken] for a description of this assertion. */ - CAMLassert (Is_in_heap (child) || Is_black_hd (chd)); -#endif - if (Is_white_hd (chd)){ - Hd_val (child) = Grayhd_hd (chd); - *gray_vals_ptr++ = child; - if (gray_vals_ptr >= gray_vals_end) { - gray_vals_cur = gray_vals_ptr; - realloc_gray_vals (); - gray_vals_ptr = gray_vals_cur; - } - } - } + gray_vals_ptr = mark_slice_darken(gray_vals_ptr,v,i, + /*in_ephemeron=*/ 0, + &slice_pointers); } if (end < size){ work = 0; @@ -292,62 +446,25 @@ static void mark_slice (intnat work) chunk = caml_heap_start; markhp = chunk; limit = chunk + Chunk_size (chunk); + } else if (caml_gc_subphase == Subphase_mark_roots) { + gray_vals_cur = gray_vals_ptr; + work = caml_darken_all_roots_slice (work); + gray_vals_ptr = gray_vals_cur; + if (work > 0){ + caml_gc_subphase = Subphase_mark_main; + } + } else if (*ephes_to_check != (value) NULL) { + /* Continue to scan the list of ephe */ + gray_vals_ptr = mark_ephe_aux(gray_vals_ptr,&work,&slice_pointers); + } else if (!ephe_list_pure){ + /* We must scan again the list because some value have been darken */ + ephe_list_pure = 1; + ephes_to_check = ephes_checked_if_pure; }else{ switch (caml_gc_subphase){ - case Subphase_roots: { - gray_vals_cur = gray_vals_ptr; - work = caml_darken_all_roots_slice (work); - gray_vals_ptr = gray_vals_cur; - if (work > 0){ - caml_gc_subphase = Subphase_main; - } - } - break; - case Subphase_main: { - /* The main marking phase is over. Start removing weak pointers to - dead values. */ - caml_gc_subphase = Subphase_weak1; - weak_prev = &caml_weak_list_head; - } - break; - case Subphase_weak1: { - value cur, curfield; - mlsize_t sz, i; - header_t hd; - - cur = *weak_prev; - if (cur != (value) NULL){ - hd = Hd_val (cur); - sz = Wosize_hd (hd); - for (i = 1; i < sz; i++){ - curfield = Field (cur, i); - weak_again: - if (curfield != caml_weak_none - && Is_block (curfield) && Is_in_heap_or_young (curfield)){ - if (Tag_val (curfield) == Forward_tag){ - value f = Forward_val (curfield); - if (Is_block (f)) { - if (!Is_in_value_area(f) || Tag_val (f) == Forward_tag - || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag){ - /* Do not short-circuit the pointer. */ - }else{ - Field (cur, i) = curfield = f; - if (Is_block (f) && Is_young (f)) - add_to_ref_table (&caml_weak_ref_table, &Field (cur, i)); - goto weak_again; - } - } - } - if (Is_white_val (curfield) && !Is_young (curfield)){ - Field (cur, i) = caml_weak_none; - } - } - } - weak_prev = &Field (cur, 0); - work -= Whsize_hd (hd); - }else{ - /* Subphase_weak1 is done. - Handle finalised values and start removing dead weak arrays. */ + case Subphase_mark_main: { + /* Subphase_mark_main is done. + Mark finalised values. */ gray_vals_cur = gray_vals_ptr; caml_final_update (); gray_vals_ptr = gray_vals_cur; @@ -355,44 +472,25 @@ static void mark_slice (intnat work) v = *--gray_vals_ptr; CAMLassert (start == 0); } - caml_gc_subphase = Subphase_weak2; - weak_prev = &caml_weak_list_head; - } + /* Complete the marking */ + ephes_to_check = ephes_checked_if_pure; + caml_gc_subphase = Subphase_mark_final; } break; - case Subphase_weak2: { - value cur; - header_t hd; - - cur = *weak_prev; - if (cur != (value) NULL){ - hd = Hd_val (cur); - if (Color_hd (hd) == Caml_white){ - /* The whole array is dead, remove it from the list. */ - *weak_prev = Field (cur, 0); - }else{ - weak_prev = &Field (cur, 0); - } - work -= 1; - }else{ - /* Subphase_weak2 is done. Go to Subphase_final. */ - caml_gc_subphase = Subphase_final; + case Subphase_mark_final: { + if (caml_ephe_list_head != (value) NULL){ + /* Initialise the clean phase. */ + caml_gc_phase = Phase_clean; + ephes_to_check = &caml_ephe_list_head; + work = 0; + } else { + /* Initialise the sweep phase, + shortcut the unneeded clean phase. */ + init_sweep_phase(); + work = 0; } } break; - case Subphase_final: { - /* Initialise the sweep phase. */ - caml_gc_sweep_hp = caml_heap_start; - caml_fl_init_merge (); - caml_gc_phase = Phase_sweep; - chunk = caml_heap_start; - caml_gc_sweep_hp = chunk; - limit = chunk + Chunk_size (chunk); - work = 0; - caml_fl_wsz_at_phase_change = caml_fl_cur_wsz; - if (caml_major_gc_hook) (*caml_major_gc_hook)(); - } - break; default: Assert (0); } } @@ -404,6 +502,33 @@ static void mark_slice (intnat work) INSTR (CAML_INSTR_INT ("major/mark/slice/pointers#", slice_pointers);) } +/* Clean ephemerons */ +static void clean_slice (intnat work) +{ + value v; + + caml_gc_message (0x40, "Cleaning %ld words\n", work); + while (work > 0){ + v = *ephes_to_check; + if (v != (value) NULL){ + if (Is_white_val (v)){ + /* The whole array is dead, remove it from the list. */ + *ephes_to_check = Field (v, CAML_EPHE_LINK_OFFSET); + work -= 1; + }else{ + caml_ephe_clean(v); + ephes_to_check = &Field (v, CAML_EPHE_LINK_OFFSET); + work -= Whsize_val (v); + } + }else{ /* End of list reached */ + /* Phase_clean is done. */ + /* Initialise the sweep phase. */ + init_sweep_phase(); + work = 0; + } + } +} + static void sweep_slice (intnat work) { char *hp; @@ -625,7 +750,7 @@ void caml_major_collection_slice (intnat howmuch) goto finished; } - if (caml_gc_phase == Phase_mark){ + if (caml_gc_phase == Phase_mark || caml_gc_phase == Phase_clean){ computed_work = (intnat) (p * (caml_stat_heap_wsz * 250 / (100 + caml_percent_free) + caml_incremental_roots_count)); @@ -638,6 +763,9 @@ void caml_major_collection_slice (intnat howmuch) mark_slice (computed_work); CAML_INSTR_TIME (tmr, mark_slice_name[caml_gc_subphase]); caml_gc_message (0x02, "!", 0); + }else if (caml_gc_phase == Phase_clean){ + clean_slice (computed_work); + caml_gc_message (0x02, "%%", 0); }else{ Assert (caml_gc_phase == Phase_sweep); CAML_INSTR_INT ("major/work/sweep#", computed_work); @@ -682,6 +810,7 @@ void caml_finish_major_cycle (void) { if (caml_gc_phase == Phase_idle) start_cycle (); while (caml_gc_phase == Phase_mark) mark_slice (LONG_MAX); + while (caml_gc_phase == Phase_clean) clean_slice (LONG_MAX); Assert (caml_gc_phase == Phase_sweep); while (caml_gc_phase == Phase_sweep) sweep_slice (LONG_MAX); Assert (caml_gc_phase == Phase_idle); diff --git a/byterun/memory.c b/byterun/memory.c index 54391b7d3..05f95a266 100644 --- a/byterun/memory.c +++ b/byterun/memory.c @@ -445,7 +445,7 @@ void caml_shrink_heap (char *chunk) color_t caml_allocation_color (void *hp) { - if (caml_gc_phase == Phase_mark + if (caml_gc_phase == Phase_mark || caml_gc_phase == Phase_clean || (caml_gc_phase == Phase_sweep && (addr)hp >= (addr)caml_gc_sweep_hp)){ return Caml_black; }else{ @@ -486,7 +486,7 @@ static inline value caml_alloc_shr_aux (mlsize_t wosize, tag_t tag, Assert (Is_in_heap (Val_hp (hp))); /* Inline expansion of caml_allocation_color. */ - if (caml_gc_phase == Phase_mark + if (caml_gc_phase == Phase_mark || caml_gc_phase == Phase_clean || (caml_gc_phase == Phase_sweep && (addr)hp >= (addr)caml_gc_sweep_hp)){ Hd_hp (hp) = Make_header (wosize, tag, Caml_black); }else{ diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c index 950ec216c..75be7bdf3 100644 --- a/byterun/minor_gc.c +++ b/byterun/minor_gc.c @@ -49,6 +49,8 @@ native code, or [caml_young_trigger]. */ +struct generic_table CAML_TABLE_STRUCT(char); + asize_t caml_minor_heap_wsz; static void *caml_young_base = NULL; CAMLexport value *caml_young_start = NULL, *caml_young_end = NULL; @@ -60,21 +62,24 @@ CAMLexport value *caml_young_trigger = NULL; CAMLexport struct caml_ref_table caml_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}, - caml_weak_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}, caml_finalize_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}; /* table of custom blocks containing finalizers in the minor heap */ +CAMLexport struct caml_ephe_ref_table + caml_ephe_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}; + int caml_in_minor_collection = 0; /* [sz] and [rsv] are numbers of entries */ -void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv) +static void alloc_generic_table (struct generic_table *tbl, asize_t sz, + asize_t rsv, asize_t element_size) { - value **new_table; + void *new_table; tbl->size = sz; tbl->reserve = rsv; - new_table = (value **) caml_stat_alloc ((tbl->size + tbl->reserve) - * sizeof (value *)); + new_table = (void *) caml_stat_alloc ((tbl->size + tbl->reserve) + * element_size); if (tbl->base != NULL) caml_stat_free (tbl->base); tbl->base = new_table; tbl->ptr = tbl->base; @@ -83,7 +88,19 @@ void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv) tbl->end = tbl->base + tbl->size + tbl->reserve; } -static void reset_table (struct caml_ref_table *tbl) +void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv) +{ + alloc_generic_table ((struct generic_table *) tbl, sz, rsv, sizeof (value *)); +} + +void caml_alloc_ephe_table (struct caml_ephe_ref_table *tbl, asize_t sz, + asize_t rsv) +{ + alloc_generic_table ((struct generic_table *) tbl, sz, rsv, + sizeof (struct caml_ephe_ref_elt)); +} + +static void reset_table (struct generic_table *tbl) { tbl->size = 0; tbl->reserve = 0; @@ -91,7 +108,7 @@ static void reset_table (struct caml_ref_table *tbl) tbl->base = tbl->ptr = tbl->threshold = tbl->limit = tbl->end = NULL; } -static void clear_table (struct caml_ref_table *tbl) +static void clear_table (struct generic_table *tbl) { tbl->ptr = tbl->base; tbl->limit = tbl->threshold; @@ -165,8 +182,8 @@ void caml_set_minor_heap_size (asize_t bsz) caml_young_ptr = caml_young_alloc_end; caml_minor_heap_wsz = Wsize_bsize (bsz); - reset_table (&caml_ref_table); - reset_table (&caml_weak_ref_table); + reset_table ((struct generic_table *) &caml_ref_table); + reset_table ((struct generic_table *) &caml_ephe_ref_table); } static value oldify_todo_list = 0; @@ -257,6 +274,21 @@ void caml_oldify_one (value v, value *p) } } +/* Test if the ephemeron is alive, everything outside minor heap is alive */ +static inline int ephe_check_alive_data(struct caml_ephe_ref_elt *re){ + mlsize_t i; + value child; + for (i = 2; i < Wosize_val(re->ephe); i++){ + child = Field (re->ephe, i); + if(child != caml_ephe_none + && Is_block (child) && Is_young (child) + && Hd_val (child) != 0){ /* Value not copied to major heap */ + return 0; + } + } + return 1; +} + /* Finish the work that was put off by [caml_oldify_one]. Note that [caml_oldify_one] itself is called by oldify_mopup, so we have to be careful to remove the first entry from the list before @@ -265,6 +297,8 @@ void caml_oldify_mopup (void) { value v, new_v, f; mlsize_t i; + struct caml_ephe_ref_elt *re; + int redo = 0; while (oldify_todo_list != 0){ v = oldify_todo_list; /* Get the head. */ @@ -285,6 +319,28 @@ void caml_oldify_mopup (void) } } } + + /* Oldify the data in the minor heap of alive ephemeron + During minor collection keys outside the minor heap are considered alive */ + for (re = caml_ephe_ref_table.base; + re < caml_ephe_ref_table.ptr; re++){ + /* look only at ephemeron with data in the minor heap */ + if (re->offset == 1){ + value *data = &Field(re->ephe,1); + if (*data != caml_ephe_none && Is_block (*data) && Is_young (*data)){ + if (Hd_val (*data) == 0){ /* Value copied to major heap */ + *data = Field (*data, 0); + } else { + if (ephe_check_alive_data(re)){ + caml_oldify_one(*data,data); + redo = 1; /* oldify_todo_list can still be 0 */ + } + } + } + } + } + + if (redo) caml_oldify_mopup (); } /* Make sure the minor heap is empty by performing a minor collection @@ -294,6 +350,7 @@ void caml_empty_minor_heap (void) { value **r; uintnat prev_alloc_words; + struct caml_ephe_ref_elt *re; if (caml_young_ptr != caml_young_alloc_end){ if (caml_minor_gc_begin_hook != NULL) (*caml_minor_gc_begin_hook) (); @@ -309,15 +366,21 @@ void caml_empty_minor_heap (void) CAML_INSTR_TIME (tmr, "minor/ref_table"); caml_oldify_mopup (); CAML_INSTR_TIME (tmr, "minor/copy"); - for (r = caml_weak_ref_table.base; r < caml_weak_ref_table.ptr; r++){ - if (Is_block (**r) && Is_young (**r)){ - if (Hd_val (**r) == 0){ - **r = Field (**r, 0); - }else{ - **r = caml_weak_none; + /* Update the ephemerons */ + for (re = caml_ephe_ref_table.base; + re < caml_ephe_ref_table.ptr; re++){ + value *key = &Field(re->ephe,re->offset); + if (*key != caml_ephe_none && Is_block (*key) && Is_young (*key)){ + if (Hd_val (*key) == 0){ /* Value copied to major heap */ + *key = Field (*key, 0); + }else{ /* Value not copied so it's dead */ + Assert(!ephe_check_alive_data(re)); + *key = caml_ephe_none; + Field(re->ephe,1) = caml_ephe_none; } } } + /* Run custom block finalisation of dead minor value */ for (r = caml_finalize_table.base; r < caml_finalize_table.ptr; r++){ int hd = Hd_val ((value)*r); if (hd != 0){ /* If not oldified the finalizer must be called */ @@ -326,14 +389,13 @@ void caml_empty_minor_heap (void) } } CAML_INSTR_TIME (tmr, "minor/update_weak"); - CAMLassert (caml_young_ptr >= caml_young_alloc_start); caml_stat_minor_words += caml_young_alloc_end - caml_young_ptr; caml_gc_clock += (double) (caml_young_alloc_end - caml_young_ptr) / caml_minor_heap_wsz; caml_young_ptr = caml_young_alloc_end; - clear_table (&caml_ref_table); - clear_table (&caml_weak_ref_table); - clear_table (&caml_finalize_table); + clear_table ((struct generic_table *) &caml_ref_table); + clear_table ((struct generic_table *) &caml_ephe_ref_table); + clear_table ((struct generic_table *) &caml_finalize_table); caml_gc_message (0x02, ">", 0); caml_in_minor_collection = 0; caml_final_empty_young (); @@ -428,16 +490,20 @@ CAMLexport value caml_check_urgent_gc (value extra_root) CAMLreturn (extra_root); } -void caml_realloc_ref_table (struct caml_ref_table *tbl) -{ Assert (tbl->ptr == tbl->limit); +static void realloc_generic_table +(struct generic_table *tbl, asize_t element_size, + char * msg_intr_int, char *msg_threshold, char *msg_growing, char *msg_error) +{ + Assert (tbl->ptr == tbl->limit); Assert (tbl->limit <= tbl->end); Assert (tbl->limit >= tbl->threshold); if (tbl->base == NULL){ - caml_alloc_table (tbl, caml_minor_heap_wsz / 8, 256); + alloc_generic_table (tbl, caml_minor_heap_wsz / 8, 256, + element_size); }else if (tbl->limit == tbl->threshold){ - CAML_INSTR_INT ("request_minor/realloc_ref_table@", 1); - caml_gc_message (0x08, "ref_table threshold crossed\n", 0); + CAML_INSTR_INT (msg_intr_int, 1); + caml_gc_message (0x08, msg_threshold, 0); tbl->limit = tbl->end; caml_request_minor_gc (); }else{ @@ -446,13 +512,11 @@ void caml_realloc_ref_table (struct caml_ref_table *tbl) CAMLassert (caml_requested_minor_gc); tbl->size *= 2; - sz = (tbl->size + tbl->reserve) * sizeof (value *); - caml_gc_message (0x08, "Growing ref_table to %" - ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n", - (intnat) sz/1024); - tbl->base = (value **) realloc ((char *) tbl->base, sz); + sz = (tbl->size + tbl->reserve) * element_size; + caml_gc_message (0x08, msg_growing, (intnat) sz/1024); + tbl->base = (void *) realloc ((char *) tbl->base, sz); if (tbl->base == NULL){ - caml_fatal_error ("Fatal error: ref_table overflow\n"); + caml_fatal_error (msg_error); } tbl->end = tbl->base + tbl->size + tbl->reserve; tbl->threshold = tbl->base + tbl->size; @@ -460,3 +524,23 @@ void caml_realloc_ref_table (struct caml_ref_table *tbl) tbl->limit = tbl->end; } } + +void caml_realloc_ref_table (struct caml_ref_table *tbl) +{ + realloc_generic_table + ((struct generic_table *) tbl, sizeof (value *), + "request_minor/realloc_ref_table@", + "ref_table threshold crossed\n", + "Growing ref_table to %" ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n", + "Fatal error: ref_table overflow\n"); +} + +void caml_realloc_ephe_ref_table (struct caml_ephe_ref_table *tbl) +{ + realloc_generic_table + ((struct generic_table *) tbl, sizeof (struct caml_ephe_ref_elt), + "request_minor/realloc_ephe_ref_table@", + "ephe_ref_table threshold crossed\n", + "Growing ephe_ref_table to %" ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n", + "Fatal error: ephe_ref_table overflow\n"); +} diff --git a/byterun/str.c b/byterun/str.c index 2ec18297c..9183cb36e 100644 --- a/byterun/str.c +++ b/byterun/str.c @@ -294,7 +294,7 @@ CAMLexport value caml_alloc_sprintf(const char * format, ...) int n; value res; -#ifndef _WIN32 +#if !defined(_WIN32) || defined(_UCRT) /* C99-compliant implementation */ va_start(args, format); /* "vsnprintf(dest, sz, format, args)" writes at most "sz" characters diff --git a/byterun/weak.c b/byterun/weak.c index 8be7a1810..262c85054 100644 --- a/byterun/weak.c +++ b/byterun/weak.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* Operations on weak arrays */ +/* Operations on weak arrays and ephemerons (named ephe here)*/ #include @@ -20,30 +20,123 @@ #include "caml/major_gc.h" #include "caml/memory.h" #include "caml/mlvalues.h" +#include "caml/weak.h" -value caml_weak_list_head = 0; +value caml_ephe_list_head = 0; + +static value ephe_dummy = 0; +value caml_ephe_none = (value) &ephe_dummy; + +#if defined (NATIVE_CODE) && defined (NO_NAKED_POINTERS) +/** The minor heap is considered alive. + Outside minor and major heap, x must be black. +*/ +static inline int Is_Dead_during_clean(value x){ + Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_clean); + return Is_block (x) && !Is_young (x) && Is_white_val(x); +} +/** The minor heap doesn't have to be marked, outside they should + already be black +*/ +static inline int Must_be_Marked_during_mark(value x){ + Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_mark); + return Is_block (x) && !Is_young (x); +} +#else +static inline int Is_Dead_during_clean(value x){ + Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_clean); + return Is_block (x) && Is_in_heap (x) && Is_white_val(x); +} +static inline int Must_be_Marked_during_mark(value x){ + Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_mark); + return Is_block (x) && Is_in_heap (x); +} +#endif -static value weak_dummy = 0; -value caml_weak_none = (value) &weak_dummy; /* [len] is a value that represents a number of words (fields) */ -CAMLprim value caml_weak_create (value len) +CAMLprim value caml_ephe_create (value len) { mlsize_t size, i; value res; - size = Long_val (len) + 1; + size = Long_val (len) + 1 /* weak_list */ + 1 /* the value */; if (size <= 0 || size > Max_wosize) caml_invalid_argument ("Weak.create"); res = caml_alloc_shr (size, Abstract_tag); - for (i = 1; i < size; i++) Field (res, i) = caml_weak_none; - Field (res, 0) = caml_weak_list_head; - caml_weak_list_head = res; + for (i = 1; i < size; i++) Field (res, i) = caml_ephe_none; + Field (res, CAML_EPHE_LINK_OFFSET) = caml_ephe_list_head; + caml_ephe_list_head = res; return res; } +CAMLprim value caml_weak_create (value len) +{ + return caml_ephe_create(len); +} + +/** + Specificity of the cleaning phase (Phase_clean): + + The dead keys must be removed from the ephemerons and data removed + when one the keys is dead. Here we call it cleaning the ephemerons. + A specific phase of the GC is dedicated to this, Phase_clean. This + phase is just after the mark phase, so the white values are dead + values. It iterates the function caml_ephe_clean through all the + ephemerons. + + However the GC is incremental and ocaml code can run on the middle + of this cleaning phase. In order to respect the semantic of the + ephemerons concerning dead values, the getter and setter must work + as if the cleaning of all the ephemerons have been done at once. + + - key getter: Even if a dead key have not yet been replaced by + caml_ephe_none, getting it should return none. + - key setter: If we replace a dead key we need to set the data to + caml_ephe_none and clean the ephemeron. + + This two cases are dealt by a call to do_check_key_clean that + trigger the cleaning of the ephemerons when the accessed key is + dead. This test is fast. + + In the case of value getter and value setter, there is no fast + test because the removing of the data depend of the deadliness of the keys. + We must always try to clean the ephemerons. + + */ + #define None_val (Val_int(0)) #define Some_tag 0 +/* If we are in Phase_clean we need to check if the key + that is going to disappear is dead and so should trigger a cleaning + */ +static void do_check_key_clean(value ar, mlsize_t offset){ + Assert ( offset >= 2); + if (caml_gc_phase == Phase_clean){ + value elt = Field (ar, offset); + if (elt != caml_ephe_none && Is_Dead_during_clean(elt)){ + Field(ar,offset) = caml_ephe_none; + Field(ar,CAML_EPHE_DATA_OFFSET) = caml_ephe_none; + }; + }; +} + +/* If we are in Phase_clean we need to do as if the key is empty when + it will be cleaned during this phase */ +static inline int is_ephe_key_none(value ar, mlsize_t offset){ + value elt = Field (ar, offset); + if (elt == caml_ephe_none){ + return 1; + }else if (caml_gc_phase == Phase_clean && Is_Dead_during_clean(elt)){ + Field(ar,offset) = caml_ephe_none; + Field(ar,CAML_EPHE_DATA_OFFSET) = caml_ephe_none; + return 1; + } else { + return 0; + } +} + + static void do_set (value ar, mlsize_t offset, value v) { if (Is_block (v) && Is_young (v)){ @@ -51,46 +144,119 @@ static void do_set (value ar, mlsize_t offset, value v) value old = Field (ar, offset); Field (ar, offset) = v; if (!(Is_block (old) && Is_young (old))){ - add_to_ref_table (&caml_weak_ref_table, &Field (ar, offset)); + add_to_ephe_ref_table (&caml_ephe_ref_table, ar, offset); } }else{ Field (ar, offset) = v; } } -CAMLprim value caml_weak_set (value ar, value n, value el) +CAMLprim value caml_ephe_set_key (value ar, value n, value el) { - mlsize_t offset = Long_val (n) + 1; + mlsize_t offset = Long_val (n) + 2; Assert (Is_in_heap (ar)); - if (offset < 1 || offset >= Wosize_val (ar)){ + if (offset < 2 || offset >= Wosize_val (ar)){ caml_invalid_argument ("Weak.set"); } + do_check_key_clean(ar,offset); + do_set (ar, offset, el); + return Val_unit; +} + +CAMLprim value caml_ephe_unset_key (value ar, value n) +{ + mlsize_t offset = Long_val (n) + 2; + Assert (Is_in_heap (ar)); + if (offset < 2 || offset >= Wosize_val (ar)){ + caml_invalid_argument ("Weak.set"); + } + do_check_key_clean(ar,offset); + Field (ar, offset) = caml_ephe_none; + return Val_unit; +} + +value caml_ephe_set_key_option (value ar, value n, value el) +{ + mlsize_t offset = Long_val (n) + 2; + Assert (Is_in_heap (ar)); + if (offset < 2 || offset >= Wosize_val (ar)){ + caml_invalid_argument ("Weak.set"); + } + do_check_key_clean(ar,offset); if (el != None_val && Is_block (el)){ Assert (Wosize_val (el) == 1); do_set (ar, offset, Field (el, 0)); }else{ - Field (ar, offset) = caml_weak_none; + Field (ar, offset) = caml_ephe_none; } return Val_unit; } +CAMLprim value caml_weak_set (value ar, value n, value el){ + return caml_ephe_set_key_option(ar,n,el); +} + +CAMLprim value caml_ephe_set_data (value ar, value el) +{ + Assert (Is_in_heap (ar)); + if (caml_gc_phase == Phase_clean){ + /* During this phase since we don't know which ephemeron have been + cleaned we always need to check it. */ + caml_ephe_clean(ar); + }; + do_set (ar, 1, el); + return Val_unit; +} + +CAMLprim value caml_ephe_unset_data (value ar) +{ + Assert (Is_in_heap (ar)); + Field (ar, CAML_EPHE_DATA_OFFSET) = caml_ephe_none; + return Val_unit; +} + + #define Setup_for_gc #define Restore_after_gc -CAMLprim value caml_weak_get (value ar, value n) +CAMLprim value caml_ephe_get_key (value ar, value n) { CAMLparam2 (ar, n); - mlsize_t offset = Long_val (n) + 1; + mlsize_t offset = Long_val (n) + 2; CAMLlocal2 (res, elt); Assert (Is_in_heap (ar)); - if (offset < 1 || offset >= Wosize_val (ar)){ - caml_invalid_argument ("Weak.get"); + if (offset < 2 || offset >= Wosize_val (ar)){ + caml_invalid_argument ("Weak.get_key"); } - if (Field (ar, offset) == caml_weak_none){ + if (is_ephe_key_none(ar, offset)){ res = None_val; }else{ elt = Field (ar, offset); - if (caml_gc_phase == Phase_mark && Is_block (elt) && Is_in_heap (elt)){ + if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(elt)){ + caml_darken (elt, NULL); + } + res = caml_alloc_small (1, Some_tag); + Field (res, 0) = elt; + } + CAMLreturn (res); +} + +CAMLprim value caml_weak_get (value ar, value n){ + return caml_ephe_get_key(ar, n); +} + +CAMLprim value caml_ephe_get_data (value ar) +{ + CAMLparam1 (ar); + mlsize_t offset = 1; + CAMLlocal2 (res, elt); + Assert (Is_in_heap (ar)); + elt = Field (ar, offset); + if(caml_gc_phase == Phase_clean) caml_ephe_clean(ar); + if (elt == caml_ephe_none){ + res = None_val; + }else{ + if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(elt)){ caml_darken (elt, NULL); } res = caml_alloc_small (1, Some_tag); @@ -102,29 +268,29 @@ CAMLprim value caml_weak_get (value ar, value n) #undef Setup_for_gc #undef Restore_after_gc -CAMLprim value caml_weak_get_copy (value ar, value n) +CAMLprim value caml_ephe_get_key_copy (value ar, value n) { CAMLparam2 (ar, n); - mlsize_t offset = Long_val (n) + 1; + mlsize_t offset = Long_val (n) + 2; CAMLlocal2 (res, elt); value v; /* Caution: this is NOT a local root. */ Assert (Is_in_heap (ar)); if (offset < 1 || offset >= Wosize_val (ar)){ - caml_invalid_argument ("Weak.get"); + caml_invalid_argument ("Weak.get_copy"); } + if (is_ephe_key_none(ar, offset)) CAMLreturn (None_val); v = Field (ar, offset); - if (v == caml_weak_none) CAMLreturn (None_val); if (Is_block (v) && Is_in_heap_or_young(v)) { elt = caml_alloc (Wosize_val (v), Tag_val (v)); /* The GC may erase or move v during this call to caml_alloc. */ v = Field (ar, offset); - if (v == caml_weak_none) CAMLreturn (None_val); + if (is_ephe_key_none(ar, offset)) CAMLreturn (None_val); if (Tag_val (v) < No_scan_tag){ mlsize_t i; for (i = 0; i < Wosize_val (v); i++){ value f = Field (v, i); - if (caml_gc_phase == Phase_mark && Is_block (f) && Is_in_heap (f)){ + if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(f)){ caml_darken (f, NULL); } Modify (&Field (elt, i), f); @@ -141,21 +307,74 @@ CAMLprim value caml_weak_get_copy (value ar, value n) CAMLreturn (res); } -CAMLprim value caml_weak_check (value ar, value n) -{ - mlsize_t offset = Long_val (n) + 1; - Assert (Is_in_heap (ar)); - if (offset < 1 || offset >= Wosize_val (ar)){ - caml_invalid_argument ("Weak.get"); - } - return Val_bool (Field (ar, offset) != caml_weak_none); +CAMLprim value caml_weak_get_copy (value ar, value n){ + return caml_ephe_get_key_copy(ar,n); } -CAMLprim value caml_weak_blit (value ars, value ofs, +CAMLprim value caml_ephe_get_data_copy (value ar) +{ + CAMLparam1 (ar); + mlsize_t offset = 1; + CAMLlocal2 (res, elt); + value v; /* Caution: this is NOT a local root. */ + Assert (Is_in_heap (ar)); + + v = Field (ar, offset); + if (caml_gc_phase == Phase_clean) caml_ephe_clean(ar); + if (v == caml_ephe_none) CAMLreturn (None_val); + if (Is_block (v) && Is_in_heap_or_young(v)) { + elt = caml_alloc (Wosize_val (v), Tag_val (v)); + /* The GC may erase or move v during this call to caml_alloc. */ + v = Field (ar, offset); + if (caml_gc_phase == Phase_clean) caml_ephe_clean(ar); + if (v == caml_ephe_none) CAMLreturn (None_val); + if (Tag_val (v) < No_scan_tag){ + mlsize_t i; + for (i = 0; i < Wosize_val (v); i++){ + value f = Field (v, i); + if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(f)){ + caml_darken (f, NULL); + } + Modify (&Field (elt, i), f); + } + }else{ + memmove (Bp_val (elt), Bp_val (v), Bosize_val (v)); + } + }else{ + elt = v; + } + res = caml_alloc_small (1, Some_tag); + Field (res, 0) = elt; + + CAMLreturn (res); +} + +CAMLprim value caml_ephe_check_key (value ar, value n) +{ + mlsize_t offset = Long_val (n) + 2; + Assert (Is_in_heap (ar)); + if (offset < 2 || offset >= Wosize_val (ar)){ + caml_invalid_argument ("Weak.check"); + } + return Val_bool (!is_ephe_key_none(ar, offset)); +} + +CAMLprim value caml_weak_check (value ar, value n) +{ + return caml_ephe_check_key(ar,n); +} + +CAMLprim value caml_ephe_check_data (value ar) +{ + if(caml_gc_phase == Phase_clean) caml_ephe_clean(ar); + return Val_bool (Field (ar, CAML_EPHE_DATA_OFFSET) != caml_ephe_none); +} + +CAMLprim value caml_ephe_blit_key (value ars, value ofs, value ard, value ofd, value len) { - mlsize_t offset_s = Long_val (ofs) + 1; - mlsize_t offset_d = Long_val (ofd) + 1; + mlsize_t offset_s = Long_val (ofs) + 2; + mlsize_t offset_d = Long_val (ofd) + 2; mlsize_t length = Long_val (len); long i; Assert (Is_in_heap (ars)); @@ -166,14 +385,9 @@ CAMLprim value caml_weak_blit (value ars, value ofs, if (offset_d < 1 || offset_d + length > Wosize_val (ard)){ caml_invalid_argument ("Weak.blit"); } - if (caml_gc_phase == Phase_mark && caml_gc_subphase == Subphase_weak1){ - for (i = 0; i < length; i++){ - value v = Field (ars, offset_s + i); - if (v != caml_weak_none && Is_block (v) && Is_in_heap (v) - && Is_white_val (v)){ - Field (ars, offset_s + i) = caml_weak_none; - } - } + if (caml_gc_phase == Phase_clean){ + caml_ephe_clean(ars); + caml_ephe_clean(ard); } if (offset_d < offset_s){ for (i = 0; i < length; i++){ @@ -186,3 +400,19 @@ CAMLprim value caml_weak_blit (value ars, value ofs, } return Val_unit; } + +CAMLprim value caml_ephe_blit_data (value ars, value ard) +{ + if(caml_gc_phase == Phase_clean) { + caml_ephe_clean(ars); + caml_ephe_clean(ard); + }; + do_set (ard, CAML_EPHE_DATA_OFFSET, Field (ars, CAML_EPHE_DATA_OFFSET)); + return Val_unit; +} + +CAMLprim value caml_weak_blit (value ars, value ofs, + value ard, value ofd, value len) +{ + return caml_ephe_blit_key (ars, ofs, ard, ofd, len); +} diff --git a/config/Makefile.mingw b/config/Makefile.mingw index 5b4658f71..488effde8 100644 --- a/config/Makefile.mingw +++ b/config/Makefile.mingw @@ -86,6 +86,7 @@ RUNTIMED=noruntimed ASM_CFI_SUPPORTED=false UNIXLIB=win32unix GRAPHLIB=win32graph +FLAMBDA=false ########## Configuration for the bytecode compiler @@ -109,13 +110,28 @@ NATIVECCLIBS=-lws2_32 CPP=$(BYTECC) -E ### Flexlink -FLEXLINK=flexlink -chain mingw -stack 16777216 -link -static-libgcc -FLEXDIR:=$(shell $(FLEXLINK) -where) +FLEXLINK_CMD=flexlink +FLEXDLL_CHAIN=mingw +# FLEXLINK_FLAGS must be safe to insert in an OCaml string +# (see ocamlmklibconfig.ml in tools/Makefile.nt) +FLEXLINK_FLAGS=-chain $(FLEXDLL_CHAIN) -stack 16777216 -link -static-libgcc +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=$(FLEXLINK) -exe MKMAINDLL=$(FLEXLINK) -maindll +### Native command to build ocamlrun.exe without flexlink +MKEXE_BOOT=$(BYTECC) -o $(1) $(2) + ### How to build a static library MKLIB=rm -f $(1); $(TOOLPREF)ar rc $(1) $(2); $(RANLIB) $(1) #ml let mklib out files opts = Printf.sprintf "rm -f %s && %sar rcs %s %s %s" out toolpref opts out files;; @@ -173,5 +189,5 @@ OTOPDIR=$(WINTOPDIR) CTOPDIR=$(TOPDIR) CYGPATH=cygpath -m DIFF=diff -q --strip-trailing-cr -CANKILL=false SET_LD_PATH=PATH="$(PATH):$(LD_PATH)" +MAX_TESTSUITE_DIR_RETRIES=1 diff --git a/config/Makefile.mingw64 b/config/Makefile.mingw64 index 19a9b9437..2676958da 100644 --- a/config/Makefile.mingw64 +++ b/config/Makefile.mingw64 @@ -86,6 +86,7 @@ RUNTIMED=noruntimed ASM_CFI_SUPPORTED=false UNIXLIB=win32unix GRAPHLIB=win32graph +FLAMBDA=false ########## Configuration for the bytecode compiler @@ -109,13 +110,28 @@ NATIVECCLIBS=-lws2_32 CPP=$(BYTECC) -E ### Flexlink -FLEXLINK=flexlink -chain mingw64 -stack 33554432 -FLEXDIR:=$(shell $(FLEXLINK) -where) +FLEXLINK_CMD=flexlink +FLEXDLL_CHAIN=mingw64 +# FLEXLINK_FLAGS must be safe to insert in an OCaml string +# (see ocamlmklibconfig.ml in tools/Makefile.nt) +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=$(FLEXLINK) -exe MKMAINDLL=$(FLEXLINK) -maindll +### Native command to build ocamlrun.exe without flexlink +MKEXE_BOOT=$(BYTECC) -o $(1) $(2) + ### How to build a static library MKLIB=rm -f $(1); $(TOOLPREF)ar rc $(1) $(2); $(RANLIB) $(1) #ml let mklib out files opts = Printf.sprintf "rm -f %s && %sar rcs %s %s %s" out toolpref opts out files;; @@ -173,5 +189,5 @@ OTOPDIR=$(WINTOPDIR) CTOPDIR=$(TOPDIR) CYGPATH=cygpath -m DIFF=diff -q --strip-trailing-cr -CANKILL=false SET_LD_PATH=PATH="$(PATH):$(LD_PATH)" +MAX_TESTSUITE_DIR_RETRIES=1 diff --git a/config/Makefile.msvc b/config/Makefile.msvc index 4d399cf49..80679c278 100644 --- a/config/Makefile.msvc +++ b/config/Makefile.msvc @@ -77,6 +77,7 @@ RUNTIMED=noruntimed ASM_CFI_SUPPORTED=false UNIXLIB=win32unix GRAPHLIB=win32graph +FLAMBDA=false ########## Configuration for the bytecode compiler @@ -100,13 +101,29 @@ NATIVECCLIBS=advapi32.lib ws2_32.lib CPP=cl -nologo -EP ### Flexlink -FLEXLINK=flexlink -merge-manifest -stack 16777216 -FLEXDIR:=$(shell $(FLEXLINK) -where) +FLEXLINK_CMD=flexlink +FLEXDLL_CHAIN=msvc +# FLEXLINK_FLAGS must be safe to insert in an OCaml string +# (see ocamlmklibconfig.ml in tools/Makefile.nt) +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=$(FLEXLINK) -exe 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=$(BYTECC) /Fe$(1) $(2) /link /subsystem:console && ($(MERGEMANIFESTEXE)) + ### How to build a static library MKLIB=link -lib -nologo -out:$(1) $(2) #ml let mklib out files opts = Printf.sprintf "link -lib -nologo -out:%s %s %s" out opts files;; @@ -174,7 +191,7 @@ OTOPDIR=$(WINTOPDIR) CTOPDIR=$(WINTOPDIR) CYGPATH=cygpath -m DIFF=diff -q --strip-trailing-cr -CANKILL=false FIND=/usr/bin/find SORT=/usr/bin/sort SET_LD_PATH=PATH="$(PATH):$(LD_PATH)" +MAX_TESTSUITE_DIR_RETRIES=1 diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64 index 6a9650ba5..2abdbf344 100644 --- a/config/Makefile.msvc64 +++ b/config/Makefile.msvc64 @@ -76,6 +76,7 @@ RUNTIMED=noruntimed ASM_CFI_SUPPORTED=false UNIXLIB=win32unix GRAPHLIB=win32graph +FLAMBDA=false ########## Configuration for the bytecode compiler @@ -104,13 +105,29 @@ NATIVECCLIBS=advapi32.lib ws2_32.lib $(EXTRALIBS) CPP=cl -nologo -EP ### Flexlink -FLEXLINK=flexlink -x64 -merge-manifest -stack 33554432 -FLEXDIR:=$(shell $(FLEXLINK) -where) +FLEXLINK_CMD=flexlink +FLEXDLL_CHAIN=msvc64 +# FLEXLINK_FLAGS must be safe to insert in an OCaml string +# (see ocamlmklibconfig.ml in tools/Makefile.nt) +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=$(FLEXLINK) -exe 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=$(BYTECC) /Fe$(1) $(2) /link /subsystem:console && ($(MERGEMANIFESTEXE)) + ### How to build a static library MKLIB=link -lib -nologo -machine:AMD64 /out:$(1) $(2) #ml let mklib out files opts = Printf.sprintf "link -lib -nologo -machine:AMD64 -out:%s %s %s" out opts files;; @@ -178,7 +195,7 @@ OTOPDIR=$(WINTOPDIR) CTOPDIR=$(WINTOPDIR) CYGPATH=cygpath -m DIFF=diff -q --strip-trailing-cr -CANKILL=false FIND=/usr/bin/find SORT=/usr/bin/sort SET_LD_PATH=PATH="$(PATH):$(LD_PATH)" +MAX_TESTSUITE_DIR_RETRIES=1 diff --git a/configure b/configure index d1d36094a..30b0c02fd 100755 --- a/configure +++ b/configure @@ -51,6 +51,8 @@ no_naked_pointers=false native_compiler=true TOOLPREF="" with_cfi=true +flambda=false +max_testsuite_dir_retries=0 # Try to turn internationalization off, can cause config.guess to malfunction! unset LANG @@ -162,6 +164,8 @@ while : ; do with_cfi=false;; -no-native-compiler) native_compiler=false;; + -flambda) + flambda=true;; *) if echo "$1" | grep -q -e '^--\?[a-zA-Z0-9-]\+='; then err "configure expects arguments of the form '-prefix /foo/bar'," \ "not '-prefix=/foo/bar' (note the '=')." @@ -1058,6 +1062,23 @@ if test "$with_curses" = "yes"; then done fi +# For instrumented runtime +# (clock_gettime needs -lrt for glibc before 2.17) +if $with_instrumented_runtime; then + with_instrumented_runtime=false #enabled it only if found + for libs in "" "-lrt"; do + if sh ./hasgot $libs clock_gettime; then + inf "clock_gettime functions found (with libraries '$libs')" + instrumented_runtime_libs="${libs}" + with_instrumented_runtime=true; + break + fi + done + if ! $with_instrumented_runtime; then + err "clock_gettime functions not found. Instrumented runtime can't be built." + fi +fi + # Configuration for the libraries case "$system" in @@ -1716,7 +1737,8 @@ cclibs="$cclibs $mathlib" echo "BYTECC=$bytecc" >> Makefile echo "BYTECCCOMPOPTS=$bytecccompopts" >> Makefile echo "BYTECCLINKOPTS=$bytecclinkopts" >> Makefile -echo "BYTECCLIBS=$cclibs $dllib $curseslibs $pthread_link" >> Makefile +echo "BYTECCLIBS=$cclibs $dllib $curseslibs $pthread_link \ + $instrumented_runtime_libs" >> Makefile echo "BYTECCRPATH=$byteccrpath" >> Makefile echo "EXE=$exe" >> Makefile echo "SUPPORTS_SHARED_LIBRARIES=$shared_libraries_supported" >> Makefile @@ -1788,6 +1810,8 @@ echo "HOST=$host" >> Makefile if [ "$ostype" = Cygwin ]; then echo "DIFF=diff -q --strip-trailing-cr" >>Makefile fi +echo "FLAMBDA=$flambda" >> Makefile +echo "MAX_TESTSUITE_DIR_RETRIES=$max_testsuite_dir_retries" >> Makefile rm -f tst hasgot.c @@ -1856,6 +1880,11 @@ else else inf " profiling with gprof ..... not supported" fi + if test "$flambda" = "true"; then + inf " using flambda middle-end . yes" + else + inf " using flambda middle-end . no" + fi fi if test "$with_debugger" = "ocamldebugger"; then diff --git a/debugger/Makefile.shared b/debugger/Makefile.shared index 096d61823..30df6492d 100644 --- a/debugger/Makefile.shared +++ b/debugger/Makefile.shared @@ -30,14 +30,14 @@ INCLUDES=\ OTHEROBJS=\ $(UNIXDIR)/unix.cma \ - ../utils/config.cmo ../utils/tbl.cmo \ - ../utils/clflags.cmo ../utils/misc.cmo \ + ../utils/config.cmo ../utils/tbl.cmo ../utils/misc.cmo \ ../utils/identifiable.cmo ../utils/numbers.cmo \ + ../utils/arg_helper.cmo ../utils/clflags.cmo \ ../utils/consistbl.cmo ../utils/warnings.cmo \ ../utils/terminfo.cmo \ ../parsing/location.cmo ../parsing/longident.cmo ../parsing/docstrings.cmo \ ../parsing/ast_helper.cmo ../parsing/ast_mapper.cmo \ - ../parsing/attr_helper.cmo \ + ../parsing/ast_iterator.cmo ../parsing/attr_helper.cmo \ ../parsing/builtin_attributes.cmo \ ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \ ../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \ diff --git a/driver/compenv.ml b/driver/compenv.ml index 42d98bca6..f8933dcdb 100644 --- a/driver/compenv.ml +++ b/driver/compenv.ml @@ -93,9 +93,10 @@ let module_of_filename ppf inputfile outputprefix = name ;; +type filename = string type readenv_position = - Before_args | Before_compile | Before_link + Before_args | Before_compile of filename | Before_link (* Syntax of OCAMLPARAM: (name=VALUE,)* _ (,name=VALUE)* where VALUE should not contain ',' *) @@ -138,10 +139,242 @@ let setter ppf f name options s = (Warnings.Bad_env_variable ("OCAMLPARAM", Printf.sprintf "bad value for %s" name)) +let int_setter ppf name option s = + try + option := int_of_string s + with _ -> + Location.print_warning Location.none ppf + (Warnings.Bad_env_variable + ("OCAMLPARAM", Printf.sprintf "non-integer parameter for \"%s\"" name)) + +let float_setter ppf name option s = + try + option := float_of_string s + with _ -> + Location.print_warning Location.none ppf + (Warnings.Bad_env_variable + ("OCAMLPARAM", Printf.sprintf "non-float parameter for \"%s\"" name)) + (* 'can-discard=' specifies which arguments can be discarded without warning because they are not understood by some versions of OCaml. *) let can_discard = ref [] +let read_one_param ppf position name v = + let set name options s = setter ppf (fun b -> b) name options s in + 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 + | "annot" -> set "annot" [ Clflags.annotations ] v + | "absname" -> set "absname" [ Location.absname ] v + | "compat-32" -> set "compat-32" [ bytecode_compatible_32 ] v + | "noassert" -> set "noassert" [ noassert ] v + | "noautolink" -> set "noautolink" [ no_auto_link ] v + | "nostdlib" -> set "nostdlib" [ no_std_include ] v + | "linkall" -> set "linkall" [ link_everything ] v + | "nolabels" -> set "nolabels" [ classic ] v + | "principal" -> set "principal" [ principal ] v + | "rectypes" -> set "rectypes" [ recursive_types ] v + | "safe-string" -> clear "safe-string" [ unsafe_string ] v + | "strict-sequence" -> set "strict-sequence" [ strict_sequence ] v + | "strict-formats" -> set "strict-formats" [ strict_formats ] v + | "thread" -> set "thread" [ use_threads ] v + | "unsafe" -> set "unsafe" [ fast ] v + | "verbose" -> set "verbose" [ verbose ] v + | "nopervasives" -> set "nopervasives" [ nopervasives ] v + | "slash" -> set "slash" [ force_slash ] v (* for ocamldep *) + | "keep-docs" -> set "keep-docs" [ Clflags.keep_docs ] v + | "keep-locs" -> set "keep-locs" [ Clflags.keep_locs ] v + + | "compact" -> clear "compact" [ optimize_for_speed ] v + | "no-app-funct" -> clear "no-app-funct" [ applicative_functors ] v + | "nodynlink" -> clear "nodynlink" [ dlcode ] v + | "short-paths" -> clear "short-paths" [ real_paths ] v + | "trans-mod" -> set "trans-mod" [ transparent_modules ] v + | "opaque" -> set "opaque" [ opaque ] v + + | "pp" -> preprocessor := Some v + | "runtime-variant" -> runtime_variant := v + | "cc" -> c_compiler := Some v + + | "clambda-checks" -> set "clambda-checks" [ clambda_checks ] v + + (* assembly sources *) + | "s" -> + set "s" [ Clflags.keep_asm_file ; Clflags.keep_startup_file ] v + | "S" -> set "S" [ Clflags.keep_asm_file ] v + | "dstartup" -> set "dstartup" [ Clflags.keep_startup_file ] v + + (* warn-errors *) + | "we" | "warn-error" -> Warnings.parse_options true v + (* warnings *) + | "w" -> Warnings.parse_options false v + (* warn-errors *) + | "wwe" -> Warnings.parse_options false v + + (* inlining *) + | "inline" -> + let module F = Float_arg_helper in + begin match F.parse_no_error v inline_threshold with + | F.Ok -> () + | F.Parse_failed exn -> + let error = + Printf.sprintf "bad syntax for \"inline\": %s" + (Printexc.to_string exn) + in + Location.print_warning Location.none ppf + (Warnings.Bad_env_variable ("OCAMLPARAM", error)) + end + + | "inline-toplevel" -> + Int_arg_helper.parse v + "Bad syntax in OCAMLPARAM for 'inline-toplevel'" + inline_toplevel_threshold + + | "rounds" -> int_setter ppf "rounds" simplify_rounds v + | "unroll" -> + Int_arg_helper.parse v "Bad syntax in OCAMLPARAM for 'unroll'" + unroll + | "inline-call-cost" -> + Int_arg_helper.parse v + "Bad syntax in OCAMLPARAM for 'inline-call-cost'" + inline_call_cost + | "inline-alloc-cost" -> + Int_arg_helper.parse v + "Bad syntax in OCAMLPARAM for 'inline-alloc-cost'" + inline_alloc_cost + | "inline-prim-cost" -> + Int_arg_helper.parse v + "Bad syntax in OCAMLPARAM for 'inline-prim-cost'" + inline_prim_cost + | "inline-branch-cost" -> + Int_arg_helper.parse v + "Bad syntax in OCAMLPARAM for 'inline-branch-cost'" + inline_branch_cost + | "inline-indirect-cost" -> + Int_arg_helper.parse v + "Bad syntax in OCAMLPARAM for 'inline-indirect-cost'" + inline_indirect_cost + | "inline-lifting-benefit" -> + Int_arg_helper.parse v + "Bad syntax in OCAMLPARAM for 'inline-lifting-benefit'" + inline_lifting_benefit + | "branch-inline-factor" -> + Float_arg_helper.parse v + "Bad syntax in OCAMLPARAM for 'branch-inline-factor'" + branch_inline_factor + | "max-inlining-depth" -> + Int_arg_helper.parse v + "Bad syntax in OCAMLPARAM for 'max-inlining-depth'" + max_inlining_depth + + | "classic-inlining" -> + set "classic-inlining" [ classic_inlining ] v + | "O2" -> + set "O2" [ o2 ] v + | "O3" -> + set "O3" [ o3 ] v + | "unbox-closures" -> + set "unbox-closures" [ unbox_closures ] v + | "remove-unused-arguments" -> + set "remove-unused-arguments" [ remove_unused_arguments ] v + | "no-inline-recursive-functions" -> + clear "no-inline-recursive-functions" [ inline_recursive_functions ] v + + | "inlining-report" -> + if !native_code then + set "inlining-report" [ inlining_stats ] v + + | "flambda-verbose" -> + set "flambda-verbose" [ dump_flambda_verbose ] v + | "flambda-invariants" -> + set "flambda-invariants" [ flambda_invariant_checks ] v + + (* color output *) + | "color" -> + begin match parse_color_setting v with + | None -> + Location.print_warning Location.none ppf + (Warnings.Bad_env_variable ("OCAMLPARAM", + "bad value for \"color\", \ + (expected \"auto\", \"always\" or \"never\")")) + | Some setting -> color := setting + end + + | "intf-suffix" -> Config.interface_suffix := v + + | "I" -> begin + match position with + | Before_args -> first_include_dirs := v :: !first_include_dirs + | Before_link | Before_compile _ -> + last_include_dirs := v :: !last_include_dirs + end + + | "cclib" -> + begin + match position with + | Before_compile _ -> () + | Before_link | Before_args -> + ccobjs := Misc.rev_split_words v @ !ccobjs + end + + | "ccopts" -> + begin + match position with + | Before_link | Before_compile _ -> + last_ccopts := v :: !last_ccopts + | Before_args -> + first_ccopts := v :: !first_ccopts + end + + | "ppx" -> + begin + match position with + | Before_link | Before_compile _ -> + last_ppx := v :: !last_ppx + | Before_args -> + first_ppx := v :: !first_ppx + end + + + | "cmo" | "cma" -> + if not !native_code then + begin + match position with + | Before_link | Before_compile _ -> + last_objfiles := v ::! last_objfiles + | Before_args -> + first_objfiles := v :: !first_objfiles + end + + | "cmx" | "cmxa" -> + if !native_code then + begin + match position with + | Before_link | Before_compile _ -> + last_objfiles := v ::! last_objfiles + | Before_args -> + first_objfiles := v :: !first_objfiles + end + + | "pic" -> + if !native_code then + set "pic" [ pic_code ] v + + | "can-discard" -> + can_discard := v ::!can_discard + + | "timings" -> set "timings" [ print_timings ] v + + | _ -> + if not (List.mem name !can_discard) then begin + can_discard := name :: !can_discard; + Printf.eprintf + "Warning: discarding value of variable %S in OCAMLPARAM\n%!" + name + end + let read_OCAMLPARAM ppf position = try let s = Sys.getenv "OCAMLPARAM" in @@ -153,159 +386,105 @@ let read_OCAMLPARAM ppf position = (Warnings.Bad_env_variable ("OCAMLPARAM", s)); [],[] in - let set name options s = setter ppf (fun b -> b) name options s in - let clear name options s = setter ppf (fun b -> not b) name options s in - List.iter (fun (name, v) -> - match name with - | "g" -> set "g" [ Clflags.debug ] v - | "p" -> set "p" [ Clflags.gprofile ] v - | "bin-annot" -> set "bin-annot" [ Clflags.binary_annotations ] v - | "annot" -> set "annot" [ Clflags.annotations ] v - | "absname" -> set "absname" [ Location.absname ] v - | "compat-32" -> set "compat-32" [ bytecode_compatible_32 ] v - | "noassert" -> set "noassert" [ noassert ] v - | "noautolink" -> set "noautolink" [ no_auto_link ] v - | "nostdlib" -> set "nostdlib" [ no_std_include ] v - | "linkall" -> set "linkall" [ link_everything ] v - | "nolabels" -> set "nolabels" [ classic ] v - | "principal" -> set "principal" [ principal ] v - | "rectypes" -> set "rectypes" [ recursive_types ] v - | "safe-string" -> clear "safe-string" [ unsafe_string ] v - | "strict-sequence" -> set "strict-sequence" [ strict_sequence ] v - | "strict-formats" -> set "strict-formats" [ strict_formats ] v - | "thread" -> set "thread" [ use_threads ] v - | "unsafe" -> set "unsafe" [ fast ] v - | "verbose" -> set "verbose" [ verbose ] v - | "nopervasives" -> set "nopervasives" [ nopervasives ] v - | "slash" -> set "slash" [ force_slash ] v (* for ocamldep *) - | "keep-docs" -> set "keep-docs" [ Clflags.keep_docs ] v - | "keep-locs" -> set "keep-locs" [ Clflags.keep_locs ] v - - | "compact" -> clear "compact" [ optimize_for_speed ] v - | "no-app-funct" -> clear "no-app-funct" [ applicative_functors ] v - | "nodynlink" -> clear "nodynlink" [ dlcode ] v - | "short-paths" -> clear "short-paths" [ real_paths ] v - | "trans-mod" -> set "trans-mod" [ transparent_modules ] v - - | "pp" -> preprocessor := Some v - | "runtime-variant" -> runtime_variant := v - | "cc" -> c_compiler := Some v - - (* assembly sources *) - | "s" -> - set "s" [ Clflags.keep_asm_file ; Clflags.keep_startup_file ] v - | "S" -> set "S" [ Clflags.keep_asm_file ] v - | "dstartup" -> set "dstartup" [ Clflags.keep_startup_file ] v - - (* warn-errors *) - | "we" | "warn-error" -> Warnings.parse_options true v - (* warnings *) - | "w" -> Warnings.parse_options false v - (* warn-errors *) - | "wwe" -> Warnings.parse_options false v - - (* inlining *) - | "inline" -> begin try - inline_threshold := 8 * int_of_string v - with _ -> - Location.print_warning Location.none ppf - (Warnings.Bad_env_variable ("OCAMLPARAM", - "non-integer parameter for \"inline\"")) - end - - (* color output *) - | "color" -> - begin match parse_color_setting v with - | None -> - Location.print_warning Location.none ppf - (Warnings.Bad_env_variable ("OCAMLPARAM", - "bad value for \"color\", \ - (expected \"auto\", \"always\" or \"never\")")) - | Some setting -> color := setting - end - - | "intf-suffix" -> Config.interface_suffix := v - - | "I" -> begin - match position with - | Before_args -> first_include_dirs := v :: !first_include_dirs - | Before_link | Before_compile -> - last_include_dirs := v :: !last_include_dirs - end - - | "cclib" -> - begin - match position with - | Before_compile -> () - | Before_link | Before_args -> - ccobjs := Misc.rev_split_words v @ !ccobjs - end - - | "ccopts" -> - begin - match position with - | Before_link | Before_compile -> - last_ccopts := v :: !last_ccopts - | Before_args -> - first_ccopts := v :: !first_ccopts - end - - | "ppx" -> - begin - match position with - | Before_link | Before_compile -> - last_ppx := v :: !last_ppx - | Before_args -> - first_ppx := v :: !first_ppx - end - - - | "cmo" | "cma" -> - if not !native_code then - begin - match position with - | Before_link | Before_compile -> - last_objfiles := v ::! last_objfiles - | Before_args -> - first_objfiles := v :: !first_objfiles - end - - | "cmx" | "cmxa" -> - if !native_code then - begin - match position with - | Before_link | Before_compile -> - last_objfiles := v ::! last_objfiles - | Before_args -> - first_objfiles := v :: !first_objfiles - end - - | "pic" -> - if !native_code then - set "pic" [ pic_code ] v - - | "can-discard" -> - can_discard := v ::!can_discard - - | "timings" -> set "timings" [ print_timings ] v - - | _ -> - if not (List.mem name !can_discard) then begin - can_discard := name :: !can_discard; - Printf.eprintf - "Warning: discarding value of variable %S in OCAMLPARAM\n%!" - name - end - ) (match position with - Before_args -> before - | Before_compile | Before_link -> after) + List.iter (fun (name, v) -> read_one_param ppf position name v) + (match position with + Before_args -> before + | Before_compile _ | Before_link -> after) with Not_found -> () +(* OCAMLPARAM passed as file *) + +type pattern = + | Filename of string + | Any + +type file_option = { + pattern : pattern; + name : string; + value : string; +} + +let scan_line ic = + Scanf.bscanf ic "%[0-9a-zA-Z_.*] : %[a-zA-Z_-] = %s " + (fun pattern name value -> + let pattern = + match pattern with + | "*" -> Any + | _ -> Filename pattern + in + { pattern; name; value }) + +let load_config ppf filename = + match open_in_bin filename with + | exception e -> + Location.print_error ppf (Location.in_file filename); + Format.fprintf ppf "Cannot open file %s@." (Printexc.to_string e); + raise Exit + | ic -> + let sic = Scanf.Scanning.from_channel ic in + let rec read line_number line_start acc = + match scan_line sic with + | exception End_of_file -> + close_in ic; + acc + | exception Scanf.Scan_failure error -> + let position = Lexing.{ + pos_fname = filename; + pos_lnum = line_number; + pos_bol = line_start; + pos_cnum = pos_in ic; + } + in + let loc = Location.{ + loc_start = position; + loc_end = position; + loc_ghost = false; + } + in + Location.print_error ppf loc; + Format.fprintf ppf "Configuration file error %s@." error; + close_in ic; + raise Exit + | line -> + read (line_number + 1) (pos_in ic) (line :: acc) + in + let lines = read 0 0 [] in + lines + +let matching_filename filename { pattern } = + match pattern with + | Any -> true + | Filename pattern -> + let filename = String.lowercase_ascii filename in + let pattern = String.lowercase_ascii pattern in + filename = pattern + +let apply_config_file ppf position = + let config_file = + Filename.concat Config.standard_library "ocaml_compiler_internal_params" + in + let config = + if Sys.file_exists config_file then + load_config ppf config_file + else + [] + in + let config = + match position with + | Before_compile filename -> + List.filter (matching_filename filename) config + | Before_args | Before_link -> + List.filter (fun { pattern } -> pattern = Any) config + in + List.iter (fun { name; value } -> read_one_param ppf position name value) + config + let readenv ppf position = last_include_dirs := []; last_ccopts := []; last_ppx := []; last_objfiles := []; + apply_config_file ppf position; read_OCAMLPARAM ppf position; all_ccopts := !last_ccopts @ !first_ccopts; all_ppx := !last_ppx @ !first_ppx diff --git a/driver/compenv.mli b/driver/compenv.mli index 59cd10124..a7aeb1b4e 100644 --- a/driver/compenv.mli +++ b/driver/compenv.mli @@ -30,8 +30,10 @@ val implicit_modules : string list ref (* return the list of objfiles, after OCAMLPARAM and List.rev *) val get_objfiles : unit -> string list +type filename = string + type readenv_position = - Before_args | Before_compile | Before_link + Before_args | Before_compile of filename | Before_link val readenv : Format.formatter -> readenv_position -> unit diff --git a/driver/main.ml b/driver/main.ml index 50ef9748e..228d691ac 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -54,11 +54,11 @@ let ppf = Format.err_formatter (* Error messages to standard error formatter *) let anonymous filename = - readenv ppf Before_compile; process_file ppf filename;; + readenv ppf (Before_compile filename); process_file ppf filename;; let impl filename = - readenv ppf Before_compile; process_implementation_file ppf filename;; + readenv ppf (Before_compile filename); process_implementation_file ppf filename;; let intf filename = - readenv ppf Before_compile; process_interface_file ppf filename;; + readenv ppf (Before_compile filename); process_interface_file ppf filename;; let show_config () = Config.print_config stdout; diff --git a/driver/main_args.ml b/driver/main_args.ml index 9b3c6f19f..df4ded0ec 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -43,6 +43,10 @@ let mk_ccopt f = " Pass option to the C compiler and linker" ;; +let mk_clambda_checks f = + "-clambda-checks", Arg.Unit f, " Instrument clambda code with closure and field access checks (for debugging the compiler)" +;; + let mk_compact f = "-compact", Arg.Unit f, " Optimize code size rather than speed" ;; @@ -110,7 +114,91 @@ let mk_init f = ;; let mk_inline f = - "-inline", Arg.Int f, " Set aggressiveness of inlining to " + "-inline", Arg.String f, + Printf.sprintf "|=[,...] Aggressiveness of inlining \ + (default %.02f, higher numbers mean more aggressive)" + Clflags.default_inline_threshold +;; + +let mk_inline_toplevel f = + "-inline-toplevel", Arg.String f, + Printf.sprintf "|=[,...] Aggressiveness of inlining at \ + toplevel (higher numbers mean more aggressive)" +;; + +let mk_inlining_stats f = + "-inlining-report", Arg.Unit f, " Emit `..inlining' file(s) (one per \ + round) showing the inliner's decisions" +;; + +let mk_dump_pass f = + "-dump-pass", Arg.String f, + Format.asprintf " Record transformations performed by these passes: %a" + (Format.pp_print_list Format.pp_print_string) + !Clflags.all_passes +;; + +let mk_o2 f = + "-O2", Arg.Unit f, " Apply increased optimization for speed" +;; + +let mk_o3 f = + "-O3", Arg.Unit f, " Apply aggressive optimization for speed (may \ + significantly increase code size and compilation time)" +;; + +let mk_rounds f = + "-rounds", Arg.Int f, + Printf.sprintf " Repeat tree optimization and inlining phases this \ + many times (default %d). Rounds are numbered starting from zero." + !Clflags.simplify_rounds +;; + +let mk_unroll f = + "-unroll", Arg.String f, + Printf.sprintf "|=[,...] Unroll recursive functions at most this many times \ + (default %d)" + Clflags.default_unroll +;; + +let mk_classic_inlining f = + "-classic-inlining", Arg.Unit f, " Make inlining decisions at function definition time \ + rather than at the call site (replicates previous behaviour of the compiler)" +;; + +let mk_inline_cost arg descr default f = + Printf.sprintf "-inline-%s-cost" arg, + Arg.String f, + Printf.sprintf "|=[,...] The cost of not removing %s during inlining \ + (default %d, higher numbers more costly)" + descr + default +;; + +let mk_inline_call_cost = + mk_inline_cost "call" "a call" Clflags.default_inline_call_cost +let mk_inline_alloc_cost = + mk_inline_cost "alloc" "an allocation" Clflags.default_inline_alloc_cost +let mk_inline_prim_cost = + mk_inline_cost "prim" "a primitive" Clflags.default_inline_prim_cost +let mk_inline_branch_cost = + mk_inline_cost "branch" "a conditional" Clflags.default_inline_branch_cost +let mk_inline_indirect_cost = + mk_inline_cost "indirect" "an indirect call" Clflags.default_inline_indirect_cost + +let mk_inline_lifting_benefit f = + "-inline-lifting-benefit", + Arg.String f, + Printf.sprintf "|=[,...] The benefit of lifting definitions \ + to toplevel during inlining (default %d, higher numbers more beneficial)" + Clflags.default_inline_lifting_benefit +;; + +let mk_branch_inline_factor f = + "-branch-inline-factor", Arg.String f, + Printf.sprintf "|=[,...] Estimate the probability of a \ + branch being cold as 1/(1+n) (used for inlining) (default %.2f)" + Clflags.default_branch_inline_factor ;; let mk_intf f = @@ -151,6 +239,13 @@ let mk_make_runtime_2 f = "-make_runtime", Arg.Unit f, " (deprecated) same as -make-runtime" ;; +let mk_max_inlining_depth f = + "-max-inlining-depth", Arg.String f, + Printf.sprintf "|=[,...] Maximum depth of search for inlining opportunities \ + inside inlined functions (default %d)" + Clflags.default_max_inlining_depth +;; + let mk_modern f = "-modern", Arg.Unit f, " (deprecated) same as -labels" ;; @@ -196,6 +291,11 @@ let mk_noinit f = "-noinit", Arg.Unit f, " Do not load any init file" +let mk_no_inline_recursive_functions f = + "-no-inline-recursive-functions", Arg.Unit f, + " Do not duplicate and specialise declarations of recursive functions" +;; + let mk_nolabels f = "-nolabels", Arg.Unit f, " Ignore non-optional labels in types" ;; @@ -261,6 +361,11 @@ let mk_rectypes f = "-rectypes", Arg.Unit f, " Allow arbitrary recursive types" ;; +let mk_remove_unused_arguments f = + "-remove-unused-arguments", Arg.Unit f, + " Remove unused function arguments (experimental)" +;; + let mk_runtime_variant f = "-runtime-variant", Arg.String f, " Use the variant of the run-time system" @@ -300,6 +405,11 @@ let mk_dtimings f = "-dtimings", Arg.Unit f, " Print timings" ;; +let mk_unbox_closures f = + "-unbox-closures", Arg.Unit f, + " Unbox closures into function arguments (experimental)" +;; + let mk_unsafe f = "-unsafe", Arg.Unit f, " Do not compile bounds checking on array and string access" @@ -417,10 +527,30 @@ let mk_dlambda f = "-dlambda", Arg.Unit f, " (undocumented)" ;; +let mk_drawclambda f = + "-drawclambda", Arg.Unit f, " (undocumented)" +;; + let mk_dclambda f = "-dclambda", Arg.Unit f, " (undocumented)" ;; +let mk_dflambda f = + "-dflambda", Arg.Unit f, " Print Flambda terms" +;; + +let mk_dflambda_invariants f = + "-dflambda-invariants", Arg.Unit f, " Check Flambda invariants around each pass" +;; + +let mk_dflambda_let f = + "-dflambda-let", Arg.Int f, " Print when the given Flambda [Let] is created" +;; + +let mk_dflambda_verbose f = + "-dflambda-verbose", Arg.Unit f, " Print Flambda terms including around each pass" +;; + let mk_dinstr f = "-dinstr", Arg.Unit f, " (undocumented)" ;; @@ -605,8 +735,33 @@ end;; module type Optcommon_options = sig val _compact : unit -> unit - val _inline : int -> unit + val _inline : string -> unit + val _inline_toplevel : string -> unit + val _inlining_stats : unit -> unit + val _dump_pass : string -> unit + val _max_inlining_depth : string -> unit + val _rounds : int -> unit + val _unroll : string -> unit + val _classic_inlining : unit -> unit + val _inline_call_cost : string -> unit + val _inline_alloc_cost : string -> unit + val _inline_prim_cost : string -> unit + val _inline_branch_cost : string -> unit + val _inline_indirect_cost : string -> unit + val _inline_lifting_benefit : string -> unit + val _unbox_closures : unit -> unit + val _branch_inline_factor : string -> unit + val _no_inline_recursive_functions : unit -> unit + val _remove_unused_arguments : unit -> unit + val _o2 : unit -> unit + val _o3 : unit -> unit + val _clambda_checks : unit -> unit + val _dflambda : unit -> unit + val _dflambda_invariants : unit -> unit + val _dflambda_let : int -> unit + val _dflambda_verbose : unit -> unit + val _drawclambda : unit -> unit val _dclambda : unit -> unit val _dcmm : unit -> unit val _dsel : unit -> unit @@ -801,10 +956,13 @@ struct mk_absname F._absname; mk_annot F._annot; mk_binannot F._binannot; + mk_branch_inline_factor F._branch_inline_factor; mk_c F._c; mk_cc F._cc; mk_cclib F._cclib; mk_ccopt F._ccopt; + mk_clambda_checks F._clambda_checks; + mk_classic_inlining F._classic_inlining; mk_color F._color; mk_compact F._compact; mk_config F._config; @@ -815,21 +973,33 @@ struct mk_I F._I; mk_impl F._impl; mk_inline F._inline; + mk_inline_toplevel F._inline_toplevel; + mk_inline_alloc_cost F._inline_alloc_cost; + mk_inline_branch_cost F._inline_branch_cost; + mk_inline_call_cost F._inline_call_cost; + mk_inline_prim_cost F._inline_prim_cost; + mk_inline_indirect_cost F._inline_indirect_cost; + mk_inline_lifting_benefit F._inline_lifting_benefit; + mk_inlining_stats F._inlining_stats; mk_intf F._intf; mk_intf_suffix F._intf_suffix; mk_keep_docs F._keep_docs; mk_keep_locs F._keep_locs; mk_labels F._labels; mk_linkall F._linkall; + mk_max_inlining_depth F._max_inlining_depth; mk_no_alias_deps F._no_alias_deps; mk_no_app_funct F._no_app_funct; mk_no_float_const_prop F._no_float_const_prop; mk_noassert F._noassert; mk_noautolink_opt F._noautolink; mk_nodynlink F._nodynlink; + mk_no_inline_recursive_functions F._no_inline_recursive_functions; mk_nolabels F._nolabels; mk_nostdlib F._nostdlib; mk_o F._o; + mk_o2 F._o2; + mk_o3 F._o3; mk_open F._open; mk_output_obj F._output_obj; mk_output_complete_obj F._output_complete_obj; @@ -839,6 +1009,8 @@ struct mk_ppx F._ppx; mk_principal F._principal; mk_rectypes F._rectypes; + mk_remove_unused_arguments F._remove_unused_arguments; + mk_rounds F._rounds; mk_runtime_variant F._runtime_variant; mk_S F._S; mk_safe_string F._safe_string; @@ -847,6 +1019,8 @@ struct mk_strict_sequence F._strict_sequence; mk_strict_formats F._strict_formats; mk_thread F._thread; + mk_unbox_closures F._unbox_closures; + mk_unroll F._unroll; mk_unsafe F._unsafe; mk_unsafe_string F._unsafe_string; mk_v F._v; @@ -866,7 +1040,12 @@ struct mk_dtypedtree F._dtypedtree; mk_drawlambda F._drawlambda; mk_dlambda F._dlambda; + mk_drawclambda F._drawclambda; mk_dclambda F._dclambda; + mk_dflambda F._dflambda; + mk_dflambda_invariants F._dflambda_invariants; + mk_dflambda_let F._dflambda_let; + mk_dflambda_verbose F._dflambda_verbose; mk_dcmm F._dcmm; mk_dsel F._dsel; mk_dcombine F._dcombine; @@ -882,6 +1061,7 @@ struct mk_dlinear F._dlinear; mk_dstartup F._dstartup; mk_dtimings F._dtimings; + mk_dump_pass F._dump_pass; mk_opaque F._opaque; ] end;; @@ -893,25 +1073,42 @@ module Make_opttop_options (F : Opttop_options) = struct mk_I F._I; mk_init F._init; mk_inline F._inline; + mk_inline_toplevel F._inline_toplevel; + mk_inlining_stats F._inlining_stats; + mk_rounds F._rounds; + mk_unroll F._unroll; + mk_classic_inlining F._classic_inlining; + mk_inline_call_cost F._inline_call_cost; + mk_inline_alloc_cost F._inline_alloc_cost; + mk_inline_prim_cost F._inline_prim_cost; + mk_inline_branch_cost F._inline_branch_cost; + mk_inline_indirect_cost F._inline_indirect_cost; + mk_inline_lifting_benefit F._inline_lifting_benefit; + mk_branch_inline_factor F._branch_inline_factor; mk_labels F._labels; mk_no_alias_deps F._no_alias_deps; mk_no_app_funct F._no_app_funct; mk_noassert F._noassert; mk_noinit F._noinit; + mk_no_inline_recursive_functions F._no_inline_recursive_functions; mk_nolabels F._nolabels; mk_noprompt F._noprompt; mk_nopromptcont F._nopromptcont; mk_nostdlib F._nostdlib; + mk_o2 F._o2; + mk_o3 F._o3; mk_open F._open; mk_ppx F._ppx; mk_principal F._principal; mk_rectypes F._rectypes; + mk_remove_unused_arguments F._remove_unused_arguments; mk_S F._S; mk_safe_string F._safe_string; mk_short_paths F._short_paths; mk_stdin F._stdin; mk_strict_sequence F._strict_sequence; mk_strict_formats F._strict_formats; + mk_unbox_closures F._unbox_closures; mk_unsafe F._unsafe; mk_unsafe_string F._unsafe_string; mk_version F._version; @@ -926,7 +1123,9 @@ module Make_opttop_options (F : Opttop_options) = struct mk_dparsetree F._dparsetree; mk_dtypedtree F._dtypedtree; mk_drawlambda F._drawlambda; + mk_drawclambda F._drawclambda; mk_dclambda F._dclambda; + mk_dflambda F._dflambda; mk_dcmm F._dcmm; mk_dsel F._dsel; mk_dcombine F._dcombine; @@ -941,6 +1140,7 @@ module Make_opttop_options (F : Opttop_options) = struct mk_dscheduling F._dscheduling; mk_dlinear F._dlinear; mk_dstartup F._dstartup; + mk_dump_pass F._dump_pass; ] end;; diff --git a/driver/main_args.mli b/driver/main_args.mli index bc14432d5..f45662e32 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -117,8 +117,33 @@ end;; module type Optcommon_options = sig val _compact : unit -> unit - val _inline : int -> unit + val _inline : string -> unit + val _inline_toplevel : string -> unit + val _inlining_stats : unit -> unit + val _dump_pass : string -> unit + val _max_inlining_depth : string -> unit + val _rounds : int -> unit + val _unroll : string -> unit + val _classic_inlining : unit -> unit + val _inline_call_cost : string -> unit + val _inline_alloc_cost : string -> unit + val _inline_prim_cost : string -> unit + val _inline_branch_cost : string -> unit + val _inline_indirect_cost : string -> unit + val _inline_lifting_benefit : string -> unit + val _unbox_closures : unit -> unit + val _branch_inline_factor : string -> unit + val _no_inline_recursive_functions : unit -> unit + val _remove_unused_arguments : unit -> unit + val _o2 : unit -> unit + val _o3 : unit -> unit + val _clambda_checks : unit -> unit + val _dflambda : unit -> unit + val _dflambda_invariants : unit -> unit + val _dflambda_let : int -> unit + val _dflambda_verbose : unit -> unit + val _drawclambda : unit -> unit val _dclambda : unit -> unit val _dcmm : unit -> unit val _dsel : unit -> unit diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 0ea9e72b0..9592de1a1 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -58,7 +58,7 @@ let print_if ppf flag printer arg = let (++) x f = f x let (+++) (x, y) f = (x, f y) -let implementation ppf sourcefile outputprefix = +let implementation ppf sourcefile outputprefix ~backend = let source_provenance = Timings.File sourcefile in Compmisc.init_path true; let modulename = module_of_filename ppf sourcefile outputprefix in @@ -75,19 +75,58 @@ let implementation ppf sourcefile outputprefix = ++ Timings.(time (Typing sourcefile)) (Typemod.type_implementation sourcefile outputprefix modulename env) ++ print_if ppf Clflags.dump_typedtree - Printtyped.implementation_with_coercion + Printtyped.implementation_with_coercion in if not !Clflags.print_types then begin - (typedtree, coercion) - ++ Timings.(time (Transl sourcefile)) - (Translmod.transl_store_implementation modulename) - +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda - ++ Timings.(time (Generate sourcefile)) - (fun (size, lambda) -> - (size, Simplif.simplify_lambda lambda) - +++ print_if ppf Clflags.dump_lambda Printlambda.lambda - ++ Asmgen.compile_implementation ~source_provenance outputprefix ppf; - Compilenv.save_unit_info cmxfile) + if Config.flambda then begin + if !Clflags.o3 then begin + Clflags.simplify_rounds := 3; + Clflags.use_inlining_arguments_set ~round:0 Clflags.o1_arguments; + Clflags.use_inlining_arguments_set ~round:1 Clflags.o2_arguments; + Clflags.use_inlining_arguments_set ~round:2 Clflags.o3_arguments + end + else if !Clflags.o2 then begin + Clflags.simplify_rounds := 2; + Clflags.use_inlining_arguments_set ~round:0 Clflags.o1_arguments; + Clflags.use_inlining_arguments_set ~round:1 Clflags.o2_arguments + end + else if !Clflags.classic_inlining then begin + Clflags.use_inlining_arguments_set Clflags.classic_arguments + end; + (typedtree, coercion) + ++ Timings.(time (Timings.Transl sourcefile) + (Translmod.transl_implementation_flambda modulename)) + +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda + ++ Timings.time (Timings.Generate sourcefile) (fun lambda -> + lambda + +++ Simplif.simplify_lambda + +++ print_if ppf Clflags.dump_lambda Printlambda.lambda + ++ (fun ((module_ident, size), lam) -> + Middle_end.middle_end ppf ~source_provenance + ~prefixname:outputprefix + ~size + ~module_ident + ~backend + ~module_initializer:lam) + ++ Asmgen.compile_implementation_flambda ~source_provenance + outputprefix ~backend ppf; + Compilenv.save_unit_info cmxfile) + end + else begin + Clflags.use_inlining_arguments_set Clflags.classic_arguments; + (typedtree, coercion) + ++ Timings.(time (Transl sourcefile)) + (Translmod.transl_store_implementation modulename) + ++ print_if ppf Clflags.dump_rawlambda Printlambda.program + ++ Timings.(time (Generate sourcefile)) + (fun { Lambda.code; main_module_block_size } -> + { Lambda.code = Simplif.simplify_lambda code; + main_module_block_size } + ++ print_if ppf Clflags.dump_lambda Printlambda.program + ++ Asmgen.compile_implementation_clambda ~source_provenance + outputprefix ppf; + Compilenv.save_unit_info cmxfile) + end end; Warnings.check_fatal (); Stypes.dump (Some (outputprefix ^ ".annot")) diff --git a/driver/optcompile.mli b/driver/optcompile.mli index 00f9029a5..9f7891bdd 100644 --- a/driver/optcompile.mli +++ b/driver/optcompile.mli @@ -15,5 +15,12 @@ open Format val interface: formatter -> string -> string -> unit -val implementation: formatter -> string -> string -> unit + +val implementation + : formatter + -> string + -> string + -> backend:(module Backend_intf.S) + -> unit + val c_file: string -> unit diff --git a/driver/optmain.ml b/driver/optmain.ml index 6b6b95e81..2e48453b4 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -14,6 +14,24 @@ open Config open Clflags open Compenv +module Backend = struct + (* See backend_intf.mli. *) + + let symbol_for_global' = Compilenv.symbol_for_global' + let closure_symbol = Compilenv.closure_symbol + + let really_import_approx = Import_approx.really_import_approx + let import_symbol = Import_approx.import_symbol + + let size_int = Arch.size_int + let big_endian = Arch.big_endian + + (* CR mshinwell: this needs tying through to [Proc], although it may + necessitate the introduction of a new field in that module. *) + let max_sensible_number_of_arguments = 9 +end +let backend = (module Backend : Backend_intf.S) + let process_interface_file ppf name = let opref = output_prefix name in Optcompile.interface ppf name opref; @@ -21,7 +39,7 @@ let process_interface_file ppf name = let process_implementation_file ppf name = let opref = output_prefix name in - Optcompile.implementation ppf name opref; + Optcompile.implementation ppf name opref ~backend; objfiles := (opref ^ ".cmx") :: !objfiles let cmxa_present = ref false;; @@ -56,11 +74,11 @@ let ppf = Format.err_formatter (* Error messages to standard error formatter *) let anonymous filename = - readenv ppf Before_compile; process_file ppf filename;; + readenv ppf (Before_compile filename); process_file ppf filename;; let impl filename = - readenv ppf Before_compile; process_implementation_file ppf filename;; + readenv ppf (Before_compile filename); process_implementation_file ppf filename;; let intf filename = - readenv ppf Before_compile; process_interface_file ppf filename;; + readenv ppf (Before_compile filename); process_interface_file ppf filename;; let show_config () = Config.print_config stdout; @@ -79,6 +97,7 @@ module Options = Main_args.Make_optcomp_options (struct let _cc s = c_compiler := Some s let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs let _ccopt s = first_ccopts := s :: !first_ccopts + let _clambda_checks () = clambda_checks := true let _compact = clear optimize_for_speed let _config () = show_config () let _for_pack s = for_package := Some s @@ -86,32 +105,75 @@ module Options = Main_args.Make_optcomp_options (struct let _i () = print_types := true; compile_only := true let _I dir = include_dirs := dir :: !include_dirs let _impl = impl - let _inline n = inline_threshold := n * 8 + let _inline spec = + Float_arg_helper.parse spec ~update:inline_threshold + ~help_text:"Syntax: -inline | =[,...]" + let _inline_toplevel spec = + Int_arg_helper.parse spec ~update:inline_toplevel_threshold + ~help_text:"Syntax: -inline-toplevel | =[,...]" + let _inlining_stats () = inlining_stats := true + let _dump_pass pass = set_dumped_pass pass true + let _rounds n = simplify_rounds := n + let _unroll spec = + Int_arg_helper.parse spec ~update:unroll + ~help_text:"Syntax: -unroll | =[,...]" + let _classic_inlining () = classic_inlining := true + let _inline_call_cost spec = + Int_arg_helper.parse spec ~update:inline_call_cost + ~help_text:"Syntax: -inline-call-cost | =[,...]" + let _inline_alloc_cost spec = + Int_arg_helper.parse spec ~update:inline_alloc_cost + ~help_text:"Syntax: -inline-alloc-cost | =[,...]" + let _inline_prim_cost spec = + Int_arg_helper.parse spec ~update:inline_prim_cost + ~help_text:"Syntax: -inline-prim-cost | =[,...]" + let _inline_branch_cost spec = + Int_arg_helper.parse spec ~update:inline_branch_cost + ~help_text:"Syntax: -inline-branch-cost | =[,...]" + let _inline_indirect_cost spec = + Int_arg_helper.parse spec ~update:inline_indirect_cost + ~help_text:"Syntax: -inline-indirect-cost | =[,...]" + let _inline_lifting_benefit spec = + Int_arg_helper.parse spec ~update:inline_lifting_benefit + ~help_text:"Syntax: -inline-lifting-benefit | =[,...]" + let _branch_inline_factor spec = + Float_arg_helper.parse spec ~update:branch_inline_factor + ~help_text:"Syntax: -branch-inline-factor | =[,...]" let _intf = intf let _intf_suffix s = Config.interface_suffix := s let _keep_docs = set keep_docs let _keep_locs = set keep_locs let _labels = clear classic let _linkall = set link_everything + let _max_inlining_depth spec = + Int_arg_helper.parse spec ~update:max_inlining_depth + ~help_text:"Syntax: -max-inlining-depth | =[,...]" let _no_alias_deps = set transparent_modules let _no_app_funct = clear applicative_functors let _no_float_const_prop = clear float_const_prop let _noassert = set noassert let _noautolink = set no_auto_link let _nodynlink = clear dlcode + let _no_inline_recursive_functions = clear inline_recursive_functions let _nolabels = set classic let _nostdlib = set no_std_include let _o s = output_name := Some s + (* CR mshinwell: should stop e.g. -O2 -classic-inlining + lgesbert: could be done in main() below, like for -pack and -c, but that + would prevent overriding using OCAMLPARAM. *) + let _o2 = set o2 + let _o3 = set o3 let _open s = open_modules := s :: !open_modules let _output_obj = set output_c_object - let _output_complete_obj s = - set output_c_object s; set output_complete_object s + let _output_complete_obj () = + set output_c_object (); set output_complete_object () let _p = set gprofile let _pack = set make_package let _pp s = preprocessor := Some s let _ppx s = first_ppx := s :: !first_ppx let _principal = set principal let _rectypes = set recursive_types + let _remove_unused_arguments = set remove_unused_arguments let _runtime_variant s = runtime_variant := s let _safe_string = clear unsafe_string let _short_paths = clear real_paths @@ -120,6 +182,7 @@ module Options = Main_args.Make_optcomp_options (struct let _shared () = shared := true; dlcode := true let _S = set keep_asm_file let _thread = set use_threads + let _unbox_closures = set unbox_closures let _unsafe = set fast let _unsafe_string = set unsafe_string let _v () = print_version_and_library "native-code compiler" @@ -142,7 +205,14 @@ module Options = Main_args.Make_optcomp_options (struct let _dtypedtree = set dump_typedtree let _drawlambda = set dump_rawlambda let _dlambda = set dump_lambda + let _drawclambda = set dump_rawclambda let _dclambda = set dump_clambda + let _dflambda = set dump_flambda + let _dflambda_let stamp = dump_flambda_let := Some stamp + let _dflambda_verbose () = + set dump_flambda (); + set dump_flambda_verbose () + let _dflambda_invariants = set flambda_invariant_checks let _dcmm = set dump_cmm let _dsel = set dump_selection let _dcombine = set dump_combine @@ -188,7 +258,7 @@ let main () = Compmisc.init_path true; let target = extract_output !output_name in Asmpackager.package_files ppf (Compmisc.initial_env ()) - (get_objfiles ()) target; + (get_objfiles ()) target ~backend; Warnings.check_fatal (); end else if !shared then begin diff --git a/driver/pparse.ml b/driver/pparse.ml index d8f57ec3d..eea40abe9 100644 --- a/driver/pparse.ml +++ b/driver/pparse.ml @@ -145,7 +145,7 @@ let open_and_check_magic inputfile ast_magic = in (ic, is_ast_file) -let file ppf ~tool_name inputfile parse_fun ast_magic = +let file_aux ppf ~tool_name inputfile parse_fun invariant_fun ast_magic = let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in let ast = try @@ -166,7 +166,12 @@ let file ppf ~tool_name inputfile parse_fun ast_magic = with x -> close_in ic; raise x in close_in ic; - apply_rewriters ~restore:false ~tool_name ast_magic ast + let ast = apply_rewriters ~restore:false ~tool_name ast_magic ast in + if is_ast_file || !Clflags.all_ppx <> [] then invariant_fun ast; + ast + +let file ppf ~tool_name inputfile parse_fun ast_magic = + file_aux ppf ~tool_name inputfile parse_fun ignore ast_magic let report_error ppf = function | CannotRun cmd -> @@ -183,11 +188,11 @@ let () = | _ -> None ) -let parse_all ~tool_name parse_fun magic ppf sourcefile = +let parse_all ~tool_name parse_fun invariant_fun magic ppf sourcefile = Location.input_name := sourcefile; let inputfile = preprocess sourcefile in let ast = - try file ppf ~tool_name inputfile parse_fun magic + try file_aux ppf ~tool_name inputfile parse_fun invariant_fun magic with exn -> remove_preprocessed inputfile; raise exn @@ -198,8 +203,10 @@ let parse_all ~tool_name parse_fun magic ppf sourcefile = let parse_implementation ppf ~tool_name sourcefile = parse_all ~tool_name (Timings.(time (Parsing sourcefile)) Parse.implementation) + Ast_invariants.structure Config.ast_impl_magic_number ppf sourcefile let parse_interface ppf ~tool_name sourcefile = parse_all ~tool_name (Timings.(time (Parsing sourcefile)) Parse.interface) + Ast_invariants.signature Config.ast_intf_magic_number ppf sourcefile diff --git a/flexdll b/flexdll new file mode 160000 index 000000000..c041e8bee --- /dev/null +++ b/flexdll @@ -0,0 +1 @@ +Subproject commit c041e8beef98484a67df08b2ced27e096b6ea766 diff --git a/lex/Makefile.nt b/lex/Makefile.nt index 6bd856040..508af8c1b 100644 --- a/lex/Makefile.nt +++ b/lex/Makefile.nt @@ -17,7 +17,7 @@ CAMLRUN ?= ../boot/ocamlrun CAMLYACC ?= ../boot/ocamlyacc CAMLC=$(CAMLRUN) ../boot/ocamlc -I ../boot -CAMLOPT=$(CAMLRUN) ../ocamlopt -I ../stdlib +CAMLOPT=$(if $(wildcard ../flexdll/Makefile),OCAML_FLEXLINK="../boot/ocamlrun ../flexdll/flexlink.exe") $(CAMLRUN) ../ocamlopt -I ../stdlib COMPFLAGS=-warn-error A LINKFLAGS= YACCFLAGS=-v @@ -45,7 +45,7 @@ parser.ml parser.mli: parser.mly $(CAMLYACC) $(YACCFLAGS) parser.mly clean:: - rm -f parser.ml parser.mli + rm -f parser.ml parser.mli parser.output beforedepend:: parser.ml parser.mli diff --git a/man/ocamlc.m b/man/ocamlc.m index ce928d1b9..ae1eeaf53 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -855,6 +855,9 @@ mutually recursive types. 50 \ \ Unexpected documentation comment. +59 +\ \ Assignment on non-mutable value. + The letters stand for the following sets of warnings. Any letter not mentioned here corresponds to the empty set. diff --git a/manual/manual/cmds/comp.etex b/manual/manual/cmds/comp.etex index b35ba71f4..a7aabd295 100644 --- a/manual/manual/cmds/comp.etex +++ b/manual/manual/cmds/comp.etex @@ -519,6 +519,14 @@ Display a short usage summary and exit. % \end{options} +\noindent +On native Windows, the following environment variable is also consulted: + +\begin{options} +\item["OCAML_FLEXLINK"] Alternative executable to use instead of the +configured value. Primarily used for bootstrapping. +\end{options} + \section{Modules and the file system} This short section is intended to clarify the relationship between the diff --git a/manual/manual/cmds/intf-c.etex b/manual/manual/cmds/intf-c.etex index 58c1c5012..adce7534f 100644 --- a/manual/manual/cmds/intf-c.etex +++ b/manual/manual/cmds/intf-c.etex @@ -2232,6 +2232,14 @@ libraries are supported) and "lib"\var{outputc}".a". If not specified, defaults to the output name given with "-o". \end{options} +\noindent +On native Windows, the following environment variable is also consulted: + +\begin{options} +\item["OCAML_FLEXLINK"] Alternative executable to use instead of the +configured value. Primarily used for bootstrapping. +\end{options} + \paragraph{Example} Consider an OCaml interface to the standard "libz" C library for reading and writing compressed files. Assume this library resides in "/usr/local/zlib". This interface is diff --git a/manual/manual/cmds/native.etex b/manual/manual/cmds/native.etex index 2de553971..33b2399c6 100644 --- a/manual/manual/cmds/native.etex +++ b/manual/manual/cmds/native.etex @@ -505,6 +505,14 @@ Display a short usage summary and exit. % \end{options} +\noindent +On native Windows, the following environment variable is also consulted: + +\begin{options} +\item["OCAML_FLEXLINK"] Alternative executable to use instead of the +configured value. Primarily used for bootstrapping. +\end{options} + \paragraph{Options for the IA32 architecture} The IA32 code generator (Intel Pentium, AMD Athlon) supports the following additional option: diff --git a/middle_end/alias_analysis.ml b/middle_end/alias_analysis.ml index 2883583ce..e7231b62a 100644 --- a/middle_end/alias_analysis.ml +++ b/middle_end/alias_analysis.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + type allocation_point = | Symbol of Symbol.t | Variable of Variable.t diff --git a/middle_end/alias_analysis.mli b/middle_end/alias_analysis.mli index dd548d578..d45ea4ca3 100644 --- a/middle_end/alias_analysis.mli +++ b/middle_end/alias_analysis.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + type allocation_point = | Symbol of Symbol.t | Variable of Variable.t diff --git a/middle_end/allocated_const.ml b/middle_end/allocated_const.ml index 0bb2d4bac..a29ca2e86 100644 --- a/middle_end/allocated_const.ml +++ b/middle_end/allocated_const.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + type t = | Float of float | Int32 of int32 diff --git a/middle_end/allocated_const.mli b/middle_end/allocated_const.mli index ffd9bcc0c..4ab554211 100644 --- a/middle_end/allocated_const.mli +++ b/middle_end/allocated_const.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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, ...)]. *) diff --git a/middle_end/augment_closures.ml b/middle_end/augment_closures.ml index 8a62bd20b..d32707b95 100644 --- a/middle_end/augment_closures.ml +++ b/middle_end/augment_closures.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module A = Simple_value_approx module E = Inline_and_simplify_aux.Env diff --git a/middle_end/augment_closures.mli b/middle_end/augment_closures.mli index 609307529..c8bcac59a 100644 --- a/middle_end/augment_closures.mli +++ b/middle_end/augment_closures.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + val run : env:Inline_and_simplify_aux.Env.t -> set_of_closures:Flambda.set_of_closures -> diff --git a/middle_end/backend_intf.mli b/middle_end/backend_intf.mli index ac13225a5..45070159b 100644 --- a/middle_end/backend_intf.mli +++ b/middle_end/backend_intf.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** Knowledge that the middle end needs about the backend. *) module type S = sig diff --git a/middle_end/base_types/closure_element.ml b/middle_end/base_types/closure_element.ml index f444d87a7..069ba44f4 100644 --- a/middle_end/base_types/closure_element.ml +++ b/middle_end/base_types/closure_element.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + include Variable let wrap t = t diff --git a/middle_end/base_types/closure_element.mli b/middle_end/base_types/closure_element.mli index 5a9244bec..5aee016d1 100644 --- a/middle_end/base_types/closure_element.mli +++ b/middle_end/base_types/closure_element.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + include Identifiable.S val wrap : Variable.t -> t diff --git a/middle_end/base_types/closure_id.ml b/middle_end/base_types/closure_id.ml index 39e19e0ce..fe3027cd5 100644 --- a/middle_end/base_types/closure_id.ml +++ b/middle_end/base_types/closure_id.ml @@ -14,4 +14,6 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + include Closure_element diff --git a/middle_end/base_types/closure_id.mli b/middle_end/base_types/closure_id.mli index 02425be40..f2a42fae8 100644 --- a/middle_end/base_types/closure_id.mli +++ b/middle_end/base_types/closure_id.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** CR-someday lwhite: "Closure_id" is quite a generic name. I wonder wether something like "Closure_label" would better capture that it is the label of a projection. *) diff --git a/middle_end/base_types/compilation_unit.ml b/middle_end/base_types/compilation_unit.ml index a798c436e..6e846e322 100644 --- a/middle_end/base_types/compilation_unit.ml +++ b/middle_end/base_types/compilation_unit.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + type t = { id : Ident.t; linkage_name : Linkage_name.t; diff --git a/middle_end/base_types/compilation_unit.mli b/middle_end/base_types/compilation_unit.mli index 408da62e6..1af20c6dd 100644 --- a/middle_end/base_types/compilation_unit.mli +++ b/middle_end/base_types/compilation_unit.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + include Identifiable.S (* The [Ident.t] must be persistent. This function raises an exception diff --git a/middle_end/base_types/export_id.ml b/middle_end/base_types/export_id.ml index edcb731aa..7da010f0c 100644 --- a/middle_end/base_types/export_id.ml +++ b/middle_end/base_types/export_id.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module Id : Id_types.Id = Id_types.Id (struct end) module Unit_id = Id_types.UnitId (Id) (Compilation_unit) diff --git a/middle_end/base_types/export_id.mli b/middle_end/base_types/export_id.mli index f4ed136ad..a71e43d5b 100644 --- a/middle_end/base_types/export_id.mli +++ b/middle_end/base_types/export_id.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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, diff --git a/middle_end/base_types/id_types.ml b/middle_end/base_types/id_types.ml index c2c5a2fae..a6c3cccb1 100644 --- a/middle_end/base_types/id_types.ml +++ b/middle_end/base_types/id_types.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module type BaseId = sig type t val equal : t -> t -> bool diff --git a/middle_end/base_types/id_types.mli b/middle_end/base_types/id_types.mli index 0a6dee184..dbfeadb91 100644 --- a/middle_end/base_types/id_types.mli +++ b/middle_end/base_types/id_types.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (* CR-soon mshinwell: This module should be removed. *) diff --git a/middle_end/base_types/linkage_name.ml b/middle_end/base_types/linkage_name.ml index 1690d51d6..7e7dfce75 100644 --- a/middle_end/base_types/linkage_name.ml +++ b/middle_end/base_types/linkage_name.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + type t = string include Identifiable.Make (struct diff --git a/middle_end/base_types/linkage_name.mli b/middle_end/base_types/linkage_name.mli index c0a29cdea..b54af46a3 100644 --- a/middle_end/base_types/linkage_name.mli +++ b/middle_end/base_types/linkage_name.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + include Identifiable.S val create : string -> t diff --git a/middle_end/base_types/mutable_variable.ml b/middle_end/base_types/mutable_variable.ml index b8090a9eb..d42d9ce0a 100644 --- a/middle_end/base_types/mutable_variable.ml +++ b/middle_end/base_types/mutable_variable.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + type t = { compilation_unit : Compilation_unit.t; ident : Ident.t; diff --git a/middle_end/base_types/mutable_variable.mli b/middle_end/base_types/mutable_variable.mli index 158875b30..aa3bec17b 100644 --- a/middle_end/base_types/mutable_variable.mli +++ b/middle_end/base_types/mutable_variable.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + include Identifiable.S val create : ?current_compilation_unit:Compilation_unit.t -> string -> t diff --git a/middle_end/base_types/set_of_closures_id.ml b/middle_end/base_types/set_of_closures_id.ml index 99d56051f..a579e5a6b 100644 --- a/middle_end/base_types/set_of_closures_id.ml +++ b/middle_end/base_types/set_of_closures_id.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module Id : Id_types.Id = Id_types.Id (struct end) module Unit_id = Id_types.UnitId (Id) (Compilation_unit) diff --git a/middle_end/base_types/set_of_closures_id.mli b/middle_end/base_types/set_of_closures_id.mli index a1e01fa6a..fa14e1ee9 100644 --- a/middle_end/base_types/set_of_closures_id.mli +++ b/middle_end/base_types/set_of_closures_id.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** An identifier, unique across the whole program, that identifies a set of a closures (viz. [Set_of_closures]). *) diff --git a/middle_end/base_types/static_exception.ml b/middle_end/base_types/static_exception.ml index 1520e472d..4a93526a0 100644 --- a/middle_end/base_types/static_exception.ml +++ b/middle_end/base_types/static_exception.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + include Numbers.Int let create () = Lambda.next_raise_count () diff --git a/middle_end/base_types/static_exception.mli b/middle_end/base_types/static_exception.mli index 00078d543..9cf5c905d 100644 --- a/middle_end/base_types/static_exception.mli +++ b/middle_end/base_types/static_exception.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** An identifier that is used to label static exceptions. Its uniqueness properties are unspecified. *) diff --git a/middle_end/base_types/symbol.ml b/middle_end/base_types/symbol.ml index 4f41c3dda..0f91dc4ef 100644 --- a/middle_end/base_types/symbol.ml +++ b/middle_end/base_types/symbol.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + type t = { compilation_unit : Compilation_unit.t; label : Linkage_name.t; diff --git a/middle_end/base_types/symbol.mli b/middle_end/base_types/symbol.mli index 65bc4da01..20d970596 100644 --- a/middle_end/base_types/symbol.mli +++ b/middle_end/base_types/symbol.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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. diff --git a/middle_end/base_types/tag.ml b/middle_end/base_types/tag.ml index 938eed265..a168aff1f 100644 --- a/middle_end/base_types/tag.ml +++ b/middle_end/base_types/tag.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + type t = int include Identifiable.Make (Numbers.Int) diff --git a/middle_end/base_types/tag.mli b/middle_end/base_types/tag.mli index 25ec434db..26d96d92e 100644 --- a/middle_end/base_types/tag.mli +++ b/middle_end/base_types/tag.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** Tags on runtime boxed values. *) include Identifiable.S diff --git a/middle_end/base_types/var_within_closure.ml b/middle_end/base_types/var_within_closure.ml index 39e19e0ce..fe3027cd5 100644 --- a/middle_end/base_types/var_within_closure.ml +++ b/middle_end/base_types/var_within_closure.ml @@ -14,4 +14,6 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + include Closure_element diff --git a/middle_end/base_types/var_within_closure.mli b/middle_end/base_types/var_within_closure.mli index 48ecc5dbe..72a906ca9 100644 --- a/middle_end/base_types/var_within_closure.mli +++ b/middle_end/base_types/var_within_closure.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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 diff --git a/middle_end/base_types/variable.ml b/middle_end/base_types/variable.ml index cae8207cf..cdd8ee067 100644 --- a/middle_end/base_types/variable.ml +++ b/middle_end/base_types/variable.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + type t = { compilation_unit : Compilation_unit.t; name : string; diff --git a/middle_end/base_types/variable.mli b/middle_end/base_types/variable.mli index 363cb6c52..a99486562 100644 --- a/middle_end/base_types/variable.mli +++ b/middle_end/base_types/variable.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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, diff --git a/middle_end/closure_conversion.ml b/middle_end/closure_conversion.ml index bae35aed8..b39c6d746 100644 --- a/middle_end/closure_conversion.ml +++ b/middle_end/closure_conversion.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module Env = Closure_conversion_aux.Env module Function_decls = Closure_conversion_aux.Function_decls module Function_decl = Function_decls.Function_decl @@ -149,7 +151,8 @@ let rec close_const t env (const : Lambda.structured_constant) | Const_pointer c -> Const (Const_pointer c), "pointer" | Const_immstring c -> Allocated_const (Immutable_string c), "immstring" | Const_float_array c -> - Allocated_const (Float_array (List.map float_of_string c)), "float_array" + Allocated_const (Immutable_float_array (List.map float_of_string c)), + "float_array" | Const_block _ -> Expr (close t env (eliminate_const_block const)), "const_block" diff --git a/middle_end/closure_conversion.mli b/middle_end/closure_conversion.mli index 59161fcf1..152012462 100644 --- a/middle_end/closure_conversion.mli +++ b/middle_end/closure_conversion.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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. diff --git a/middle_end/closure_conversion_aux.ml b/middle_end/closure_conversion_aux.ml index e524a5a0b..c1d559781 100644 --- a/middle_end/closure_conversion_aux.ml +++ b/middle_end/closure_conversion_aux.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module IdentSet = Lambda.IdentSet module Env = struct diff --git a/middle_end/closure_conversion_aux.mli b/middle_end/closure_conversion_aux.mli index 66ce463a1..3701a7eb3 100644 --- a/middle_end/closure_conversion_aux.mli +++ b/middle_end/closure_conversion_aux.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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 diff --git a/middle_end/effect_analysis.ml b/middle_end/effect_analysis.ml index f97715cad..e411207a8 100644 --- a/middle_end/effect_analysis.ml +++ b/middle_end/effect_analysis.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + let no_effects_prim (prim : Lambda.primitive) = match Semantics_of_primitives.for_primitive prim with | (No_effects | Only_generative_effects), (No_coeffects | Has_coeffects) -> diff --git a/middle_end/effect_analysis.mli b/middle_end/effect_analysis.mli index 2705571ec..55266455b 100644 --- a/middle_end/effect_analysis.mli +++ b/middle_end/effect_analysis.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** Simple side effect analysis. *) (* CR-someday pchambart: Replace by call to [Purity] module. diff --git a/middle_end/find_recursive_functions.ml b/middle_end/find_recursive_functions.ml index ed23c3b42..919c939af 100644 --- a/middle_end/find_recursive_functions.ml +++ b/middle_end/find_recursive_functions.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + let in_function_declarations (function_decls : Flambda.function_declarations) ~backend = let module VCC = Strongly_connected_components.Make (Variable) in diff --git a/middle_end/find_recursive_functions.mli b/middle_end/find_recursive_functions.mli index 12d055967..f6130cd14 100644 --- a/middle_end/find_recursive_functions.mli +++ b/middle_end/find_recursive_functions.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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]. diff --git a/middle_end/flambda.ml b/middle_end/flambda.ml index e5b095ea0..83349041b 100644 --- a/middle_end/flambda.ml +++ b/middle_end/flambda.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + type call_kind = | Indirect | Direct of Closure_id.t @@ -514,9 +516,7 @@ let rec variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument free_variables (variables_usage_named ?ignore_uses_in_project_var ?ignore_uses_as_callee ?ignore_uses_as_argument ~all_used_variables defining_expr); - free_variables - (variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument - ?ignore_uses_in_project_var ~all_used_variables body) + aux body end else begin free_variables free_vars_of_defining_expr; diff --git a/middle_end/flambda.mli b/middle_end/flambda.mli index 624856cd9..7a8859459 100644 --- a/middle_end/flambda.mli +++ b/middle_end/flambda.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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. *) @@ -398,8 +400,7 @@ val free_variables_named -> named -> Variable.Set.t -(** Compute _all_ variables occuring inside an expression. (This is O(1) - for [Let]s). *) +(** Compute _all_ variables occuring inside an expression. *) val used_variables : ?ignore_uses_as_callee:unit -> ?ignore_uses_as_argument:unit diff --git a/middle_end/flambda_invariants.ml b/middle_end/flambda_invariants.ml index 657159aa6..b7ebf3fe3 100644 --- a/middle_end/flambda_invariants.ml +++ b/middle_end/flambda_invariants.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-30-40-41-42"] + type flambda_kind = | Normal | Lifted diff --git a/middle_end/flambda_invariants.mli b/middle_end/flambda_invariants.mli index 327093609..093c599cc 100644 --- a/middle_end/flambda_invariants.mli +++ b/middle_end/flambda_invariants.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + type flambda_kind = | Normal | Lifted diff --git a/middle_end/flambda_iterators.ml b/middle_end/flambda_iterators.ml index ea38fadd7..2f5456e7a 100644 --- a/middle_end/flambda_iterators.ml +++ b/middle_end/flambda_iterators.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + let apply_on_subexpressions f f_named (flam : Flambda.t) = match flam with | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable diff --git a/middle_end/flambda_iterators.mli b/middle_end/flambda_iterators.mli index 3ea854191..c77fbfca0 100644 --- a/middle_end/flambda_iterators.mli +++ b/middle_end/flambda_iterators.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (* CR-soon mshinwell: we need to document whether these iterators follow any particular order. *) diff --git a/middle_end/flambda_utils.ml b/middle_end/flambda_utils.ml index c583c623d..ab97ed1a2 100644 --- a/middle_end/flambda_utils.ml +++ b/middle_end/flambda_utils.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + let find_declaration cf ({ funs } : Flambda.function_declarations) = Variable.Map.find (Closure_id.unwrap cf) funs diff --git a/middle_end/flambda_utils.mli b/middle_end/flambda_utils.mli index 2ae870306..8210a9e0e 100644 --- a/middle_end/flambda_utils.mli +++ b/middle_end/flambda_utils.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** Utility functions for the Flambda intermediate language. *) (** Access functions *) diff --git a/middle_end/freshening.ml b/middle_end/freshening.ml index 29d7b922d..cc2e4bcc6 100644 --- a/middle_end/freshening.ml +++ b/middle_end/freshening.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + type tbl = { sb_var : Variable.t Variable.Map.t; sb_mutable_var : Mutable_variable.t Mutable_variable.Map.t; diff --git a/middle_end/freshening.mli b/middle_end/freshening.mli index ba4f3b16f..45bfcb203 100644 --- a/middle_end/freshening.mli +++ b/middle_end/freshening.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** Freshening of various identifiers. *) (** A table used for freshening variables and static exception identifiers. *) diff --git a/middle_end/inconstant_idents.ml b/middle_end/inconstant_idents.ml index c57d432f9..822e19602 100644 --- a/middle_end/inconstant_idents.ml +++ b/middle_end/inconstant_idents.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (* This cannot be done in a single simple pass due to expressions like: let rec ... = @@ -349,9 +351,8 @@ module Inconstants (P:Param) (Backend:Backend_intf.S) = struct if toplevel then mark_var arg curr else mark_curr curr | Prim (Pduparray _, _, _) -> - Misc.fatal_errorf - "Unsupported case of Pduparray in Inconstant_idents: %a" - Flambda.print_named named + (* 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 diff --git a/middle_end/inconstant_idents.mli b/middle_end/inconstant_idents.mli index 3e961e20e..08128c9c3 100644 --- a/middle_end/inconstant_idents.mli +++ b/middle_end/inconstant_idents.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + type result (** [inconstants_on_program] finds those variables and set-of-closures identifiers that diff --git a/middle_end/initialize_symbol_to_let_symbol.ml b/middle_end/initialize_symbol_to_let_symbol.ml index 869576f23..7f32493dd 100644 --- a/middle_end/initialize_symbol_to_let_symbol.ml +++ b/middle_end/initialize_symbol_to_let_symbol.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + let constant_field (expr:Flambda.t) : Flambda.constant_defining_value_block_field option = match expr with diff --git a/middle_end/initialize_symbol_to_let_symbol.mli b/middle_end/initialize_symbol_to_let_symbol.mli index b24c3f3fa..4535c3a08 100644 --- a/middle_end/initialize_symbol_to_let_symbol.mli +++ b/middle_end/initialize_symbol_to_let_symbol.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** 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 index 11c3f0cf2..0e6e0f1c2 100644 --- a/middle_end/inline_and_simplify.ml +++ b/middle_end/inline_and_simplify.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module A = Simple_value_approx module B = Inlining_cost.Benefit module E = Inline_and_simplify_aux.Env @@ -940,7 +942,7 @@ and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t = _block::_, block_approx::_ -> if A.is_definitely_immutable block_approx then begin Location.prerr_warning (Debuginfo.to_location dbg) - Warnings.Assignment_on_non_mutable_value + Warnings.Assignment_to_non_mutable_value end; tree, ret r (A.value_unknown Other) | (Psetfield _ | Parraysetu _ | Parraysets _), _, _ -> diff --git a/middle_end/inline_and_simplify.mli b/middle_end/inline_and_simplify.mli index d56015bd8..9e827a83f 100644 --- a/middle_end/inline_and_simplify.mli +++ b/middle_end/inline_and_simplify.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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. diff --git a/middle_end/inline_and_simplify_aux.ml b/middle_end/inline_and_simplify_aux.ml index 037eb0365..b4d94e1e0 100644 --- a/middle_end/inline_and_simplify_aux.ml +++ b/middle_end/inline_and_simplify_aux.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module Env = struct type scope = Current | Outer diff --git a/middle_end/inline_and_simplify_aux.mli b/middle_end/inline_and_simplify_aux.mli index 6567682c8..7ec54acc4 100644 --- a/middle_end/inline_and_simplify_aux.mli +++ b/middle_end/inline_and_simplify_aux.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** Environments and result structures used during inlining and simplification. (See inline_and_simplify.ml.) *) diff --git a/middle_end/inlining_cost.ml b/middle_end/inlining_cost.ml index cbd6ca65c..afea7a000 100644 --- a/middle_end/inlining_cost.ml +++ b/middle_end/inlining_cost.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (* Simple approximation of the space cost of a primitive. *) let prim_size (prim : Lambda.primitive) args = diff --git a/middle_end/inlining_cost.mli b/middle_end/inlining_cost.mli index 5af569aa2..99550f6ce 100644 --- a/middle_end/inlining_cost.mli +++ b/middle_end/inlining_cost.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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. *) diff --git a/middle_end/inlining_decision.ml b/middle_end/inlining_decision.ml index 4dc9c5f5e..2e2e2728a 100644 --- a/middle_end/inlining_decision.ml +++ b/middle_end/inlining_decision.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module A = Simple_value_approx module E = Inline_and_simplify_aux.Env module R = Inline_and_simplify_aux.Result diff --git a/middle_end/inlining_decision.mli b/middle_end/inlining_decision.mli index 9fae5921c..5d161d698 100644 --- a/middle_end/inlining_decision.mli +++ b/middle_end/inlining_decision.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (* CR mshinwell: Add the new inlining heuristic documentation here. *) (** Try to inline a full application of a known function, guided by various diff --git a/middle_end/inlining_decision_intf.mli b/middle_end/inlining_decision_intf.mli index d85481031..1aa801ca6 100644 --- a/middle_end/inlining_decision_intf.mli +++ b/middle_end/inlining_decision_intf.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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 = diff --git a/middle_end/inlining_stats.ml b/middle_end/inlining_stats.ml index e7dfa3960..b5d8888b7 100644 --- a/middle_end/inlining_stats.ml +++ b/middle_end/inlining_stats.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + let _vim_trailer = "vim:fdm=expr:filetype=plain:\ foldexpr=getline(v\\:lnum)=~'^\\\\s*$'&&getline(v\\:lnum+1)=~'\\\\S'?'<1'\\:1" diff --git a/middle_end/inlining_stats.mli b/middle_end/inlining_stats.mli index d8201a66b..9bdf1a8d2 100644 --- a/middle_end/inlining_stats.mli +++ b/middle_end/inlining_stats.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module Closure_stack : sig type t diff --git a/middle_end/inlining_stats_types.ml b/middle_end/inlining_stats_types.ml index df2c30d5a..b12d05700 100644 --- a/middle_end/inlining_stats_types.ml +++ b/middle_end/inlining_stats_types.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module Wsb = Inlining_cost.Whether_sufficient_benefit let print_stars ppf n = diff --git a/middle_end/inlining_stats_types.mli b/middle_end/inlining_stats_types.mli index 3ea9b09e9..c19b2eec5 100644 --- a/middle_end/inlining_stats_types.mli +++ b/middle_end/inlining_stats_types.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (* Types used for producing statistics about inlining. *) module Inlined : sig diff --git a/middle_end/inlining_transforms.ml b/middle_end/inlining_transforms.ml index 35fa90303..3502b3009 100644 --- a/middle_end/inlining_transforms.ml +++ b/middle_end/inlining_transforms.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module A = Simple_value_approx module B = Inlining_cost.Benefit module E = Inline_and_simplify_aux.Env diff --git a/middle_end/inlining_transforms.mli b/middle_end/inlining_transforms.mli index 9d5d3cf92..010ec26a7 100644 --- a/middle_end/inlining_transforms.mli +++ b/middle_end/inlining_transforms.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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 diff --git a/middle_end/invariant_params.ml b/middle_end/invariant_params.ml index 64611cdad..07b950190 100644 --- a/middle_end/invariant_params.ml +++ b/middle_end/invariant_params.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (* 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. diff --git a/middle_end/invariant_params.mli b/middle_end/invariant_params.mli index 136ef3dc4..37cee2f3e 100644 --- a/middle_end/invariant_params.mli +++ b/middle_end/invariant_params.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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 diff --git a/middle_end/lift_code.ml b/middle_end/lift_code.ml index 1adf4e858..dc826ffc3 100644 --- a/middle_end/lift_code.ml +++ b/middle_end/lift_code.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module A = Simple_value_approx module C = Inlining_cost diff --git a/middle_end/lift_code.mli b/middle_end/lift_code.mli index fdf2331de..bc4681935 100644 --- a/middle_end/lift_code.mli +++ b/middle_end/lift_code.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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 diff --git a/middle_end/lift_constants.ml b/middle_end/lift_constants.ml index 4ec33c07e..c3beb9d9b 100644 --- a/middle_end/lift_constants.ml +++ b/middle_end/lift_constants.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + let rec tail_variable : Flambda.t -> Variable.t option = function | Var v -> Some v | Let_rec (_, e) @@ -272,7 +274,7 @@ let find_original_set_of_closure in loop var -let rec translate_definition_and_resolve_alias +let translate_definition_and_resolve_alias inconstants (aliases:Alias_analysis.allocation_point Variable.Map.t) (var_to_symbol_tbl:Symbol.t Variable.Tbl.t) @@ -282,6 +284,41 @@ let rec translate_definition_and_resolve_alias (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 floats = + List.map (fun var -> + let var = + match Variable.Map.find var aliases with + | exception Not_found -> var + | Symbol _ -> + Misc.fatal_errorf + "Lift_constants.translate_definition_and_resolve_alias: \ + Array Pfloatarray %a with Symbol argument: %a" + Variable.print var + Alias_analysis.print_constant_defining_value definition + | Variable var -> var + in + 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) + 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)) @@ -347,10 +384,13 @@ let rec translate_definition_and_resolve_alias 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 mapping to \ - wrong value %a" + 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 @@ -385,11 +425,10 @@ let rec translate_definition_and_resolve_alias | Mutable -> Float_array floats in Some (Flambda.Allocated_const const) - | (Allocated_const (Array (Pfloatarray, _, _))) as definition -> - translate_definition_and_resolve_alias inconstants aliases - var_to_symbol_tbl var_to_definition_tbl symbol_definition_map - project_closure_map definition - ~backend + | 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: \ @@ -402,34 +441,7 @@ let rec 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)) -> - let floats = - List.map (fun var -> - let var = - match Variable.Map.find var aliases with - | exception Not_found -> var - | Symbol _ -> - Misc.fatal_errorf - "Lift_constants.translate_definition_and_resolve_alias: \ - Array Pfloatarray %a with Symbol argument: %a" - Variable.print var - Alias_analysis.print_constant_defining_value definition - | Variable var -> var - in - 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) - 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) + 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" diff --git a/middle_end/lift_constants.mli b/middle_end/lift_constants.mli index 04fe7fa05..ebb8bf580 100644 --- a/middle_end/lift_constants.mli +++ b/middle_end/lift_constants.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (* CR mshinwell: check comment is up to date *) (** 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 diff --git a/middle_end/lift_let_to_initialize_symbol.ml b/middle_end/lift_let_to_initialize_symbol.ml index 6dd54ad1a..d77dff09f 100644 --- a/middle_end/lift_let_to_initialize_symbol.ml +++ b/middle_end/lift_let_to_initialize_symbol.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + type ('a, 'b) kind = | Initialisation of (Symbol.t * Tag.t * Flambda.t list) | Effect of 'b diff --git a/middle_end/lift_let_to_initialize_symbol.mli b/middle_end/lift_let_to_initialize_symbol.mli index e1627e82d..451669134 100644 --- a/middle_end/lift_let_to_initialize_symbol.mli +++ b/middle_end/lift_let_to_initialize_symbol.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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 diff --git a/middle_end/middle_end.ml b/middle_end/middle_end.ml index 85751f5a8..d264246a3 100644 --- a/middle_end/middle_end.ml +++ b/middle_end/middle_end.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + let _dump_function_sizes flam ~backend = let module Backend = (val backend : Backend_intf.S) in let than = max_int in diff --git a/middle_end/middle_end.mli b/middle_end/middle_end.mli index 12db62d19..74444bf89 100644 --- a/middle_end/middle_end.mli +++ b/middle_end/middle_end.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (* Translate Lambda code to Flambda code and then optimize it. *) val middle_end diff --git a/middle_end/ref_to_variables.ml b/middle_end/ref_to_variables.ml index 7a7123171..9d9557a81 100644 --- a/middle_end/ref_to_variables.ml +++ b/middle_end/ref_to_variables.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + let rename_var var = Mutable_variable.create (Variable.unique_name var) diff --git a/middle_end/ref_to_variables.mli b/middle_end/ref_to_variables.mli index 9cce0833f..107e4ae5e 100644 --- a/middle_end/ref_to_variables.mli +++ b/middle_end/ref_to_variables.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** Transform [let]-bound references into variables. *) val eliminate_ref diff --git a/middle_end/remove_unused_arguments.ml b/middle_end/remove_unused_arguments.ml index 290b00a70..b32b5f61b 100644 --- a/middle_end/remove_unused_arguments.ml +++ b/middle_end/remove_unused_arguments.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + let pass_name = "remove-unused-arguments" let () = Clflags.all_passes := pass_name :: !Clflags.all_passes diff --git a/middle_end/remove_unused_arguments.mli b/middle_end/remove_unused_arguments.mli index 80573d7d8..c35da0f78 100644 --- a/middle_end/remove_unused_arguments.mli +++ b/middle_end/remove_unused_arguments.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** Introduce a stub function to avoid depending on unused arguments. For instance, it turns diff --git a/middle_end/remove_unused_closure_vars.ml b/middle_end/remove_unused_closure_vars.ml index e02cee1bb..26cad48d3 100644 --- a/middle_end/remove_unused_closure_vars.ml +++ b/middle_end/remove_unused_closure_vars.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** 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 program = diff --git a/middle_end/remove_unused_closure_vars.mli b/middle_end/remove_unused_closure_vars.mli index 35b5984dc..bf361cee4 100644 --- a/middle_end/remove_unused_closure_vars.mli +++ b/middle_end/remove_unused_closure_vars.mli @@ -14,5 +14,7 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** Eliminate variables bound by closures that are not required. *) val remove_unused_closure_variables : Flambda.program -> Flambda.program diff --git a/middle_end/remove_unused_program_constructs.ml b/middle_end/remove_unused_program_constructs.ml index ae7378a2c..93f982d8d 100644 --- a/middle_end/remove_unused_program_constructs.ml +++ b/middle_end/remove_unused_program_constructs.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + let dependency (expr:Flambda.t) = Flambda.free_symbols expr (* CR-soon pchambart: copied from lift_constant. Needs remerging *) diff --git a/middle_end/remove_unused_program_constructs.mli b/middle_end/remove_unused_program_constructs.mli index a639a0415..e736e5cd8 100644 --- a/middle_end/remove_unused_program_constructs.mli +++ b/middle_end/remove_unused_program_constructs.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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. diff --git a/middle_end/semantics_of_primitives.ml b/middle_end/semantics_of_primitives.ml index f68c56725..6bd3d1607 100644 --- a/middle_end/semantics_of_primitives.ml +++ b/middle_end/semantics_of_primitives.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + type effects = No_effects | Only_generative_effects | Arbitrary_effects type coeffects = No_coeffects | Has_coeffects @@ -24,7 +26,8 @@ let for_primitive (prim : Lambda.primitive) = | Pmakearray (_, Mutable) -> Only_generative_effects, No_coeffects | Pmakearray (_, Immutable) -> No_effects, No_coeffects | Pduparray (_, Immutable) -> - No_effects, Has_coeffects (* Might read a mutable record field. *) + No_effects, No_coeffects (* Pduparray (_, Immutable) is allowed only on + immutable arrays. *) | Pduparray (_, Mutable) | Pduprecord _ -> Only_generative_effects, Has_coeffects | Pccall { prim_name = diff --git a/middle_end/semantics_of_primitives.mli b/middle_end/semantics_of_primitives.mli index c2df0f0a6..5b092ff47 100644 --- a/middle_end/semantics_of_primitives.mli +++ b/middle_end/semantics_of_primitives.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** Description of the semantics of primitives, to be used for optimization purposes. diff --git a/middle_end/share_constants.ml b/middle_end/share_constants.ml index 45f8bc794..245264c0a 100644 --- a/middle_end/share_constants.ml +++ b/middle_end/share_constants.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module Constant_defining_value = Flambda.Constant_defining_value let update_constant_for_sharing sharing_symbol_tbl const : Flambda.constant_defining_value = diff --git a/middle_end/share_constants.mli b/middle_end/share_constants.mli index 3881601e4..3dac5d374 100644 --- a/middle_end/share_constants.mli +++ b/middle_end/share_constants.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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. *) diff --git a/middle_end/simple_value_approx.ml b/middle_end/simple_value_approx.ml index 13f49df30..b21c35bd5 100644 --- a/middle_end/simple_value_approx.ml +++ b/middle_end/simple_value_approx.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module U = Flambda_utils type 'a boxed_int = diff --git a/middle_end/simple_value_approx.mli b/middle_end/simple_value_approx.mli index f6b436d11..987151525 100644 --- a/middle_end/simple_value_approx.mli +++ b/middle_end/simple_value_approx.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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. *) diff --git a/middle_end/simplify_boxed_integer_ops.ml b/middle_end/simplify_boxed_integer_ops.ml index cdd6afb09..87f2ca472 100644 --- a/middle_end/simplify_boxed_integer_ops.ml +++ b/middle_end/simplify_boxed_integer_ops.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module S = Simplify_common (* Simplification of operations on boxed integers (nativeint, Int32, Int64). *) diff --git a/middle_end/simplify_boxed_integer_ops.mli b/middle_end/simplify_boxed_integer_ops.mli index 0a22da44b..1980495ce 100644 --- a/middle_end/simplify_boxed_integer_ops.mli +++ b/middle_end/simplify_boxed_integer_ops.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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 diff --git a/middle_end/simplify_boxed_integer_ops_intf.mli b/middle_end/simplify_boxed_integer_ops_intf.mli index cd9d52e65..a9a742702 100644 --- a/middle_end/simplify_boxed_integer_ops_intf.mli +++ b/middle_end/simplify_boxed_integer_ops_intf.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module type S = sig type t diff --git a/middle_end/simplify_common.ml b/middle_end/simplify_common.ml index e87ebb1fd..1593c9ad9 100644 --- a/middle_end/simplify_common.ml +++ b/middle_end/simplify_common.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module A = Simple_value_approx module C = Inlining_cost diff --git a/middle_end/simplify_common.mli b/middle_end/simplify_common.mli index 6f882c387..b0a8e26f3 100644 --- a/middle_end/simplify_common.mli +++ b/middle_end/simplify_common.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@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] diff --git a/middle_end/simplify_primitives.ml b/middle_end/simplify_primitives.ml index 650f7a5e0..334cbb9c9 100644 --- a/middle_end/simplify_primitives.ml +++ b/middle_end/simplify_primitives.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module A = Simple_value_approx module C = Inlining_cost module I = Simplify_boxed_integer_ops diff --git a/middle_end/simplify_primitives.mli b/middle_end/simplify_primitives.mli index e297e34af..f24d20ff1 100644 --- a/middle_end/simplify_primitives.mli +++ b/middle_end/simplify_primitives.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + (** Simplifies an application of a primitive based on approximation information. *) val primitive diff --git a/middle_end/unbox_closures.ml b/middle_end/unbox_closures.ml index 87f6f5105..39c494d17 100644 --- a/middle_end/unbox_closures.ml +++ b/middle_end/unbox_closures.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + module A = Simple_value_approx module E = Inline_and_simplify_aux.Env diff --git a/middle_end/unbox_closures.mli b/middle_end/unbox_closures.mli index 0f39b563a..6277891c2 100644 --- a/middle_end/unbox_closures.mli +++ b/middle_end/unbox_closures.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + val introduce_specialised_args_for_free_vars : backend:(module Backend_intf.S) -> Flambda.set_of_closures diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt index 9c009596b..a16d53e48 100644 --- a/ocamldoc/Makefile.nt +++ b/ocamldoc/Makefile.nt @@ -18,7 +18,7 @@ CAMLYACC ?= ../boot/ocamlyacc ########################## ROOTDIR = .. OCAMLC = $(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib -OCAMLOPT = $(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib +OCAMLOPT = $(if $(wildcard $(ROOTDIR)/flexdll/Makefile),OCAML_FLEXLINK="$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/flexdll/flexlink.exe") $(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib OCAMLDEP = $(CAMLRUN) $(ROOTDIR)/tools/ocamldep OCAMLLEX = $(CAMLRUN) $(ROOTDIR)/boot/ocamllex OCAMLLIB = $(LIBDIR) diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 3fdf2716f..58e330069 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -438,7 +438,7 @@ let analyse_files ?(init=[]) files = print_string Odoc_messages.cross_referencing; print_newline () ); - let _ = Odoc_cross.associate modules_list in + Odoc_cross.associate modules_list; if !Odoc_global.verbose then ( diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml index 8ce41c20f..57102068a 100644 --- a/ocamldoc/odoc_args.ml +++ b/ocamldoc/odoc_args.ml @@ -229,6 +229,7 @@ module Options = Main_args.Make_ocamldoc_options(struct let _dtypedtree = set Clflags.dump_typedtree let _drawlambda = set Clflags.dump_rawlambda let _dlambda = set Clflags.dump_lambda + let _dflambda = set Clflags.dump_flambda let _dinstr = set Clflags.dump_instr let anonymous = anonymous end) @@ -399,10 +400,9 @@ let add_option o = let parse () = if modified_options () then append_last_doc "\n"; let options = !options @ !help_options in - let _ = Arg.parse (Arg.align ~limit:13 options) + Arg.parse (Arg.align ~limit:13 options) anonymous - (M.usage^M.options_are) - in + (M.usage^M.options_are); (* we sort the hidden modules by name, to be sure that for example, A.B is before A, so we will match against A.B before A in Odoc_name.hide_modules.*) diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index 436c7502e..284c3725e 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -867,19 +867,16 @@ module Analyser = tt_class_exp table in - let cl = - { - cl_name = complete_name ; - cl_info = comment_opt ; - cl_type = cltype ; - cl_virtual = virt ; - cl_type_parameters = type_parameters ; - cl_kind = kind ; - cl_parameters = parameters ; - cl_loc = { loc_impl = Some loc ; loc_inter = None } ; - } - in - cl + { + cl_name = complete_name ; + cl_info = comment_opt ; + cl_type = cltype ; + cl_virtual = virt ; + cl_type_parameters = type_parameters ; + cl_kind = kind ; + cl_parameters = parameters ; + cl_loc = { loc_impl = Some loc ; loc_inter = None } ; + } (** Get a name from a module expression, or "struct ... end" if the module expression is not an ident of a constraint on an ident. *) @@ -1043,18 +1040,15 @@ module Analyser = [] -> let s = get_string_of_file last_pos pos_limit in let (_, ele_coms) = My_ir.all_special !file_name s in - let ele_comments = - List.fold_left - (fun acc -> fun sc -> - match sc.Odoc_types.i_desc with - None -> - acc - | Some t -> - acc @ [Element_module_comment t]) - [] - ele_coms - in - ele_comments + List.fold_left + (fun acc -> fun sc -> + match sc.Odoc_types.i_desc with + None -> + acc + | Some t -> + acc @ [Element_module_comment t]) + [] + ele_coms | item :: q -> let (comment_opt, ele_comments) = get_comments_in_module last_pos item.Parsetree.pstr_loc.Location.loc_start.Lexing.pos_cnum diff --git a/ocamldoc/odoc_comments.ml b/ocamldoc/odoc_comments.ml index 236d860a3..b9fabbdf0 100644 --- a/ocamldoc/odoc_comments.ml +++ b/ocamldoc/odoc_comments.ml @@ -41,7 +41,7 @@ module Info_retriever = let retrieve_info fun_lex file (s : string) = try - let _ = Odoc_comments_global.init () in + Odoc_comments_global.init (); Odoc_lexer.comments_level := 0; let lexbuf = Lexing.from_string s in match Odoc_parser.main fun_lex lexbuf with @@ -49,15 +49,14 @@ module Info_retriever = (0, None) | Some (desc, remain_opt) -> let mem_nb_chars = !Odoc_comments_global.nb_chars in - let _ = - match remain_opt with + begin match remain_opt with None -> () | Some s -> (*DEBUG*)print_string ("remain: "^s); print_newline(); let lexbuf2 = Lexing.from_string s in Odoc_parser.info_part2 Odoc_lexer.elements lexbuf2 - in + end; (mem_nb_chars, Some { @@ -138,7 +137,7 @@ module Info_retriever = retrieve_info Odoc_lexer.main file s let retrieve_info_simple file (s : string) = - let _ = Odoc_comments_global.init () in + Odoc_comments_global.init (); Odoc_lexer.comments_level := 0; let lexbuf = Lexing.from_string s in match Odoc_parser.main Odoc_lexer.simple lexbuf with diff --git a/ocamldoc/odoc_dag2html.ml b/ocamldoc/odoc_dag2html.ml index 74119e6e8..9725d115a 100644 --- a/ocamldoc/odoc_dag2html.ml +++ b/ocamldoc/odoc_dag2html.ml @@ -938,14 +938,16 @@ let tablify phony no_optim no_group d = let t = {table = Array.append t.table [| Array.of_list new_row |]} in let t = if no_group && not (has_phony_children phony d t) then t - else - let _ = if no_optim then () else equilibrate t in - let _ = group_elem t in - let _ = group_ghost t in - let _ = group_children t in - let _ = group_span_by_common_children d t in + else begin + if no_optim then () else equilibrate t; + group_elem t; + group_ghost t; + group_children t; + group_span_by_common_children d t; let t = if no_optim then t else treat_gaps d t in - let _ = group_span_last_row t in t + group_span_last_row t; + t + end in loop t in @@ -1442,7 +1444,7 @@ let table_of_dag phony no_optim invert no_group d = let d = if invert then invert_dag d else d in let t = tablify phony no_optim no_group d in let t = if invert then invert_table t else t in - let _ = fall () t in + fall () t; let t = fall2_right t in let t = fall2_left t in let t = shorten_too_long t in diff --git a/ocamldoc/odoc_dep.ml b/ocamldoc/odoc_dep.ml index ab027d8d4..1e598128b 100644 --- a/ocamldoc/odoc_dep.ml +++ b/ocamldoc/odoc_dep.ml @@ -199,22 +199,19 @@ let kernel_deps_of_modules modules = *) let deps_of_types ?(kernel=false) types = let deps_pre = List.map (fun t -> (t, type_deps t)) types in - let deps = - if kernel then - ( - let graph = List.map - (fun (t, names) -> Dep.make_node t.Type.ty_name names) - deps_pre - in - let k = Dep.kernel graph in - List.map - (fun t -> + if kernel then + ( + let graph = List.map + (fun (t, names) -> Dep.make_node t.Type.ty_name names) + deps_pre + in + let k = Dep.kernel graph in + List.map + (fun t -> let node = Dep.get_node k t.Type.ty_name in (t, Dep.set_to_list node.Dep.near) - ) - types - ) - else - deps_pre - in - deps + ) + types + ) + else + deps_pre diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index 36ec40318..65f0f81ff 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -168,8 +168,7 @@ module Naming = (** Return the complete filename for the code of the given value. *) let file_code_value_complete_target v = - let f = code_prefix^mark_value^(subst_infix_symbols v.val_name)^".html" in - f + code_prefix^mark_value^(subst_infix_symbols v.val_name)^".html" (** Return the link target for the given attribute. *) let attribute_target a = target mark_attribute (Name.simple a.att_value.val_name) @@ -179,8 +178,7 @@ module Naming = (** Return the complete filename for the code of the given attribute. *) let file_code_attribute_complete_target a = - let f = code_prefix^mark_attribute^a.att_value.val_name^".html" in - f + code_prefix^mark_attribute^a.att_value.val_name^".html" (** Return the link target for the given method. *) let method_target m = target mark_method (Name.simple m.met_value.val_name) @@ -190,8 +188,7 @@ module Naming = (** Return the complete filename for the code of the given method. *) let file_code_method_complete_target m = - let f = code_prefix^mark_method^m.met_value.val_name^".html" in - f + code_prefix^mark_method^m.met_value.val_name^".html" (** Return the link target for the given label section. *) let label_target l = target "" l @@ -202,20 +199,17 @@ module Naming = (** Return the complete filename for the code of the type of the given module or module type name. *) let file_type_module_complete_target name = - let f = type_prefix^name^".html" in - f + type_prefix^name^".html" (** Return the complete filename for the code of the given module name. *) let file_code_module_complete_target name = - let f = code_prefix^name^".html" in - f + code_prefix^name^".html" (** Return the complete filename for the code of the type of the given class or class type name. *) let file_type_class_complete_target name = - let f = type_prefix^name^".html" in - f + type_prefix^name^".html" end module StringSet = Set.Make (struct @@ -259,8 +253,7 @@ class virtual text = method label_of_text t= let t2 = Odoc_info.first_sentence_of_text t in let s = Odoc_info.string_of_text t2 in - let s2 = self#keep_alpha_num s in - s2 + self#keep_alpha_num s (** Create a label for the associated title. Return the label specified by the user or a label created @@ -1176,12 +1169,10 @@ class html = else s_final in - let s2 = Str.global_substitute - (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)") - f - s - in - s2 + Str.global_substitute + (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)") + f + s (** Take a string and return the string where fully qualified module idents have been replaced by links to the module referenced by the ident.*) @@ -1200,12 +1191,10 @@ class html = else s_final in - let s2 = Str.global_substitute - (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\)\\(\\.[A-Z][a-zA-Z_'0-9]*\\)*") - f - s - in - s2 + Str.global_substitute + (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\)\\(\\.[A-Z][a-zA-Z_'0-9]*\\)*") + f + s (** Print html code to display a [Types.type_expr]. *) method html_of_type_expr b m_name t = diff --git a/ocamldoc/odoc_lexer.mll b/ocamldoc/odoc_lexer.mll index 5993cb8fc..bf5da3e23 100644 --- a/ocamldoc/odoc_lexer.mll +++ b/ocamldoc/odoc_lexer.mll @@ -87,8 +87,7 @@ let remove_blanks s = (** Remove first blank characters of each line of a string, until the first '*' *) let remove_stars s = - let s2 = Str.global_replace (Str.regexp ("^"^blank^"*\\*")) "" s in - s2 + Str.global_replace (Str.regexp ("^"^blank^"*\\*")) "" s } let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml index 3c85aa32a..d2ee3f750 100644 --- a/ocamldoc/odoc_man.ml +++ b/ocamldoc/odoc_man.ml @@ -355,12 +355,10 @@ class man = match_s (Name.get_relative m_name match_s) in - let s2 = Str.global_substitute - (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)") - f - s - in - s2 + Str.global_substitute + (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)") + f + s (** Print groff string to display a [Types.type_expr].*) method man_of_type_expr b m_name t = diff --git a/ocamldoc/odoc_ocamlhtml.mll b/ocamldoc/odoc_ocamlhtml.mll index 9b3ad2da1..04ca1c659 100644 --- a/ocamldoc/odoc_ocamlhtml.mll +++ b/ocamldoc/odoc_ocamlhtml.mll @@ -198,8 +198,7 @@ let string_buffer = Buffer.create 32 let reset_string_buffer () = Buffer.reset string_buffer let store_string_char = Buffer.add_char string_buffer let get_stored_string () = - let s = Buffer.contents string_buffer in - s + Buffer.contents string_buffer (** To translate escape sequences *) @@ -517,7 +516,7 @@ let html_of_code b ?(with_pre=true) code = try print ~esc: false start ; let lexbuf = Lexing.from_string code in - let _ = token lexbuf in + token lexbuf; print ~esc: false ending ; Format.pp_print_flush !fmt () ; Buffer.contents buf diff --git a/ocamldoc/odoc_search.ml b/ocamldoc/odoc_search.ml index 763b71602..9e40ae3cb 100644 --- a/ocamldoc/odoc_search.ml +++ b/ocamldoc/odoc_search.ml @@ -157,8 +157,7 @@ module Search = [] (Odoc_class.class_comments c) in - let l = res_att @ res_met @ res_sec in - l + res_att @ res_met @ res_sec else [] in @@ -189,8 +188,7 @@ module Search = [] (Odoc_class.class_type_comments ct) in - let l = res_att @ res_met @ res_sec in - l + res_att @ res_met @ res_sec else [] in @@ -252,10 +250,8 @@ module Search = [] (Odoc_module.module_type_comments mt) in - let l = res_val @ res_typ @ res_ext @ res_exc @ res_mod @ + res_val @ res_typ @ res_ext @ res_exc @ res_mod @ res_modtyp @ res_cl @ res_cltyp @ res_sec - in - l else [] in @@ -317,10 +313,8 @@ module Search = [] (Odoc_module.module_comments m) in - let l = res_val @ res_typ @ res_ext @ res_exc @ res_mod @ + res_val @ res_typ @ res_ext @ res_exc @ res_mod @ res_modtyp @ res_cl @ res_cltyp @ res_sec - in - l else [] in diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index e246f01ff..9d0f8b216 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -136,8 +136,7 @@ module Analyser = prepare_file must have been called to fill the file global variable.*) let get_string_of_file the_start the_end = try - let s = String.sub !file the_start (the_end-the_start) in - s + String.sub !file the_start (the_end-the_start) with Invalid_argument _ -> "" @@ -501,14 +500,11 @@ module Analyser = Parsetree.Pcty_constr (longident, _) -> (*of Longident.t * core_type list*) let name = Name.from_longident longident.txt in - let ic = - { - ic_name = Odoc_env.full_class_or_class_type_name env name ; - ic_class = None ; - ic_text = text_opt ; - } - in - ic + { + ic_name = Odoc_env.full_class_or_class_type_name env name ; + ic_class = None ; + ic_text = text_opt ; + } | Parsetree.Pcty_signature _ | Parsetree.Pcty_arrow _ -> @@ -1459,15 +1455,12 @@ module Analyser = (Parsetree.Pcty_constr (_, _) (*of Longident.t * core_type list *), Types.Cty_constr (p, typ_list, _) (*of Path.t * type_expr list * class_type*)) -> print_DEBUG "Cty_constr _"; - let k = - Class_type - { - cta_name = Odoc_env.full_class_or_class_type_name env (Name.from_path p) ; - cta_class = None ; - cta_type_parameters = List.map (Odoc_env.subst_type env) typ_list - } - in - k + Class_type + { + cta_name = Odoc_env.full_class_or_class_type_name env (Name.from_path p) ; + cta_class = None ; + cta_type_parameters = List.map (Odoc_env.subst_type env) typ_list + } | (Parsetree.Pcty_signature { Parsetree.pcsig_fields = class_type_field_list; diff --git a/ocamldoc/odoc_text_lexer.mll b/ocamldoc/odoc_text_lexer.mll index bc339e72c..b53a5a9de 100644 --- a/ocamldoc/odoc_text_lexer.mll +++ b/ocamldoc/odoc_text_lexer.mll @@ -190,12 +190,11 @@ rule main = parse if !verb_mode || !target_mode || !code_pre_mode || (!open_brackets >= 1) then Char (Lexing.lexeme lexbuf) - else - let _ = - if !ele_ref_mode then - ele_ref_mode := false - in + else begin + if !ele_ref_mode then + ele_ref_mode := false; END + end } | begin_title { diff --git a/ocamldoc/odoc_to_text.ml b/ocamldoc/odoc_to_text.ml index ce328b0da..93aff00c8 100644 --- a/ocamldoc/odoc_to_text.ml +++ b/ocamldoc/odoc_to_text.ml @@ -96,13 +96,10 @@ class virtual info = (** Return [text] value for the given "see also" reference. *) method text_of_see (see_ref, t) = - let t_ref = - match see_ref with - Odoc_info.See_url s -> [ Odoc_info.Link (s, t) ] - | Odoc_info.See_file s -> (Odoc_info.Code s) :: (Odoc_info.Raw " ") :: t - | Odoc_info.See_doc s -> (Odoc_info.Italic [Odoc_info.Raw s]) :: (Odoc_info.Raw " ") :: t - in - t_ref + match see_ref with + Odoc_info.See_url s -> [ Odoc_info.Link (s, t) ] + | Odoc_info.See_file s -> (Odoc_info.Code s) :: (Odoc_info.Raw " ") :: t + | Odoc_info.See_doc s -> (Odoc_info.Italic [Odoc_info.Raw s]) :: (Odoc_info.Raw " ") :: t (** Return [text] value for the given list of "see also" references.*) method text_of_sees l = @@ -192,12 +189,10 @@ class virtual to_text = let rel = Name.get_relative m_name match_s in Odoc_info.apply_if_equal Odoc_info.use_hidden_modules match_s rel in - let s2 = Str.global_substitute - (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)") - f - s - in - s2 + Str.global_substitute + (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)") + f + s (** Take a string and return the string where fully qualified idents have been replaced by idents relative to the given module name. @@ -208,12 +203,10 @@ class virtual to_text = let rel = Name.get_relative m_name match_s in Odoc_info.apply_if_equal Odoc_info.use_hidden_modules match_s rel in - let s2 = Str.global_substitute - (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([A-Z][a-zA-Z_'0-9]*\\)") - f - s - in - s2 + Str.global_substitute + (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([A-Z][a-zA-Z_'0-9]*\\)") + f + s (** Get a string for a [Types.class_type] where all idents are relative. *) method normal_class_type m_name t = @@ -248,14 +241,12 @@ class virtual to_text = (** @return [text] value to represent a [Types.type_expr].*) method text_of_type_expr module_name t = - let t = List.flatten - (List.map - (fun s -> [Code s ; Newline ]) - (Str.split (Str.regexp "\n") - (self#normal_type module_name t)) - ) - in - t + List.flatten + (List.map + (fun s -> [Code s ; Newline ]) + (Str.split (Str.regexp "\n") + (self#normal_type module_name t)) + ) (** Return [text] value for a given short [Types.type_expr].*) method text_of_short_type_expr module_name t = @@ -273,15 +264,13 @@ class virtual to_text = (** @return [text] value to represent parameters of a class (with arraows).*) method text_of_class_params module_name c = - let t = Odoc_info.text_concat - [Newline] - (List.map - (fun s -> [Code s]) - (Str.split (Str.regexp "\n") - (self#normal_class_params module_name c)) - ) - in - t + Odoc_info.text_concat + [Newline] + (List.map + (fun s -> [Code s]) + (Str.split (Str.regexp "\n") + (self#normal_class_params module_name c)) + ) (** @return [text] value to represent a [Types.module_type]. *) method text_of_module_type t = diff --git a/otherlibs/Makefile.nt b/otherlibs/Makefile.nt index 6d16f8d27..be4291bfe 100644 --- a/otherlibs/Makefile.nt +++ b/otherlibs/Makefile.nt @@ -15,6 +15,8 @@ include ../Makefile +export OCAML_FLEXLINK:=$(if $(wildcard $(ROOTDIR)/flexdll/Makefile),$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/flexdll/flexlink.exe) + # The Unix version now works fine under Windows # Note .. is the current directory (this makefile is included from diff --git a/otherlibs/bigarray/bigarray.ml b/otherlibs/bigarray/bigarray.ml index 960c97241..039e09c31 100644 --- a/otherlibs/bigarray/bigarray.ml +++ b/otherlibs/bigarray/bigarray.ml @@ -62,6 +62,21 @@ let complex32 = Complex32 let complex64 = Complex64 let char = Char +let kind_size_in_bytes : type a b. (a, b) kind -> int = function + | Float32 -> 4 + | Float64 -> 8 + | Int8_signed -> 1 + | Int8_unsigned -> 1 + | Int16_signed -> 2 + | Int16_unsigned -> 2 + | Int32 -> 4 + | Int64 -> 8 + | Int -> Sys.word_size / 8 + | Nativeint -> Sys.word_size / 8 + | Complex32 -> 8 + | Complex64 -> 16 + | Char -> 1 + type c_layout = C_layout_typ type fortran_layout = Fortran_layout_typ @@ -90,9 +105,13 @@ module Genarray = struct let d = Array.make n 0 in for i = 0 to n-1 do d.(i) <- nth_dim a i done; d + external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" + let size_in_bytes arr = + (kind_size_in_bytes (kind arr)) * (Array.fold_left ( * ) 1 (dims arr)) + external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "caml_ba_sub" external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> @@ -126,6 +145,10 @@ module Array1 = struct external dim: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1" external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" + + let size_in_bytes arr = + (kind_size_in_bytes (kind arr)) * (dim arr) + external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t = "caml_ba_sub" external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit" external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" @@ -156,6 +179,10 @@ module Array2 = struct external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2" external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" + + let size_in_bytes arr = + (kind_size_in_bytes (kind arr)) * (dim1 arr) * (dim2 arr) + external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "caml_ba_sub" external sub_right: @@ -203,6 +230,10 @@ module Array3 = struct external dim3: ('a, 'b, 'c) t -> int = "%caml_ba_dim_3" external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" + + let size_in_bytes arr = + (kind_size_in_bytes (kind arr)) * (dim1 arr) * (dim2 arr) * (dim3 arr) + external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "caml_ba_sub" external sub_right: diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli index a45c6799e..d45fb8050 100644 --- a/otherlibs/bigarray/bigarray.mli +++ b/otherlibs/bigarray/bigarray.mli @@ -168,6 +168,10 @@ val char : (char, int8_unsigned_elt) kind characters instead of arrays of small integers, by using the kind value [char] instead of [int8_unsigned]. *) +val kind_size_in_bytes : ('a, 'b) kind -> int +(** [kind_size_in_bytes k] is the number of bytes used to store + an element of type [k]. *) + (** {6 Array layouts} *) type c_layout = C_layout_typ (**) @@ -280,6 +284,10 @@ module Genarray : external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" (** Return the layout of the given big array. *) + val size_in_bytes : ('a, 'b, 'c) t -> int + (** [size_in_bytes a] is the number of elements in [a] multiplied + by [a]'s {!kind_size_in_bytes}.*) + external get: ('a, 'b, 'c) t -> int array -> 'a = "caml_ba_get_generic" (** Read an element of a generic big array. [Genarray.get a [|i1; ...; iN|]] returns the element of [a] @@ -490,6 +498,10 @@ module Array1 : sig external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" (** Return the layout of the given big array. *) + val size_in_bytes : ('a, 'b, 'c) t -> int + (** [size_in_bytes a] is the number of elements in [a] + multiplied by [a]'s {!kind_size_in_bytes}. *) + external get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_ref_1" (** [Array1.get a x], or alternatively [a.{x}], returns the element of [a] at index [x]. @@ -572,6 +584,10 @@ module Array2 : external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" (** Return the layout of the given big array. *) + val size_in_bytes : ('a, 'b, 'c) t -> int + (** [size_in_bytes a] is the number of elements in [a] + multiplied by [a]'s {!kind_size_in_bytes}. *) + external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_ref_2" (** [Array2.get a x y], also written [a.{x,y}], returns the element of [a] at coordinates ([x], [y]). @@ -678,6 +694,10 @@ module Array3 : external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" (** Return the layout of the given big array. *) + val size_in_bytes : ('a, 'b, 'c) t -> int + (** [size_in_bytes a] is the number of elements in [a] + multiplied by [a]'s {!kind_size_in_bytes}. *) + external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_ref_3" (** [Array3.get a x y z], also written [a.{x,y,z}], returns the element of [a] at coordinates ([x], [y], [z]). diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index eb5049716..26ad34cd1 100644 --- a/otherlibs/dynlink/Makefile +++ b/otherlibs/dynlink/Makefile @@ -30,14 +30,16 @@ COMPFLAGS=-w +33..39 -warn-error A -bin-annot -g -safe-string \ OBJS=dynlinkaux.cmo dynlink.cmo COMPILEROBJS=\ - ../../utils/misc.cmo ../../utils/config.cmo ../../utils/clflags.cmo \ + ../../utils/misc.cmo ../../utils/config.cmo \ ../../utils/identifiable.cmo ../../utils/numbers.cmo \ + ../../utils/arg_helper.cmo ../../utils/clflags.cmo \ ../../utils/tbl.cmo ../../utils/consistbl.cmo \ ../../utils/terminfo.cmo ../../utils/warnings.cmo \ ../../parsing/asttypes.cmi \ ../../parsing/location.cmo ../../parsing/longident.cmo \ ../../parsing/docstrings.cmo ../../parsing/ast_helper.cmo \ - ../../parsing/ast_mapper.cmo ../../parsing/attr_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 \ diff --git a/otherlibs/systhreads/Makefile.nt b/otherlibs/systhreads/Makefile.nt index 22fb1c717..bb26cee2c 100644 --- a/otherlibs/systhreads/Makefile.nt +++ b/otherlibs/systhreads/Makefile.nt @@ -22,6 +22,8 @@ COMPFLAGS=-w +33 -warn-error A -g MKLIB=$(CAMLRUN) ../../tools/ocamlmklib CFLAGS=-I../../byterun $(EXTRACFLAGS) +export OCAML_FLEXLINK:=$(if $(wildcard ../../flexdll/Makefile),../../boot/ocamlrun ../../flexdll/flexlink.exe) + CAMLOBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo CMIFILES=$(CAMLOBJS:.cmo=.cmi) COBJS=st_stubs_b.$(O) diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index b7851d0b7..771e52375 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -33,7 +33,7 @@ LIB=../../stdlib LIB_OBJS=$(LIB)/camlinternalFormatBasics.cmo pervasives.cmo \ $(LIB)/array.cmo $(LIB)/list.cmo $(LIB)/char.cmo $(LIB)/bytes.cmo \ - $(LIB)/string.cmo $(LIB)/sys.cmo $(LIB)/sort.cmo marshal.cmo \ + $(LIB)/string.cmo $(LIB)/sys.cmo $(LIB)/sort.cmo marshal.cmo \ $(LIB)/obj.cmo $(LIB)/int32.cmo $(LIB)/int64.cmo \ $(LIB)/nativeint.cmo $(LIB)/lexing.cmo $(LIB)/parsing.cmo \ $(LIB)/set.cmo $(LIB)/map.cmo $(LIB)/stack.cmo $(LIB)/queue.cmo \ @@ -43,9 +43,10 @@ LIB_OBJS=$(LIB)/camlinternalFormatBasics.cmo pervasives.cmo \ $(LIB)/random.cmo $(LIB)/hashtbl.cmo $(LIB)/format.cmo \ $(LIB)/scanf.cmo $(LIB)/callback.cmo $(LIB)/camlinternalOO.cmo \ $(LIB)/oo.cmo $(LIB)/camlinternalMod.cmo $(LIB)/genlex.cmo \ - $(LIB)/weak.cmo $(LIB)/filename.cmo $(LIB)/complex.cmo \ - $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo $(LIB)/bytesLabels.cmo \ - $(LIB)/stringLabels.cmo $(LIB)/moreLabels.cmo $(LIB)/stdLabels.cmo + $(LIB)/weak.cmo $(LIB)/ephemeron.cmo $(LIB)/filename.cmo \ + $(LIB)/complex.cmo $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo \ + $(LIB)/bytesLabels.cmo $(LIB)/stringLabels.cmo \ + $(LIB)/moreLabels.cmo $(LIB)/stdLabels.cmo UNIXLIB=../unix diff --git a/otherlibs/win32graph/Makefile.nt b/otherlibs/win32graph/Makefile.nt index f09392ed7..8a2e92363 100644 --- a/otherlibs/win32graph/Makefile.nt +++ b/otherlibs/win32graph/Makefile.nt @@ -31,3 +31,6 @@ 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/parsing/ast_helper.ml b/parsing/ast_helper.ml index fe6f26ce4..d4e28a240 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -29,6 +29,17 @@ let with_default_loc l f = try let r = f () in default_loc := old; r with exn -> default_loc := old; raise exn +module Const = struct + let integer ?suffix i = Pconst_integer (i, suffix) + let int ?suffix i = integer ?suffix (string_of_int i) + let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) + let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) + let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) + let float ?suffix f = Pconst_float (f, suffix) + let char c = Pconst_char c + let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) +end + module Typ = struct let mk ?(loc = !default_loc) ?(attrs = []) d = {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs} diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index 2f8ba31eb..405d770c9 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -30,6 +30,19 @@ val with_default_loc: loc -> (unit -> 'a) -> 'a (** Set the [default_loc] within the scope of the execution of the provided function. *) +(** {2 Constants} *) + +module Const : sig + val char : char -> constant + val string : ?quotation_delimiter:string -> string -> constant + val integer : ?suffix:char -> string -> constant + val int : ?suffix:char -> int -> constant + val int32 : ?suffix:char -> int32 -> constant + val int64 : ?suffix:char -> int64 -> constant + val nativeint : ?suffix:char -> nativeint -> constant + val float : ?suffix:char -> string -> constant +end + (** {2 Core language} *) (** Type expressions *) diff --git a/parsing/ast_invariants.ml b/parsing/ast_invariants.ml new file mode 100644 index 000000000..22cc1282e --- /dev/null +++ b/parsing/ast_invariants.ml @@ -0,0 +1,154 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2015 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed 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 Parsetree +open Ast_iterator + +let err = Syntaxerr.ill_formed_ast + +let empty_record loc = err loc "Records cannot be empty." +let empty_variant loc = err loc "Variant types cannot be empty." +let invalid_tuple loc = err loc "Tuples must have at least 2 components." +let no_args loc = err loc "Function application with no argument." +let empty_let loc = err loc "Let with no bindings." +let empty_type loc = err loc "Type declarations cannot be empty." +let complex_id loc = err loc "Functor application not allowed here." + +let simple_longident id = + let rec is_simple = function + | Longident.Lident _ -> true + | Longident.Ldot (id, _) -> is_simple id + | Longident.Lapply _ -> false + in + if not (is_simple id.txt) then complex_id id.loc + +let iterator = + let super = Ast_iterator.default_iterator in + let type_declaration self td = + super.type_declaration self td; + let loc = td.ptype_loc in + match td.ptype_kind with + | Ptype_record [] -> empty_record loc + | Ptype_variant [] -> empty_variant loc + | _ -> () + in + let typ self ty = + super.typ self ty; + let loc = ty.ptyp_loc in + match ty.ptyp_desc with + | Ptyp_tuple ([] | [_]) -> invalid_tuple loc + | Ptyp_class (id, _) -> simple_longident id + | Ptyp_package (_, cstrs) -> + List.iter (fun (id, _) -> simple_longident id) cstrs + | _ -> () + in + let pat self pat = + super.pat self pat; + let loc = pat.ppat_loc in + match pat.ppat_desc with + | Ppat_tuple ([] | [_]) -> invalid_tuple loc + | Ppat_record ([], _) -> empty_record loc + | Ppat_construct (id, _) -> simple_longident id + | Ppat_record (fields, _) -> + List.iter (fun (id, _) -> simple_longident id) fields + | _ -> () + in + let expr self exp = + super.expr self exp; + let loc = exp.pexp_loc in + match exp.pexp_desc with + | Pexp_tuple ([] | [_]) -> invalid_tuple loc + | Pexp_record ([], _) -> empty_record loc + | Pexp_apply (_, []) -> no_args loc + | Pexp_let (_, [], _) -> empty_let loc + | Pexp_ident id + | Pexp_construct (id, _) + | Pexp_field (_, id) + | Pexp_setfield (_, id, _) + | Pexp_new id + | Pexp_open (_, id, _) -> simple_longident id + | Pexp_record (fields, _) -> + List.iter (fun (id, _) -> simple_longident id) fields + | _ -> () + in + let extension_constructor self ec = + super.extension_constructor self ec; + match ec.pext_kind with + | Pext_rebind id -> simple_longident id + | _ -> () + in + let class_expr self ce = + super.class_expr self ce; + let loc = ce.pcl_loc in + match ce.pcl_desc with + | Pcl_apply (_, []) -> no_args loc + | Pcl_constr (id, _) -> simple_longident id + | _ -> () + in + let module_type self mty = + super.module_type self mty; + match mty.pmty_desc with + | Pmty_alias id -> simple_longident id + | _ -> () + in + let open_description self opn = + super.open_description self opn; + simple_longident opn.popen_lid + in + let with_constraint self wc = + super.with_constraint self wc; + match wc with + | Pwith_type (id, _) + | Pwith_module (id, _) -> simple_longident id + | _ -> () + in + let module_expr self me = + super.module_expr self me; + match me.pmod_desc with + | Pmod_ident id -> simple_longident id + | _ -> () + in + let structure_item self st = + super.structure_item self st; + let loc = st.pstr_loc in + match st.pstr_desc with + | Pstr_type (_, []) -> empty_type loc + | Pstr_value (_, []) -> empty_let loc + | _ -> () + in + let signature_item self sg = + super.signature_item self sg; + let loc = sg.psig_loc in + match sg.psig_desc with + | Psig_type (_, []) -> empty_type loc + | _ -> () + in + { super with + type_declaration + ; typ + ; pat + ; expr + ; extension_constructor + ; class_expr + ; module_expr + ; module_type + ; open_description + ; with_constraint + ; structure_item + ; signature_item + } + +let structure st = iterator.structure iterator st +let signature sg = iterator.signature iterator sg diff --git a/parsing/ast_invariants.mli b/parsing/ast_invariants.mli new file mode 100644 index 000000000..15d905dcf --- /dev/null +++ b/parsing/ast_invariants.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2015 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file ../LICENSE. *) +(* *) +(***********************************************************************) + +(** Check AST invariants *) + +val structure : Parsetree.structure -> unit +val signature : Parsetree.signature -> unit diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml new file mode 100755 index 000000000..22ba96ae6 --- /dev/null +++ b/parsing/ast_iterator.ml @@ -0,0 +1,588 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nicolas Ojeda Bar, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* A generic Parsetree mapping class *) + +(* +[@@@ocaml.warning "+9"] + (* Ensure that record patterns don't miss any field. *) +*) + + +open Parsetree +open Location + +type iterator = { + attribute: iterator -> attribute -> unit; + attributes: iterator -> attribute list -> 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; + constructor_declaration: iterator -> constructor_declaration -> unit; + expr: iterator -> expression -> unit; + extension: iterator -> extension -> unit; + extension_constructor: iterator -> extension_constructor -> unit; + include_declaration: iterator -> include_declaration -> unit; + include_description: iterator -> include_description -> unit; + label_declaration: iterator -> label_declaration -> unit; + location: iterator -> Location.t -> unit; + module_binding: iterator -> module_binding -> unit; + module_declaration: iterator -> module_declaration -> unit; + module_expr: iterator -> module_expr -> unit; + module_type: iterator -> module_type -> unit; + module_type_declaration: iterator -> module_type_declaration -> unit; + open_description: iterator -> open_description -> unit; + pat: iterator -> pattern -> unit; + payload: iterator -> payload -> 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_extension: iterator -> type_extension -> unit; + type_kind: iterator -> type_kind -> unit; + value_binding: iterator -> value_binding -> unit; + value_description: iterator -> value_description -> unit; + with_constraint: iterator -> with_constraint -> unit; +} +(** A [iterator] record implements one "method" per syntactic category, + using an open recursion style: each method takes as its first + argument the iterator to be applied to children in the syntax + tree. *) + +let iter_fst f (x, _) = f x +let iter_snd f (_, y) = f y +let iter_tuple f1 f2 (x, y) = f1 x; f2 y +let iter_tuple3 f1 f2 f3 (x, y, z) = f1 x; f2 y; f3 z +let iter_opt f = function None -> () | Some x -> f x + +let iter_loc sub {loc; txt = _} = sub.location sub loc + +module T = struct + (* Type expressions for the core language *) + + let row_field sub = function + | Rtag (_, attrs, _, tl) -> + sub.attributes sub attrs; List.iter (sub.typ sub) tl + | Rinherit t -> sub.typ sub t + + let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Ptyp_any + | Ptyp_var _ -> () + | Ptyp_arrow (_lab, t1, t2) -> + sub.typ sub t1; sub.typ sub t2 + | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl + | Ptyp_constr (lid, tl) -> + iter_loc sub lid; List.iter (sub.typ sub) tl + | Ptyp_object (l, o) -> + let f (_, a, t) = sub.attributes sub a; sub.typ sub t in + List.iter f l + | Ptyp_class (lid, tl) -> + iter_loc sub lid; List.iter (sub.typ sub) tl + | Ptyp_alias (t, _) -> sub.typ sub t + | Ptyp_variant (rl, b, ll) -> + List.iter (row_field sub) rl + | Ptyp_poly (_, t) -> sub.typ sub t + | Ptyp_package (lid, l) -> + iter_loc sub lid; + List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l + | Ptyp_extension x -> sub.extension sub x + + let iter_type_declaration sub + {ptype_name; ptype_params; ptype_cstrs; + ptype_kind; + ptype_private; + ptype_manifest; + ptype_attributes; + ptype_loc} = + iter_loc sub ptype_name; + List.iter (iter_fst (sub.typ sub)) ptype_params; + List.iter + (iter_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + ptype_cstrs; + sub.type_kind sub ptype_kind; + iter_opt (sub.typ sub) ptype_manifest; + sub.location sub ptype_loc; + sub.attributes sub ptype_attributes + + let iter_type_kind sub = function + | Ptype_abstract -> () + | Ptype_variant l -> + List.iter (sub.constructor_declaration sub) l + | Ptype_record l -> List.iter (sub.label_declaration sub) l + | Ptype_open -> () + + let iter_constructor_arguments sub = function + | Pcstr_tuple l -> List.iter (sub.typ sub) l + | Pcstr_record l -> + List.iter (sub.label_declaration sub) l + + let iter_type_extension sub + {ptyext_path; ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_attributes} = + iter_loc sub ptyext_path; + List.iter (sub.extension_constructor sub) ptyext_constructors; + List.iter (iter_fst (sub.typ sub)) ptyext_params; + sub.attributes sub ptyext_attributes + + let iter_extension_constructor_kind sub = function + Pext_decl(ctl, cto) -> + iter_constructor_arguments sub ctl; iter_opt (sub.typ sub) cto + | Pext_rebind li -> + iter_loc sub li + + let iter_extension_constructor sub + {pext_name; + pext_kind; + pext_loc; + pext_attributes} = + iter_loc sub pext_name; + iter_extension_constructor_kind sub pext_kind; + sub.location sub pext_loc; + sub.attributes sub pext_attributes + +end + +module CT = struct + (* Type expressions for the class language *) + + let iter sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pcty_constr (lid, tys) -> + iter_loc sub lid; List.iter (sub.typ sub) tys + | Pcty_signature x -> sub.class_signature sub x + | Pcty_arrow (_lab, t, ct) -> + sub.typ sub t; sub.class_type sub ct + | Pcty_extension x -> sub.extension sub x + + let iter_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} + = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pctf_inherit ct -> sub.class_type sub ct + | Pctf_val (s, m, v, t) -> sub.typ sub t + | Pctf_method (s, p, v, t) -> sub.typ sub t + | Pctf_constraint (t1, t2) -> + sub.typ sub t1; sub.typ sub t2 + | Pctf_attribute x -> sub.attribute sub x + | Pctf_extension x -> sub.extension sub x + + let iter_signature sub {pcsig_self; pcsig_fields} = + sub.typ sub pcsig_self; + List.iter (sub.class_type_field sub) pcsig_fields +end + +module MT = struct + (* Type expressions for the module language *) + + let iter sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pmty_ident s -> iter_loc sub s + | Pmty_alias s -> iter_loc sub s + | Pmty_signature sg -> sub.signature sub sg + | Pmty_functor (s, mt1, mt2) -> + iter_loc sub s; + iter_opt (sub.module_type sub) mt1; + sub.module_type sub mt2 + | Pmty_with (mt, l) -> + sub.module_type sub mt; + List.iter (sub.with_constraint sub) l + | Pmty_typeof me -> sub.module_expr sub me + | Pmty_extension x -> sub.extension sub x + + let iter_with_constraint sub = function + | Pwith_type (lid, d) -> + iter_loc sub lid; sub.type_declaration sub d + | Pwith_module (lid, lid2) -> + iter_loc sub lid; iter_loc sub lid2 + | Pwith_typesubst d -> sub.type_declaration sub d + | Pwith_modsubst (s, lid) -> + iter_loc sub s; iter_loc sub lid + + let iter_signature_item sub {psig_desc = desc; psig_loc = loc} = + sub.location sub loc; + match desc with + | Psig_value vd -> sub.value_description sub vd + | Psig_type (rf, l) -> List.iter (sub.type_declaration sub) l + | Psig_typext te -> sub.type_extension sub te + | Psig_exception ed -> sub.extension_constructor sub ed + | Psig_module x -> sub.module_declaration sub x + | Psig_recmodule l -> + List.iter (sub.module_declaration sub) l + | Psig_modtype x -> sub.module_type_declaration sub x + | Psig_open x -> sub.open_description sub x + | Psig_include x -> sub.include_description sub x + | Psig_class l -> List.iter (sub.class_description sub) l + | Psig_class_type l -> + List.iter (sub.class_type_declaration sub) l + | Psig_extension (x, attrs) -> + sub.extension sub x; sub.attributes sub attrs + | Psig_attribute x -> sub.attribute sub x +end + + +module M = struct + (* Value expressions for the module language *) + + let iter sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pmod_ident x -> iter_loc sub x + | Pmod_structure str -> sub.structure sub str + | Pmod_functor (arg, arg_ty, body) -> + iter_loc sub arg; + iter_opt (sub.module_type sub) arg_ty; + sub.module_expr sub body + | Pmod_apply (m1, m2) -> + sub.module_expr sub m1; sub.module_expr sub m2 + | Pmod_constraint (m, mty) -> + sub.module_expr sub m; sub.module_type sub mty + | Pmod_unpack e -> sub.expr sub e + | Pmod_extension x -> sub.extension sub x + + let iter_structure_item sub {pstr_loc = loc; pstr_desc = desc} = + sub.location sub loc; + match desc with + | Pstr_eval (x, attrs) -> + sub.expr sub x; sub.attributes sub attrs + | Pstr_value (r, vbs) -> List.iter (sub.value_binding sub) vbs + | Pstr_primitive vd -> sub.value_description sub vd + | Pstr_type (rf, l) -> List.iter (sub.type_declaration sub) l + | Pstr_typext te -> sub.type_extension sub te + | Pstr_exception ed -> sub.extension_constructor sub ed + | Pstr_module x -> sub.module_binding sub x + | Pstr_recmodule l -> List.iter (sub.module_binding sub) l + | Pstr_modtype x -> sub.module_type_declaration sub x + | Pstr_open x -> sub.open_description sub x + | Pstr_class l -> List.iter (sub.class_declaration sub) l + | Pstr_class_type l -> + List.iter (sub.class_type_declaration sub) l + | Pstr_include x -> sub.include_declaration sub x + | Pstr_extension (x, attrs) -> + sub.extension sub x; sub.attributes sub attrs + | Pstr_attribute x -> sub.attribute sub x +end + +module E = struct + (* Value expressions for the core language *) + + let iter sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pexp_ident x -> iter_loc sub x + | Pexp_constant x -> () + | Pexp_let (r, vbs, e) -> + List.iter (sub.value_binding sub) vbs; + sub.expr sub e + | Pexp_fun (lab, def, p, e) -> + iter_opt (sub.expr sub) def; + sub.pat sub p; + sub.expr sub e + | Pexp_function pel -> sub.cases sub pel + | Pexp_apply (e, l) -> + sub.expr sub e; List.iter (iter_snd (sub.expr sub)) l + | Pexp_match (e, pel) -> + sub.expr sub e; sub.cases sub pel + | Pexp_try (e, pel) -> sub.expr sub e; sub.cases sub pel + | Pexp_tuple el -> List.iter (sub.expr sub) el + | Pexp_construct (lid, arg) -> + iter_loc sub lid; iter_opt (sub.expr sub) arg + | Pexp_variant (lab, eo) -> + iter_opt (sub.expr sub) eo + | Pexp_record (l, eo) -> + List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l; + iter_opt (sub.expr sub) eo + | Pexp_field (e, lid) -> + sub.expr sub e; iter_loc sub lid + | Pexp_setfield (e1, lid, e2) -> + sub.expr sub e1; iter_loc sub lid; + sub.expr sub e2 + | Pexp_array el -> List.iter (sub.expr sub) el + | Pexp_ifthenelse (e1, e2, e3) -> + sub.expr sub e1; sub.expr sub e2; + iter_opt (sub.expr sub) e3 + | Pexp_sequence (e1, e2) -> + sub.expr sub e1; sub.expr sub e2 + | Pexp_while (e1, e2) -> + sub.expr sub e1; sub.expr sub e2 + | Pexp_for (p, e1, e2, d, e3) -> + sub.pat sub p; sub.expr sub e1; sub.expr sub e2; + sub.expr sub e3 + | Pexp_coerce (e, t1, t2) -> + sub.expr sub e; iter_opt (sub.typ sub) t1; + sub.typ sub t2 + | Pexp_constraint (e, t) -> + sub.expr sub e; sub.typ sub t + | Pexp_send (e, s) -> sub.expr sub e + | Pexp_new lid -> iter_loc sub lid + | Pexp_setinstvar (s, e) -> + iter_loc sub s; sub.expr sub e + | Pexp_override sel -> + List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) sel + | Pexp_letmodule (s, me, e) -> + iter_loc sub s; sub.module_expr sub me; + sub.expr sub e + | Pexp_assert e -> sub.expr sub e + | Pexp_lazy e -> sub.expr sub e + | Pexp_poly (e, t) -> + sub.expr sub e; iter_opt (sub.typ sub) t + | Pexp_object cls -> sub.class_structure sub cls + | Pexp_newtype (s, e) -> sub.expr sub e + | Pexp_pack me -> sub.module_expr sub me + | Pexp_open (ovf, lid, e) -> + iter_loc sub lid; sub.expr sub e + | Pexp_extension x -> sub.extension sub x + | Pexp_unreachable -> () +end + +module P = struct + (* Patterns *) + + let iter sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Ppat_any -> () + | Ppat_var s -> iter_loc sub s + | Ppat_alias (p, s) -> sub.pat sub p; iter_loc sub s + | Ppat_constant c -> () + | Ppat_interval (c1, c2) -> () + | Ppat_tuple pl -> List.iter (sub.pat sub) pl + | Ppat_construct (l, p) -> + iter_loc sub l; iter_opt (sub.pat sub) p + | Ppat_variant (l, p) -> iter_opt (sub.pat sub) p + | Ppat_record (lpl, cf) -> + List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl + | Ppat_array pl -> List.iter (sub.pat sub) pl + | Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2 + | Ppat_constraint (p, t) -> + sub.pat sub p; sub.typ sub t + | Ppat_type s -> iter_loc sub s + | Ppat_lazy p -> sub.pat sub p + | Ppat_unpack s -> iter_loc sub s + | Ppat_exception p -> sub.pat sub p + | Ppat_extension x -> sub.extension sub x +end + +module CE = struct + (* Value expressions for the class language *) + + let iter sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pcl_constr (lid, tys) -> + iter_loc sub lid; List.iter (sub.typ sub) tys + | Pcl_structure s -> + sub.class_structure sub s + | Pcl_fun (lab, e, p, ce) -> + iter_opt (sub.expr sub) e; + sub.pat sub p; + sub.class_expr sub ce + | Pcl_apply (ce, l) -> + sub.class_expr sub ce; + List.iter (iter_snd (sub.expr sub)) l + | Pcl_let (r, vbs, ce) -> + List.iter (sub.value_binding sub) vbs; + sub.class_expr sub ce + | Pcl_constraint (ce, ct) -> + sub.class_expr sub ce; sub.class_type sub ct + | Pcl_extension x -> sub.extension sub x + + let iter_kind sub = function + | Cfk_concrete (o, e) -> sub.expr sub e + | Cfk_virtual t -> sub.typ sub t + + let iter_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pcf_inherit (o, ce, s) -> sub.class_expr sub ce + | Pcf_val (s, m, k) -> iter_loc sub s; iter_kind sub k + | Pcf_method (s, p, k) -> + iter_loc sub s; iter_kind sub k + | Pcf_constraint (t1, t2) -> + sub.typ sub t1; sub.typ sub t2 + | Pcf_initializer e -> sub.expr sub e + | Pcf_attribute x -> sub.attribute sub x + | Pcf_extension x -> sub.extension sub x + + let iter_structure sub {pcstr_self; pcstr_fields} = + sub.pat sub pcstr_self; + List.iter (sub.class_field sub) pcstr_fields + + let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; + pci_loc; pci_attributes} = + List.iter (iter_fst (sub.typ sub)) pl; + iter_loc sub pci_name; + f pci_expr; + sub.location sub pci_loc; + sub.attributes sub pci_attributes +end + +(* Now, a generic AST mapper, to be extended to cover all kinds and + cases of the OCaml grammar. The default behavior of the mapper is + the identity. *) + +let default_iterator = + { + structure = (fun this l -> List.iter (this.structure_item this) l); + structure_item = M.iter_structure_item; + module_expr = M.iter; + signature = (fun this l -> List.iter (this.signature_item this) l); + signature_item = MT.iter_signature_item; + module_type = MT.iter; + with_constraint = MT.iter_with_constraint; + class_declaration = + (fun this -> CE.class_infos this (this.class_expr this)); + class_expr = CE.iter; + class_field = CE.iter_field; + class_structure = CE.iter_structure; + class_type = CT.iter; + class_type_field = CT.iter_field; + class_signature = CT.iter_signature; + class_type_declaration = + (fun this -> CE.class_infos this (this.class_type this)); + class_description = + (fun this -> CE.class_infos this (this.class_type this)); + type_declaration = T.iter_type_declaration; + type_kind = T.iter_type_kind; + typ = T.iter; + type_extension = T.iter_type_extension; + extension_constructor = T.iter_extension_constructor; + value_description = + (fun this {pval_name; pval_type; pval_prim; pval_loc; + pval_attributes} -> + iter_loc this pval_name; + this.typ this pval_type; + this.attributes this pval_attributes; + this.location this pval_loc + ); + + pat = P.iter; + expr = E.iter; + + module_declaration = + (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> + iter_loc this pmd_name; + this.module_type this pmd_type; + this.attributes this pmd_attributes; + this.location this pmd_loc + ); + + module_type_declaration = + (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> + iter_loc this pmtd_name; + iter_opt (this.module_type this) pmtd_type; + this.attributes this pmtd_attributes; + this.location this pmtd_loc + ); + + module_binding = + (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> + iter_loc this pmb_name; this.module_expr this pmb_expr; + this.attributes this pmb_attributes; + this.location this pmb_loc + ); + + + open_description = + (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> + iter_loc this popen_lid; + this.location this popen_loc; + this.attributes this popen_attributes + ); + + + include_description = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + this.module_type this pincl_mod; + this.location this pincl_loc; + this.attributes this pincl_attributes + ); + + include_declaration = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + this.module_expr this pincl_mod; + this.location this pincl_loc; + this.attributes this pincl_attributes + ); + + + value_binding = + (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> + this.pat this pvb_pat; + this.expr this pvb_expr; + this.location this pvb_loc; + this.attributes this pvb_attributes + ); + + + constructor_declaration = + (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> + iter_loc this pcd_name; + T.iter_constructor_arguments this pcd_args; + iter_opt (this.typ this) pcd_res; + this.location this pcd_loc; + this.attributes this pcd_attributes + ); + + label_declaration = + (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> + iter_loc this pld_name; + this.typ this pld_type; + this.location this pld_loc; + this.attributes this pld_attributes + ); + + cases = (fun this l -> List.iter (this.case this) l); + case = + (fun this {pc_lhs; pc_guard; pc_rhs} -> + this.pat this pc_lhs; + iter_opt (this.expr this) pc_guard; + this.expr this pc_rhs + ); + + location = (fun this l -> ()); + + extension = (fun this (s, e) -> iter_loc this s; this.payload this e); + attribute = (fun this (s, e) -> iter_loc this s; this.payload this e); + attributes = (fun this l -> List.iter (this.attribute this) l); + payload = + (fun this -> function + | PStr x -> this.structure this x + | PSig x -> this.signature this x + | PTyp x -> this.typ this x + | PPat (x, g) -> this.pat this x; iter_opt (this.expr this) g + ); + } diff --git a/parsing/ast_iterator.mli b/parsing/ast_iterator.mli new file mode 100755 index 000000000..c8d7dd00e --- /dev/null +++ b/parsing/ast_iterator.mli @@ -0,0 +1,69 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nicolas Ojeda Bar, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(** {!iterator} allows to implement AST inspection using open recursion. A + typical mapper would be based on {!default_iterator}, a trivial iterator, + and will fall back on it for handling the syntax it does not modify. *) + +open Parsetree + +(** {2 A generic Parsetree iterator} *) + +type iterator = { + attribute: iterator -> attribute -> unit; + attributes: iterator -> attribute list -> 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; + constructor_declaration: iterator -> constructor_declaration -> unit; + expr: iterator -> expression -> unit; + extension: iterator -> extension -> unit; + extension_constructor: iterator -> extension_constructor -> unit; + include_declaration: iterator -> include_declaration -> unit; + include_description: iterator -> include_description -> unit; + label_declaration: iterator -> label_declaration -> unit; + location: iterator -> Location.t -> unit; + module_binding: iterator -> module_binding -> unit; + module_declaration: iterator -> module_declaration -> unit; + module_expr: iterator -> module_expr -> unit; + module_type: iterator -> module_type -> unit; + module_type_declaration: iterator -> module_type_declaration -> unit; + open_description: iterator -> open_description -> unit; + pat: iterator -> pattern -> unit; + payload: iterator -> payload -> 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_extension: iterator -> type_extension -> unit; + type_kind: iterator -> type_kind -> unit; + value_binding: iterator -> value_binding -> unit; + value_description: iterator -> value_description -> unit; + with_constraint: iterator -> with_constraint -> unit; +} +(** A [iterator] record implements one "method" per syntactic category, + using an open recursion style: each method takes as its first + argument the iterator to be applied to children in the syntax + tree. *) + +val default_iterator: iterator +(** A default iterator, which implements a "do not do anything" mapping. *) diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index d35409e22..cd5210dd3 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -626,13 +626,13 @@ let default_mapper = let rec extension_of_error {loc; msg; if_highlight; sub} = { loc; txt = "ocaml.error" }, - PStr ([Str.eval (Exp.constant (PConst_string (msg, None))); - Str.eval (Exp.constant (PConst_string (if_highlight, None)))] @ + PStr ([Str.eval (Exp.constant (Pconst_string (msg, None))); + Str.eval (Exp.constant (Pconst_string (if_highlight, None)))] @ (List.map (fun ext -> Str.extension (extension_of_error ext)) sub)) let attribute_of_warning loc s = { loc; txt = "ocaml.ppwarning" }, - PStr ([Str.eval ~loc (Exp.constant (PConst_string (s, None)))]) + PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, None)))]) module StringMap = Map.Make(struct type t = string @@ -660,7 +660,7 @@ module PpxContext = struct let lid name = { txt = Lident name; loc = Location.none } - let make_string x = Exp.constant (PConst_string (x, None)) + let make_string x = Exp.constant (Pconst_string (x, None)) let make_bool x = if x @@ -715,7 +715,7 @@ module PpxContext = struct let restore fields = let field name payload = let rec get_string = function - | { pexp_desc = Pexp_constant (PConst_string (str, None)) } -> str + | { pexp_desc = Pexp_constant (Pconst_string (str, None)) } -> str | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ { %s }] string syntax" name and get_bool pexp = diff --git a/parsing/builtin_attributes.ml b/parsing/builtin_attributes.ml index 0f1641af9..e9d0fa916 100755 --- a/parsing/builtin_attributes.ml +++ b/parsing/builtin_attributes.ml @@ -14,7 +14,7 @@ open Asttypes open Parsetree let string_of_cst = function - | PConst_string(s, _) -> Some s + | Pconst_string(s, _) -> Some s | _ -> None let string_of_payload = function @@ -37,13 +37,13 @@ let rec error_of_extension ext = in begin match p with | PStr({pstr_desc=Pstr_eval - ({pexp_desc=Pexp_constant(PConst_string(msg,_))}, _)}:: + ({pexp_desc=Pexp_constant(Pconst_string(msg,_))}, _)}:: {pstr_desc=Pstr_eval - ({pexp_desc=Pexp_constant(PConst_string(if_highlight,_))}, _)}:: + ({pexp_desc=Pexp_constant(Pconst_string(if_highlight,_))}, _)}:: inner) -> Location.error ~loc ~if_highlight ~sub:(sub_from inner) msg | PStr({pstr_desc=Pstr_eval - ({pexp_desc=Pexp_constant(PConst_string(msg,_))}, _)}::inner) -> + ({pexp_desc=Pexp_constant(Pconst_string(msg,_))}, _)}::inner) -> Location.error ~loc ~sub:(sub_from inner) msg | _ -> Location.errorf ~loc "Invalid syntax for extension '%s'." txt end @@ -106,19 +106,17 @@ let emit_external_warnings = 'ppwarning' attributes during the actual type-checking, making sure to cover all contexts (easier and more ugly alternative: duplicate here the logic which control warnings locally). *) - let open Ast_mapper in + let open Ast_iterator in { - default_mapper with + default_iterator with attribute = (fun _ a -> - begin match a with + match a with | {txt="ocaml.ppwarning"|"ppwarning"}, PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant - (PConst_string (s, _))},_); + (Pconst_string (s, _))},_); pstr_loc}] -> Location.prerr_warning pstr_loc (Warnings.Preprocessor s) | _ -> () - end; - a ) } diff --git a/parsing/builtin_attributes.mli b/parsing/builtin_attributes.mli index 2760bf5f5..ee2be723c 100755 --- a/parsing/builtin_attributes.mli +++ b/parsing/builtin_attributes.mli @@ -37,7 +37,7 @@ val warning_leave_scope: unit -> unit val warning_attribute: Parsetree.attributes -> unit val with_warning_attribute: Parsetree.attributes -> (unit -> 'a) -> 'a -val emit_external_warnings: Ast_mapper.mapper +val emit_external_warnings: Ast_iterator.iterator val warn_on_literal_pattern: Parsetree.attributes -> bool val explicit_arity: Parsetree.attributes -> bool diff --git a/parsing/docstrings.ml b/parsing/docstrings.ml index f4bbe9bae..7562f22ea 100644 --- a/parsing/docstrings.ml +++ b/parsing/docstrings.ml @@ -85,7 +85,7 @@ let doc_loc = {txt = "ocaml.doc"; loc = Location.none} let docs_attr ds = let open Parsetree in let exp = - { pexp_desc = Pexp_constant (PConst_string(ds.ds_body, None)); + { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); pexp_loc = ds.ds_loc; pexp_attributes = []; } in @@ -116,12 +116,9 @@ let empty_info = None let info_attr = docs_attr let add_info_attrs info attrs = - let attrs = - match info with - | None -> attrs - | Some ds -> attrs @ [info_attr ds] - in - attrs + match info with + | None -> attrs + | Some ds -> attrs @ [info_attr ds] (* Docstrings not attached to a specifc item *) @@ -134,7 +131,7 @@ let text_loc = {txt = "ocaml.text"; loc = Location.none} let text_attr ds = let open Parsetree in let exp = - { pexp_desc = Pexp_constant (PConst_string(ds.ds_body, None)); + { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); pexp_loc = ds.ds_loc; pexp_attributes = []; } in diff --git a/parsing/lexer.mll b/parsing/lexer.mll index 25e2aad1c..ec1a93bca 100644 --- a/parsing/lexer.mll +++ b/parsing/lexer.mll @@ -163,6 +163,12 @@ let char_for_decimal_code lexbuf i = Location.curr lexbuf)) else Char.chr c +let char_for_octal_code lexbuf i = + let c = 64 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + + 8 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in + Char.chr c + let char_for_hexadecimal_code lexbuf i = let d1 = Char.code (Lexing.lexeme_char lexbuf i) in let val1 = if d1 >= 97 then d1 - 87 @@ -366,6 +372,8 @@ rule token = parse { CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) } | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'" { CHAR(char_for_decimal_code lexbuf 2) } + | "\'\\" 'o' ['0'-'3'] ['0'-'7'] ['0'-'7'] "\'" + { CHAR(char_for_octal_code lexbuf 3) } | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'" { CHAR(char_for_hexadecimal_code lexbuf 3) } | "\'\\" _ @@ -583,6 +591,9 @@ and string = parse | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { store_string_char(char_for_decimal_code lexbuf 1); string lexbuf } + | '\\' 'o' ['0'-'3'] ['0'-'7'] ['0'-'7'] + { store_string_char(char_for_octal_code lexbuf 2); + string lexbuf } | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] { store_string_char(char_for_hexadecimal_code lexbuf 2); string lexbuf } diff --git a/parsing/parser.mly b/parsing/parser.mly index f19579090..e9c5842ca 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -79,18 +79,18 @@ let neg_string f = let mkuminus name arg = match name, arg.pexp_desc with - | "-", Pexp_constant(PConst_int (n,m)) -> - mkexp(Pexp_constant(PConst_int(neg_string n,m))) - | ("-" | "-."), Pexp_constant(PConst_float (f, m)) -> - mkexp(Pexp_constant(PConst_float(neg_string f, m))) + | "-", Pexp_constant(Pconst_integer (n,m)) -> + mkexp(Pexp_constant(Pconst_integer(neg_string n,m))) + | ("-" | "-."), Pexp_constant(Pconst_float (f, m)) -> + mkexp(Pexp_constant(Pconst_float(neg_string f, m))) | _ -> mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg])) let mkuplus name arg = let desc = arg.pexp_desc in match name, desc with - | "+", Pexp_constant(PConst_int _) - | ("+" | "+."), Pexp_constant(PConst_float _) -> mkexp desc + | "+", Pexp_constant(Pconst_integer _) + | ("+" | "+."), Pexp_constant(Pconst_float _) -> mkexp desc | _ -> mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg])) @@ -2169,17 +2169,17 @@ label: /* Constants */ constant: - | INT { let (n, m) = $1 in PConst_int (n, m) } - | CHAR { PConst_char $1 } - | STRING { let (s, d) = $1 in PConst_string (s, d) } - | FLOAT { let (f, m) = $1 in PConst_float (f, m) } + | INT { let (n, m) = $1 in Pconst_integer (n, m) } + | CHAR { Pconst_char $1 } + | STRING { let (s, d) = $1 in Pconst_string (s, d) } + | FLOAT { let (f, m) = $1 in Pconst_float (f, m) } ; signed_constant: constant { $1 } - | MINUS INT { let (n, m) = $2 in PConst_int("-" ^ n, m) } - | MINUS FLOAT { let (f, m) = $2 in PConst_float("-" ^ f, m) } - | PLUS INT { let (n, m) = $2 in PConst_int (n, m) } - | PLUS FLOAT { let (f, m) = $2 in PConst_float(f, m) } + | MINUS INT { let (n, m) = $2 in Pconst_integer("-" ^ n, m) } + | MINUS FLOAT { let (f, m) = $2 in Pconst_float("-" ^ f, m) } + | PLUS INT { let (n, m) = $2 in Pconst_integer (n, m) } + | PLUS FLOAT { let (f, m) = $2 in Pconst_float(f, m) } ; /* Identifiers and long identifiers */ @@ -2222,10 +2222,10 @@ operator: ; constr_ident: UIDENT { $1 } -/* | LBRACKET RBRACKET { "[]" } */ + | LBRACKET RBRACKET { "[]" } | LPAREN RPAREN { "()" } - | COLONCOLON { "::" } -/* | LPAREN COLONCOLON RPAREN { "::" } */ + /* | COLONCOLON { "::" } */ + | LPAREN COLONCOLON RPAREN { "::" } | FALSE { "false" } | TRUE { "true" } ; diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 5e6edbf14..a2db59c50 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -15,10 +15,24 @@ open Asttypes type constant = - PConst_int of string * char option - | PConst_char of char - | PConst_string of string * string option - | PConst_float of string * char option + Pconst_integer of string * char option + (* 3 3l 3L 3n + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes except 'l', 'L' and 'n' are rejected by the typechecker + *) + | Pconst_char of char + (* 'c' *) + | Pconst_string of string * string option + (* "constant" + {delim|other constant|delim} + *) + | Pconst_float of string * char option + (* 3.4 2e5 1.4e-4 + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. + *) (** {2 Extension points} *) diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 4a0b5c6b2..f741565eb 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -168,13 +168,13 @@ class printer ()= object(self:'self) pp f "%a(%a)" self#longident y self#longident s method longident_loc f x = pp f "%a" self#longident x.txt method constant f = function - | PConst_char i -> pp f "%C" i - | PConst_string (i, None) -> pp f "%S" i - | PConst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim - | PConst_int (i,None) -> self#paren (i.[0]='-') (fun f -> pp f "%s") f i - | PConst_int (i,Some m) -> self#paren (i.[0]='-') (fun f (i,m) -> pp f "%s%c" i m) f (i,m) - | PConst_float (i,None) -> self#paren (i.[0]='-') (fun f -> pp f "%s") f i - | PConst_float (i, Some m) -> self#paren (i.[0]='-') (fun f (i,m) -> pp f "%s%c" i m) f (i,m) + | Pconst_char i -> pp f "%C" i + | Pconst_string (i, None) -> pp f "%S" i + | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim + | Pconst_integer (i,None) -> self#paren (i.[0]='-') (fun f -> pp f "%s") f i + | Pconst_integer (i,Some m) -> self#paren (i.[0]='-') (fun f (i,m) -> pp f "%s%c" i m) f (i,m) + | Pconst_float (i,None) -> self#paren (i.[0]='-') (fun f -> pp f "%s") f i + | Pconst_float (i, Some m) -> self#paren (i.[0]='-') (fun f (i,m) -> pp f "%s%c" i m) f (i,m) (* trailing space*) method mutable_flag f = function diff --git a/parsing/printast.ml b/parsing/printast.ml index db90e46da..c401b93da 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -55,12 +55,12 @@ let fmt_char_option f = function let fmt_constant f x = match x with - | PConst_int (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m; - | PConst_char (c) -> fprintf f "PConst_char %02x" (Char.code c); - | PConst_string (s, None) -> fprintf f "PConst_string(%S,None)" s; - | PConst_string (s, Some delim) -> + | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m; + | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c); + | Pconst_string (s, None) -> fprintf f "PConst_string(%S,None)" s; + | Pconst_string (s, Some delim) -> fprintf f "PConst_string (%S,Some %S)" s delim; - | PConst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m; + | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m; ;; let fmt_mutable_flag f x = diff --git a/stdlib/.depend b/stdlib/.depend index bdf9cbb24..d83a6c53c 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -48,6 +48,7 @@ stringLabels.cmi : sys.cmi : uchar.cmi : format.cmi weak.cmi : hashtbl.cmi +ephemeron.cmi : hashtbl.cmi obj.cmi arg.cmo : sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi \ arg.cmi arg.cmx : sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx \ @@ -176,6 +177,8 @@ uchar.cmo : printf.cmi pervasives.cmi format.cmi char.cmi uchar.cmi uchar.cmx : printf.cmx pervasives.cmx format.cmx char.cmx uchar.cmi weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi weak.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi +ephemeron.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi obj.cmi ephemeron.cmi +ephemeron.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx obj.cmx ephemeron.cmi arg.cmo : sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi \ arg.cmi arg.p.cmx : sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx \ @@ -304,3 +307,5 @@ uchar.cmo : printf.cmi pervasives.cmi format.cmi char.cmi uchar.cmi uchar.p.cmx : printf.cmx pervasives.cmx format.cmx char.cmx uchar.cmi weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi weak.p.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi +ephemeron.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi obj.cmi ephemeron.cmi +ephemeron.p.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx obj.cmx ephemeron.cmi diff --git a/stdlib/Makefile.shared b/stdlib/Makefile.shared index 5d1b73cb3..92bf46b7e 100755 --- a/stdlib/Makefile.shared +++ b/stdlib/Makefile.shared @@ -36,7 +36,7 @@ OTHERS=list.cmo char.cmo bytes.cmo string.cmo sys.cmo \ digest.cmo random.cmo hashtbl.cmo weak.cmo \ format.cmo uchar.cmo scanf.cmo callback.cmo \ camlinternalOO.cmo oo.cmo camlinternalMod.cmo \ - genlex.cmo \ + genlex.cmo ephemeron.cmo \ filename.cmo complex.cmo \ arrayLabels.cmo listLabels.cmo bytesLabels.cmo \ stringLabels.cmo moreLabels.cmo stdLabels.cmo diff --git a/stdlib/ephemeron.ml b/stdlib/ephemeron.ml new file mode 100644 index 000000000..c14c7e36b --- /dev/null +++ b/stdlib/ephemeron.ml @@ -0,0 +1,614 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Para, 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +module type SeededS = sig + include Hashtbl.SeededS + val clean: 'a t -> unit + val stats_alive: 'a t -> Hashtbl.statistics + (** same as {!stats} but only count the alive bindings *) +end + +module type S = sig + include Hashtbl.S + val clean: 'a t -> unit + val stats_alive: 'a t -> Hashtbl.statistics + (** same as {!stats} but only count the alive bindings *) +end + +module GenHashTable = struct + + type equal = + | ETrue | EFalse + | EDead (** the garbage collector reclaimed the data *) + + module MakeSeeded(H: sig + type t + type 'a container + val create: t -> 'a -> 'a container + val hash: int -> t -> int + val equal: 'a container -> t -> equal + val get_data: 'a container -> 'a option + val get_key: 'a container -> t option + val set_key_data: 'a container -> t -> 'a -> unit + val check_key: 'a container -> bool + end) : SeededS with type key = H.t + = struct + + type 'a t = + { mutable size: int; (* number of entries *) + mutable data: 'a bucketlist array; (* the buckets *) + mutable seed: int; (* for randomization *) + initial_size: int; (* initial array size *) + } + + and 'a bucketlist = + | Empty + | Cons of int (** hash of the key *) * 'a H.container * 'a bucketlist + + (** the hash of the key is kept in order to test the equality of the hash + before the key. Same reason than for Weak.Make *) + + type key = H.t + + let rec power_2_above x n = + if x >= n then x + else if x * 2 > Sys.max_array_length then x + else power_2_above (x * 2) n + + let prng = lazy (Random.State.make_self_init()) + + let create ?(random = (Hashtbl.is_randomized ())) initial_size = + let s = power_2_above 16 initial_size in + let seed = if random then Random.State.bits (Lazy.force prng) else 0 in + { initial_size = s; size = 0; seed = seed; data = Array.make s Empty } + + let clear h = + h.size <- 0; + let len = Array.length h.data in + for i = 0 to len - 1 do + h.data.(i) <- Empty + done + + let reset h = + let len = Array.length h.data in + if len = h.initial_size then + clear h + else begin + h.size <- 0; + h.data <- Array.make h.initial_size Empty + end + + let copy h = { h with data = Array.copy h.data } + + let key_index h hkey = + hkey land (Array.length h.data - 1) + + let clean h = + let rec do_bucket = function + | Empty -> + Empty + | Cons(_, c, rest) when not (H.check_key c) -> + h.size <- h.size - 1; + do_bucket rest + | Cons(hkey, c, rest) -> + Cons(hkey, c, do_bucket rest) + in + let d = h.data in + for i = 0 to Array.length d - 1 do + d.(i) <- do_bucket d.(i) + done + + (** resize is the only function to do the actual cleaning of dead keys + (remove does it just because it could). + + The goal is to: + + - not resize infinitely when the actual number of alive keys is + bounded but keys are continuously added. That would happen if + this function always resize. + - not call this function after each addition, that would happen if this + function don't resize even when only one key is dead. + + So the algorithm: + - clean the keys before resizing + - if the number of remaining key is less than half the size of the + array, don't resize. + - if it is more, resize. + + The second problem remains if the table reaches {!Sys.max_array_length}. + + *) + let resize h = + let odata = h.data in + let osize = Array.length odata in + let nsize = osize * 2 in + clean h; + if nsize < Sys.max_array_length && h.size >= osize lsr 1 then begin + let ndata = Array.make nsize Empty in + h.data <- ndata; (* so that key_index sees the new bucket count *) + let rec insert_bucket = function + Empty -> () + | Cons(hkey, data, rest) -> + insert_bucket rest; (* preserve original order of elements *) + let nidx = key_index h hkey in + ndata.(nidx) <- Cons(hkey, data, ndata.(nidx)) in + for i = 0 to osize - 1 do + insert_bucket odata.(i) + done + end + + let add h key info = + let hkey = H.hash h.seed key in + let i = key_index h hkey in + let container = H.create key info in + let bucket = Cons(hkey, container, h.data.(i)) in + h.data.(i) <- bucket; + h.size <- h.size + 1; + if h.size > Array.length h.data lsl 1 then resize h + + let remove h key = + let hkey = H.hash h.seed key in + let rec remove_bucket = function + | Empty -> Empty + | Cons(hk, c, next) when hkey = hk -> + begin match H.equal c key with + | ETrue -> h.size <- h.size - 1; next + | EFalse -> Cons(hk, c, remove_bucket next) + | EDead -> + (** The dead key is automatically removed. It is acceptable + for this function since it already remove a binding *) + h.size <- h.size - 1; + remove_bucket next + end + | Cons(hk,c,next) -> Cons(hk, c, remove_bucket next) in + let i = key_index h hkey in + h.data.(i) <- remove_bucket h.data.(i) + + (** {!find} don't remove dead keys because it would be surprising for + the user that a read-only function mutate the state (eg. concurrent + access). Same for {!iter}, {!fold}, {!mem}. + *) + let rec find_rec key hkey = function + | Empty -> + raise Not_found + | Cons(hk, c, rest) when hkey = hk -> + begin match H.equal c key with + | ETrue -> + begin match H.get_data c with + | None -> + (** This case is not impossible because the gc can run between + H.equal and H.get_data *) + find_rec key hkey rest + | Some d -> d + end + | EFalse -> find_rec key hkey rest + | EDead -> + find_rec key hkey rest + end + | Cons(_, _, rest) -> + find_rec key hkey rest + + let find h key = + let hkey = H.hash h.seed key in + (** TODO inline 3 iteration *) + find_rec key hkey (h.data.(key_index h hkey)) + + let find_all h key = + let hkey = H.hash h.seed key in + let rec find_in_bucket = function + | Empty -> [] + | Cons(hk, c, rest) when hkey = hk -> + begin match H.equal c key with + | ETrue -> begin match H.get_data c with + | None -> + find_in_bucket rest + | Some d -> d::find_in_bucket rest + end + | EFalse -> find_in_bucket rest + | EDead -> + find_in_bucket rest + end + | Cons(_, _, rest) -> + find_in_bucket rest in + find_in_bucket h.data.(key_index h hkey) + + + let replace h key info = + let hkey = H.hash h.seed key in + let rec replace_bucket = function + | Empty -> raise Not_found + | Cons(hk, c, next) when hkey = hk -> + begin match H.equal c key with + | ETrue -> H.set_key_data c key info + | EFalse | EDead -> replace_bucket next + end + | Cons(_,_,next) -> replace_bucket next + in + let i = key_index h hkey in + let l = h.data.(i) in + try + replace_bucket l + with Not_found -> + let container = H.create key info in + h.data.(i) <- Cons(hkey, container, l); + h.size <- h.size + 1; + if h.size > Array.length h.data lsl 1 then resize h + + let mem h key = + let hkey = H.hash h.seed key in + let rec mem_in_bucket = function + | Empty -> + false + | Cons(hk, c, rest) when hk = hkey -> + begin match H.equal c key with + | ETrue -> true + | EFalse | EDead -> mem_in_bucket rest + end + | Cons(hk, c, rest) -> mem_in_bucket rest in + mem_in_bucket h.data.(key_index h hkey) + + let iter f h = + let rec do_bucket = function + | Empty -> + () + | Cons(_, c, rest) -> + begin match H.get_key c, H.get_data c with + | None, _ | _, None -> () + | Some k, Some d -> f k d + end; do_bucket rest in + let d = h.data in + for i = 0 to Array.length d - 1 do + do_bucket d.(i) + done + + let fold f h init = + let rec do_bucket b accu = + match b with + Empty -> + accu + | Cons(_, c, rest) -> + let accu = begin match H.get_key c, H.get_data c with + | None, _ | _, None -> accu + | Some k, Some d -> f k d accu + end in + do_bucket rest accu in + let d = h.data in + let accu = ref init in + for i = 0 to Array.length d - 1 do + accu := do_bucket d.(i) !accu + done; + !accu + + let filter_map_inplace f h = + let rec do_bucket = function + | Empty -> + Empty + | Cons(hk, c, rest) -> + match H.get_key c, H.get_data c with + | None, _ | _, None -> + do_bucket rest + | Some k, Some d -> + match f k d with + | None -> + do_bucket rest + | Some new_d -> + H.set_key_data c k new_d; + Cons(hk, c, do_bucket rest) + in + let d = h.data in + for i = 0 to Array.length d - 1 do + d.(i) <- do_bucket d.(i) + done + + let length h = h.size + + let rec bucket_length accu = function + | Empty -> accu + | Cons(_, _, rest) -> bucket_length (accu + 1) rest + + let stats h = + let mbl = + Array.fold_left (fun m b -> max m (bucket_length 0 b)) 0 h.data in + let histo = Array.make (mbl + 1) 0 in + Array.iter + (fun b -> + let l = bucket_length 0 b in + histo.(l) <- histo.(l) + 1) + h.data; + { Hashtbl.num_bindings = h.size; + num_buckets = Array.length h.data; + max_bucket_length = mbl; + bucket_histogram = histo } + + let rec bucket_length_alive accu = function + | Empty -> accu + | Cons(_, c, rest) when H.check_key c -> + bucket_length_alive (accu + 1) rest + | Cons(_, _, rest) -> bucket_length_alive accu rest + + let stats_alive h = + let size = ref 0 in + let mbl = + Array.fold_left (fun m b -> max m (bucket_length_alive 0 b)) 0 h.data in + let histo = Array.make (mbl + 1) 0 in + Array.iter + (fun b -> + let l = bucket_length_alive 0 b in + size := !size + l; + histo.(l) <- histo.(l) + 1) + h.data; + { Hashtbl.num_bindings = !size; + num_buckets = Array.length h.data; + max_bucket_length = mbl; + bucket_histogram = histo } + + + end +end + +module ObjEph = Obj.Ephemeron + +let _obj_opt : Obj.t option -> 'a option = fun x -> + match x with + | None -> x + | Some v -> Some (Obj.obj v) + +(** The previous function is typed so this one is also correct *) +let obj_opt : Obj.t option -> 'a option = fun x -> Obj.magic x + + +module K1 = struct + type ('k,'d) t = ObjEph.t + + let create () : ('k,'d) t = ObjEph.create 1 + + let get_key (t:('k,'d) t) : 'k option = obj_opt (ObjEph.get_key t 0) + let get_key_copy (t:('k,'d) t) : 'k option = obj_opt (ObjEph.get_key_copy t 0) + let set_key (t:('k,'d) t) (k:'k) : unit = ObjEph.set_key t 0 (Obj.repr k) + let unset_key (t:('k,'d) t) : unit = ObjEph.unset_key t 0 + let check_key (t:('k,'d) t) : bool = ObjEph.check_key t 0 + + let blit_key (t1:('k,'d) t) (t2:('k,'d) t): unit = + ObjEph.blit_key t1 0 t2 0 1 + + let get_data (t:('k,'d) t) : 'd option = obj_opt (ObjEph.get_data t) + let get_data_copy (t:('k,'d) t) : 'd option = obj_opt (ObjEph.get_data_copy t) + let set_data (t:('k,'d) t) (d:'d) : unit = ObjEph.set_data t (Obj.repr d) + let unset_data (t:('k,'d) t) : unit = ObjEph.unset_data t + let check_data (t:('k,'d) t) : bool = ObjEph.check_data t + let blit_data (t1:(_,'d) t) (t2:(_,'d) t) : unit = ObjEph.blit_data t1 t2 + + module MakeSeeded (H:Hashtbl.SeededHashedType) = + GenHashTable.MakeSeeded(struct + type 'a container = (H.t,'a) t + type t = H.t + let create k d = + let c = create () in + set_data c d; + set_key c k; + c + let hash = H.hash + let equal c k = + (** {!get_key_copy} is not used because the equality of the user can be + the physical equality *) + match get_key c with + | None -> GenHashTable.EDead + | Some k' -> + if H.equal k k' then GenHashTable.ETrue else GenHashTable.EFalse + let get_data = get_data + let get_key = get_key + let set_key_data c k d = + unset_data c; + set_key c k; + set_data c d + let check_key = check_key + end) + + module Make(H: Hashtbl.HashedType): (S with type key = H.t) = + struct + include MakeSeeded(struct + type t = H.t + let equal = H.equal + let hash (seed: int) x = H.hash x + end) + let create sz = create ~random:false sz + end + +end + +module K2 = struct + type ('k1, 'k2, 'd) t = ObjEph.t + + let create () : ('k1,'k2,'d) t = ObjEph.create 2 + + let get_key1 (t:('k1,'k2,'d) t) : 'k1 option = obj_opt (ObjEph.get_key t 0) + let get_key1_copy (t:('k1,'k2,'d) t) : 'k1 option = + obj_opt (ObjEph.get_key_copy t 0) + let set_key1 (t:('k1,'k2,'d) t) (k:'k1) : unit = + ObjEph.set_key t 0 (Obj.repr k) + let unset_key1 (t:('k1,'k2,'d) t) : unit = ObjEph.unset_key t 0 + let check_key1 (t:('k1,'k2,'d) t) : bool = ObjEph.check_key t 0 + + let get_key2 (t:('k1,'k2,'d) t) : 'k2 option = obj_opt (ObjEph.get_key t 1) + let get_key2_copy (t:('k1,'k2,'d) t) : 'k2 option = + obj_opt (ObjEph.get_key_copy t 1) + let set_key2 (t:('k1,'k2,'d) t) (k:'k2) : unit = + ObjEph.set_key t 1 (Obj.repr k) + let unset_key2 (t:('k1,'k2,'d) t) : unit = ObjEph.unset_key t 1 + let check_key2 (t:('k1,'k2,'d) t) : bool = ObjEph.check_key t 1 + + + let blit_key1 (t1:('k1,_,_) t) (t2:('k1,_,_) t) : unit = + ObjEph.blit_key t1 0 t2 0 1 + let blit_key2 (t1:(_,'k2,_) t) (t2:(_,'k2,_) t) : unit = + ObjEph.blit_key t1 1 t2 1 1 + let blit_key12 (t1:('k1,'k2,_) t) (t2:('k1,'k2,_) t) : unit = + ObjEph.blit_key t1 0 t2 0 2 + + let get_data (t:('k1,'k2,'d) t) : 'd option = obj_opt (ObjEph.get_data t) + let get_data_copy (t:('k1,'k2,'d) t) : 'd option = + obj_opt (ObjEph.get_data_copy t) + let set_data (t:('k1,'k2,'d) t) (d:'d) : unit = + ObjEph.set_data t (Obj.repr d) + let unset_data (t:('k1,'k2,'d) t) : unit = ObjEph.unset_data t + let check_data (t:('k1,'k2,'d) t) : bool = ObjEph.check_data t + let blit_data (t1:(_,_,'d) t) (t2:(_,_,'d) t) : unit = ObjEph.blit_data t1 t2 + + module MakeSeeded + (H1:Hashtbl.SeededHashedType) + (H2:Hashtbl.SeededHashedType) = + GenHashTable.MakeSeeded(struct + type 'a container = (H1.t,H2.t,'a) t + type t = H1.t * H2.t + let create (k1,k2) d = + let c = create () in + set_data c d; + set_key1 c k1; set_key2 c k2; + c + let hash seed (k1,k2) = + H1.hash seed k1 + H2.hash seed k2 * 65599 + let equal c (k1,k2) = + match get_key1 c, get_key2 c with + | None, _ | _ , None -> GenHashTable.EDead + | Some k1', Some k2' -> + if H1.equal k1 k1' && H2.equal k2 k2' + then GenHashTable.ETrue else GenHashTable.EFalse + let get_data = get_data + let get_key c = + match get_key1 c, get_key2 c with + | None, _ | _ , None -> None + | Some k1', Some k2' -> Some (k1', k2') + let set_key_data c (k1,k2) d = + unset_data c; + set_key1 c k1; set_key2 c k2; + set_data c d + let check_key c = check_key1 c && check_key2 c + end) + + module Make(H1: Hashtbl.HashedType)(H2: Hashtbl.HashedType): + (S with type key = H1.t * H2.t) = + struct + include MakeSeeded + (struct + type t = H1.t + let equal = H1.equal + let hash (seed: int) x = H1.hash x + end) + (struct + type t = H2.t + let equal = H2.equal + let hash (seed: int) x = H2.hash x + end) + let create sz = create ~random:false sz + end + +end + +module Kn = struct + type ('k,'d) t = ObjEph.t + + let create n : ('k,'d) t = ObjEph.create n + let length (k:('k,'d) t) : int = ObjEph.length k + + let get_key (t:('k,'d) t) (n:int) : 'k option = obj_opt (ObjEph.get_key t n) + let get_key_copy (t:('k,'d) t) (n:int) : 'k option = + obj_opt (ObjEph.get_key_copy t n) + let set_key (t:('k,'d) t) (n:int) (k:'k) : unit = + ObjEph.set_key t n (Obj.repr k) + let unset_key (t:('k,'d) t) (n:int) : unit = ObjEph.unset_key t n + let check_key (t:('k,'d) t) (n:int) : bool = ObjEph.check_key t n + + let blit_key (t1:('k,'d) t) (o1:int) (t2:('k,'d) t) (o2:int) (l:int) : unit = + ObjEph.blit_key t1 o1 t2 o2 l + + let get_data (t:('k,'d) t) : 'd option = obj_opt (ObjEph.get_data t) + let get_data_copy (t:('k,'d) t) : 'd option = obj_opt (ObjEph.get_data_copy t) + let set_data (t:('k,'d) t) (d:'d) : unit = ObjEph.set_data t (Obj.repr d) + let unset_data (t:('k,'d) t) : unit = ObjEph.unset_data t + let check_data (t:('k,'d) t) : bool = ObjEph.check_data t + let blit_data (t1:(_,'d) t) (t2:(_,'d) t) : unit = ObjEph.blit_data t1 t2 + + module MakeSeeded (H:Hashtbl.SeededHashedType) = + GenHashTable.MakeSeeded(struct + type 'a container = (H.t,'a) t + type t = H.t array + let create k d = + let c = create (Array.length k) in + set_data c d; + for i=0 to Array.length k -1 do + set_key c i k.(i); + done; + c + let hash seed k = + let h = ref 0 in + for i=0 to Array.length k -1 do + h := H.hash seed k.(i) * 65599 + !h; + done; + !h + let equal c k = + let len = Array.length k in + let len' = length c in + if len != len' then GenHashTable.EFalse + else + let rec equal_array k c i = + if i < 0 then GenHashTable.ETrue + else + match get_key c i with + | None -> GenHashTable.EDead + | Some ki -> + if H.equal k.(i) ki + then equal_array k c (i-1) + else GenHashTable.EFalse + in + equal_array k c (len-1) + let get_data = get_data + let get_key c = + let len = length c in + if len = 0 then Some [||] + else + match get_key c 0 with + | None -> None + | Some k0 -> + let rec fill a i = + if i < 1 then Some a + else + match get_key c i with + | None -> None + | Some ki -> + a.(i) <- ki; + fill a (i-1) + in + let a = Array.make len k0 in + fill a (len-1) + let set_key_data c k d = + unset_data c; + for i=0 to Array.length k -1 do + set_key c i k.(i); + done; + set_data c d + let check_key c = + let rec check c i = + i < 0 || (check_key c i && check c (i-1)) in + check c (length c - 1) + end) + + module Make(H: Hashtbl.HashedType): (S with type key = H.t array) = + struct + include MakeSeeded(struct + type t = H.t + let equal = H.equal + let hash (seed: int) x = H.hash x + end) + let create sz = create ~random:false sz + end +end diff --git a/stdlib/ephemeron.mli b/stdlib/ephemeron.mli new file mode 100644 index 000000000..add6989d9 --- /dev/null +++ b/stdlib/ephemeron.mli @@ -0,0 +1,334 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Para, 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(** Ephemerons and weak hash table *) + +(** Ephemerons and weak hash table + + Ephemerons and weak hashtable are useful when one wants to cache + or memorize the computation of a function, as long as the + arguments and the function are used, without creating memory leaks + by continuously keeping old computation results that are not + useful anymore because one argument or the function is freed. An + implementation using {Hashtbl.t} is not suitable, because all + associations would keep in memory the arguments and the result. + + Ephemerons can also be used for "adding" a field to an arbitrary + boxed ocaml value: you can attach an information to a value + created by an external library without memory leaks. + + Ephemerons hold some keys and one or no data. They are all boxed + ocaml values. The keys of an ephemerons have the same behavior + than weak pointers according to the garbage collector. In fact + ocaml weak pointers are implemented as ephemerons without data. + + The keys and data of an ephemeron are said to be full if they + point to a value, empty if the value have never been set, have + been unset, or was erased by the GC. In the function that access + the keys or data these two states are represented by the [option] + type. + + The data is considered by the garbage collector alive if all the + full keys are alive and if the ephemeron is alive. When one of the + keys is not considered alive anymore by the GC, the data is + emptied from the ephemeron. The data could be alive for another + reason and in that case the GC will free it, but the ephemerons + will not hold the data anymore. + + The ephemerons complicate the notion of liveness of values, because + it is not anymore an equivalence with the reachability from root + value by usual pointers (not weak and not ephemerons). With ephemerons + the notion of liveness is constructed by the least fixpoint of: + A value is alive if: + - it is a root value + - it is reachable from alive value by usual pointers + - it is the data of an alive ephemeron with all its full keys alive + + Notes: + - All the types defined in this module cannot be marshaled + using {!Pervasives.output_value} nor the functions of the + {!Marshal} module. + + Ephemerons are defined in a language agnostic way in this paper: + B. Hayes, Ephemerons: a New Finalization Mechanism, OOPSLA'9 + +*) + +module type S = sig + (** Propose the same interface than usual hash table. However since + the bindings are weak, [mem h k] is true doesn't mean that a + just following [find h k] will not raise the exception + [Not_found] since the garbage collector can run between the two. + + Secondly during an iteration the table shouldn't be modified use + instead {!filter_map_inplace} for that purpose. + *) + + include Hashtbl.S + + val clean: 'a t -> unit + (** remove all dead bindings. Done automatically during automatic resizing. *) + val stats_alive: 'a t -> Hashtbl.statistics + (** same as {!Hashtbl.SeededS.stats} but only count the alive bindings *) +end +(** The output signature of the functor {!K1.Make} and {!K2.Make}. + These hash tables are weak in the keys. If all the keys of a binding are + alive the binding is kept, but if one of the keys of the binding + is dead then the binding is removed. +*) + +module type SeededS = sig + include Hashtbl.SeededS + val clean: 'a t -> unit + (** remove all dead bindings. Done automatically during automatic resizing. *) + val stats_alive: 'a t -> Hashtbl.statistics + (** same as {!Hashtbl.SeededS.stats} but only count the alive bindings *) +end +(** The output signature of the functor {!K1.MakeSeeded} and {!K2.MakeSeeded}. +*) + +module K1 : sig + type ('k,'d) t (** an ephemeron with one key *) + + val create: unit -> ('k,'d) t + (** [Ephemeron.K1.create ()] creates an ephemeron with one key. The + data and key are empty *) + + val get_key: ('k,'d) t -> 'k option + (** [Ephemeron.K1.get_key eph] returns [None] if the key of [eph] is + empty, [Some x] (where [x] is the key) if it is full. *) + + val get_key_copy: ('k,'d) t -> 'k option + (** [Ephemeron.K1.get_key_copy eph] returns [None] if the key of [eph] is + empty, [Some x] (where [x] is a (shallow) copy of the key) if + it is full. This function has the same GC friendliness as {!Weak.get_copy} + *) + + val set_key: ('k,'d) t -> 'k -> unit + (** [Ephemeron.K1.set_key eph el] sets the key of [eph] to be a + (full) key to [el] + *) + + val unset_key: ('k,'d) t -> unit + (** [Ephemeron.K1.unset_key eph el] sets the key of [eph] to be an + empty key. Since there is only one key, the ephemeron start + behaving like a references on the data. *) + + val check_key: ('k,'d) t -> bool + (** [Ephemeron.K1.check_key eph] returns [true] if the key of the [eph] + is full, [false] if it is empty. Note that even if + [Ephemeron.K1.check_key eph] returns [true], a subsequent + {!Ephemeron.K1.get_key}[eph] can return [None]. + *) + + + val blit_key : ('k,_) t -> ('k,_) t -> unit + (** [Ephemeron.K1.blit_key eph1 eph2] sets the key of [eph2] with + the key of [eph1]. Contrary to using [Ephemeron.K1.get_key] + followed by [Ephemeron.K1.set_key] or [Ephemeon.K1.unset_key] + this function does not prevent the incremental GC from erasing + the value in its current cycle. *) + + val get_data: ('k,'d) t -> 'd option + (** [Ephemeron.K1.get_data eph] returns [None] if the data of [eph] is + empty, [Some x] (where [x] is the data) if it is full. *) + + val get_data_copy: ('k,'d) t -> 'd option + (** [Ephemeron.K1.get_data_copy eph] returns [None] if the data of [eph] is + empty, [Some x] (where [x] is a (shallow) copy of the data) if + it is full. This function has the same GC friendliness as {!Weak.get_copy} + *) + + val set_data: ('k,'d) t -> 'd -> unit + (** [Ephemeron.K1.set_data eph el] sets the data of [eph] to be a + (full) data to [el] + *) + + val unset_data: ('k,'d) t -> unit + (** [Ephemeron.K1.unset_key eph el] sets the key of [eph] to be an + empty key. The ephemeron start behaving like a weak pointer. + *) + + val check_data: ('k,'d) t -> bool + (** [Ephemeron.K1.check_data eph] returns [true] if the data of the [eph] + is full, [false] if it is empty. Note that even if + [Ephemeron.K1.check_data eph] returns [true], a subsequent + {!Ephemeron.K1.get_data}[eph] can return [None]. + *) + + val blit_data : (_,'d) t -> (_,'d) t -> unit + (** [Ephemeron.K1.blit_data eph1 eph2] sets the data of [eph2] with + the data of [eph1]. Contrary to using [Ephemeron.K1.get_data] + followed by [Ephemeron.K1.set_data] or [Ephemeon.K1.unset_data] + this function does not prevent the incremental GC from erasing + the value in its current cycle. *) + + module Make (H:Hashtbl.HashedType) : S with type key = H.t + (** Functor building an implementation of a weak hash table *) + + module MakeSeeded (H:Hashtbl.SeededHashedType) : SeededS with type key = H.t + (** Functor building an implementation of a weak hash table. + The seed is similar to the one of {!Hashtbl.MakeSeeded}. *) + +end + +module K2 : sig + type ('k1,'k2,'d) t (** an ephemeron with two keys *) + + val create: unit -> ('k1,'k2,'d) t + (** Same as {!Ephemeron.K1.create} *) + + val get_key1: ('k1,'k2,'d) t -> 'k1 option + (** Same as {!Ephemeron.K1.get_key} *) + val get_key1_copy: ('k1,'k2,'d) t -> 'k1 option + (** Same as {!Ephemeron.K1.get_key_copy} *) + val set_key1: ('k1,'k2,'d) t -> 'k1 -> unit + (** Same as {!Ephemeron.K1.set_key} *) + val unset_key1: ('k1,'k2,'d) t -> unit + (** Same as {!Ephemeron.K1.unset_key} *) + val check_key1: ('k1,'k2,'d) t -> bool + (** Same as {!Ephemeron.K1.check_key} *) + + val get_key2: ('k1,'k2,'d) t -> 'k2 option + (** Same as {!Ephemeron.K1.get_key} *) + val get_key2_copy: ('k1,'k2,'d) t -> 'k2 option + (** Same as {!Ephemeron.K1.get_key_copy} *) + val set_key2: ('k1,'k2,'d) t -> 'k2 -> unit + (** Same as {!Ephemeron.K1.get_key} *) + val unset_key2: ('k1,'k2,'d) t -> unit + (** Same as {!Ephemeron.K1.unset_key} *) + val check_key2: ('k1,'k2,'d) t -> bool + (** Same as {!Ephemeron.K1.check_key} *) + + val blit_key1 : ('k1,_,_) t -> ('k1,_,_) t -> unit + (** Same as {!Ephemeron.K1.blit_key} *) + val blit_key2 : (_,'k2,_) t -> (_,'k2,_) t -> unit + (** Same as {!Ephemeron.K1.blit_key} *) + val blit_key12 : ('k1,'k2,_) t -> ('k1,'k2,_) t -> unit + (** Same as {!Ephemeron.K1.blit_key} *) + + val get_data: ('k1,'k2,'d) t -> 'd option + (** Same as {!Ephemeron.K1.get_data} *) + val get_data_copy: ('k1,'k2,'d) t -> 'd option + (** Same as {!Ephemeron.K1.get_data_copy} *) + val set_data: ('k1,'k2,'d) t -> 'd -> unit + (** Same as {!Ephemeron.K1.set_data} *) + val unset_data: ('k1,'k2,'d) t -> unit + (** Same as {!Ephemeron.K1.unset_data} *) + val check_data: ('k1,'k2,'d) t -> bool + (** Same as {!Ephemeron.K1.check_data} *) + val blit_data: ('k1,'k2,'d) t -> ('k1,'k2,'d) t -> unit + (** Same as {!Ephemeron.K1.blit_data} *) + + module Make + (H1:Hashtbl.HashedType) + (H2:Hashtbl.HashedType) : + S with type key = H1.t * H2.t + (** Functor building an implementation of a weak hash table *) + + module MakeSeeded + (H1:Hashtbl.SeededHashedType) + (H2:Hashtbl.SeededHashedType) : + SeededS with type key = H1.t * H2.t + (** Functor building an implementation of a weak hash table. + The seed is similar to the one of {!Hashtbl.MakeSeeded}. *) + +end + +module Kn : sig + type ('k,'d) t (** an ephemeron with an arbitrary number of keys + of the same types *) + + val create: int -> ('k,'d) t + (** Same as {!Ephemeron.K1.create} *) + + val get_key: ('k,'d) t -> int -> 'k option + (** Same as {!Ephemeron.K1.get_key} *) + val get_key_copy: ('k,'d) t -> int -> 'k option + (** Same as {!Ephemeron.K1.get_key_copy} *) + val set_key: ('k,'d) t -> int -> 'k -> unit + (** Same as {!Ephemeron.K1.set_key} *) + val unset_key: ('k,'d) t -> int -> unit + (** Same as {!Ephemeron.K1.unset_key} *) + val check_key: ('k,'d) t -> int -> bool + (** Same as {!Ephemeron.K1.check_key} *) + + val blit_key : ('k,_) t -> int -> ('k,_) t -> int -> int -> unit + (** Same as {!Ephemeron.K1.blit_key} *) + + val get_data: ('k,'d) t -> 'd option + (** Same as {!Ephemeron.K1.get_data} *) + val get_data_copy: ('k,'d) t -> 'd option + (** Same as {!Ephemeron.K1.get_data_copy} *) + val set_data: ('k,'d) t -> 'd -> unit + (** Same as {!Ephemeron.K1.set_data} *) + val unset_data: ('k,'d) t -> unit + (** Same as {!Ephemeron.K1.unset_data} *) + val check_data: ('k,'d) t -> bool + (** Same as {!Ephemeron.K1.check_data} *) + val blit_data: ('k,'d) t -> ('k,'d) t -> unit + (** Same as {!Ephemeron.K1.blit_data} *) + + module Make + (H:Hashtbl.HashedType) : + S with type key = H.t array + (** Functor building an implementation of a weak hash table *) + + module MakeSeeded + (H:Hashtbl.SeededHashedType) : + SeededS with type key = H.t array + (** Functor building an implementation of a weak hash table. + The seed is similar to the one of {!Hashtbl.MakeSeeded}. *) + +end + +module GenHashTable: sig + (** Define hash table on generic containers which have a notion of + "death" and aliveness. If a binding is dead the hash table can + automatically remove it. *) + + type equal = + | ETrue | EFalse + | EDead (** the container is dead *) + + module MakeSeeded(H: + sig + type t + (** keys *) + type 'a container + (** contains keys and the associated data *) + + val hash: int -> t -> int + (** same as {!Hashtbl.SeededHashedType} *) + val equal: 'a container -> t -> equal + (** equality predicate used to compare a key with the one in a + container. Can return [EDead] if the keys in the container are + dead *) + + val create: t -> 'a -> 'a container + (** [create key data] creates a container from + some initials keys and one data *) + val get_key: 'a container -> t option + (** [get_key cont] returns the keys if they are all alive *) + val get_data: 'a container -> 'a option + (** [get_data cont] return the data if it is alive *) + val set_key_data: 'a container -> t -> 'a -> unit + (** [set_key_data cont] modify the key and data *) + val check_key: 'a container -> bool + (** [check_key cont] checks if all the keys contained in the data + are alive *) + end) : SeededS with type key = H.t + (** Functor building an implementation of an hash table that use the container + for keeping the information given *) + +end diff --git a/stdlib/hashtbl.ml b/stdlib/hashtbl.ml index 28fd46335..55b43c191 100644 --- a/stdlib/hashtbl.ml +++ b/stdlib/hashtbl.ml @@ -47,6 +47,7 @@ let randomized_default = let randomized = ref randomized_default let randomize () = randomized := true +let is_randomized () = !randomized let prng = lazy (Random.State.make_self_init()) @@ -191,6 +192,20 @@ let iter f h = do_bucket d.(i) done +let filter_map_inplace f h = + let rec do_bucket = function + | Empty -> + Empty + | Cons(k, d, rest) -> + match f k d with + | None -> do_bucket rest + | Some new_d -> Cons(k, new_d, do_bucket rest) + in + let d = h.data in + for i = 0 to Array.length d - 1 do + d.(i) <- do_bucket d.(i) + done + let fold f h init = let rec do_bucket b accu = match b with @@ -261,6 +276,7 @@ module type S = val replace : 'a t -> key -> 'a -> unit val mem : 'a t -> key -> bool val iter: (key -> 'a -> unit) -> 'a t -> unit + val filter_map_inplace: (key -> 'a -> 'a option) -> 'a t -> unit val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val length: 'a t -> int val stats: 'a t -> statistics @@ -281,6 +297,7 @@ module type SeededS = val replace : 'a t -> key -> 'a -> unit val mem : 'a t -> key -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit + val filter_map_inplace: (key -> 'a -> 'a option) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val length : 'a t -> int val stats: 'a t -> statistics @@ -373,6 +390,7 @@ module MakeSeeded(H: SeededHashedType): (SeededS with type key = H.t) = mem_in_bucket h.data.(key_index h key) let iter = iter + let filter_map_inplace = filter_map_inplace let fold = fold let length = length let stats = stats diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli index 386f5a6cc..076efe414 100644 --- a/stdlib/hashtbl.mli +++ b/stdlib/hashtbl.mli @@ -120,7 +120,20 @@ val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit in which the bindings are enumerated is reproducible between successive runs of the program, and even between minor versions of OCaml. For randomized hash tables, the order of enumeration - is entirely random. *) + is entirely random. + + The behavior is not defined if the hash table is modified + by [f] during the iteration. +*) + +val filter_map_inplace: ('a -> 'b -> 'b option) -> ('a, 'b) t -> unit +(** [Hashtbl.filter_map_inplace f tbl] applies [f] to all bindings in + table [tbl] and update each binding depending on the result of + [f]. If [f] returns [None], the binding is discarded. If it + returns [Some new_val], the binding is update to associate the key + to [new_val]. + + Other comments for {!Hashtbl.iter} apply as well. *) val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c (** [Hashtbl.fold f tbl init] computes @@ -138,7 +151,11 @@ val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c in which the bindings are enumerated is reproducible between successive runs of the program, and even between minor versions of OCaml. For randomized hash tables, the order of enumeration - is entirely random. *) + is entirely random. + + The behavior is not defined if the hash table is modified + by [f] during the iteration. +*) val length : ('a, 'b) t -> int (** [Hashtbl.length tbl] returns the number of bindings in [tbl]. @@ -165,6 +182,11 @@ val randomize : unit -> unit @since 4.00.0 *) +val is_randomized : unit -> bool +(** return if the tables are currently created in randomized mode by default + + @since 4.02.0 *) + type statistics = { num_bindings: int; (** Number of bindings present in the table. @@ -253,6 +275,7 @@ module type S = val replace : 'a t -> key -> 'a -> unit val mem : 'a t -> key -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit + val filter_map_inplace: (key -> 'a -> 'a option) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val length : 'a t -> int val stats: 'a t -> statistics @@ -302,6 +325,7 @@ module type SeededS = val replace : 'a t -> key -> 'a -> unit val mem : 'a t -> key -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit + val filter_map_inplace: (key -> 'a -> 'a option) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val length : 'a t -> int val stats: 'a t -> statistics diff --git a/stdlib/moreLabels.mli b/stdlib/moreLabels.mli index d8ca64bfb..de28c3c7f 100644 --- a/stdlib/moreLabels.mli +++ b/stdlib/moreLabels.mli @@ -34,6 +34,8 @@ module Hashtbl : sig val remove : ('a, 'b) t -> 'a -> unit val replace : ('a, 'b) t -> key:'a -> data:'b -> unit val iter : f:(key:'a -> data:'b -> unit) -> ('a, 'b) t -> unit + val filter_map_inplace: + f:(key:'a -> data:'b -> 'b option) -> ('a, 'b) t -> unit val fold : f:(key:'a -> data:'b -> 'c -> 'c) -> ('a, 'b) t -> init:'c -> 'c @@ -58,6 +60,8 @@ module Hashtbl : sig val replace : 'a t -> key:key -> data:'a -> unit val mem : 'a t -> key -> bool val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit + val filter_map_inplace: + f:(key:key -> data:'a -> 'a option) -> 'a t -> unit val fold : f:(key:key -> data:'a -> 'b -> 'b) -> 'a t -> init:'b -> 'b @@ -79,6 +83,8 @@ module Hashtbl : sig val replace : 'a t -> key:key -> data:'a -> unit val mem : 'a t -> key -> bool val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit + val filter_map_inplace: + f:(key:key -> data:'a -> 'a option) -> 'a t -> unit val fold : f:(key:key -> data:'a -> 'b -> 'b) -> 'a t -> init:'b -> 'b diff --git a/stdlib/obj.ml b/stdlib/obj.ml index af37d4289..4777f584e 100644 --- a/stdlib/obj.ml +++ b/stdlib/obj.ml @@ -80,3 +80,30 @@ let extension_name (slot : extension_constructor) = let extension_id (slot : extension_constructor) = (obj (field (repr slot) 1) : int) + +module Ephemeron = struct + type obj_t = t + + type t (** ephemeron *) + + external create: int -> t = "caml_ephe_create" + + let length x = size(repr x) - 2 + + external get_key: t -> int -> obj_t option = "caml_ephe_get_key" + external get_key_copy: t -> int -> obj_t option = "caml_ephe_get_key_copy" + external set_key: t -> int -> obj_t -> unit = "caml_ephe_set_key" + external unset_key: t -> int -> unit = "caml_ephe_unset_key" + external check_key: t -> int -> bool = "caml_ephe_check_key" + external blit_key : t -> int -> t -> int -> int -> unit + = "caml_ephe_blit_key" + + external get_data: t -> obj_t option = "caml_ephe_get_data" + external get_data_copy: t -> obj_t option = "caml_ephe_get_data_copy" + external set_data: t -> obj_t -> unit = "caml_ephe_set_data" + external unset_data: t -> unit = "caml_ephe_unset_data" + external check_data: t -> bool = "caml_ephe_check_data" + external blit_data : t -> t -> unit = "caml_ephe_blit_data" + + +end diff --git a/stdlib/obj.mli b/stdlib/obj.mli index 462963416..23943f842 100644 --- a/stdlib/obj.mli +++ b/stdlib/obj.mli @@ -24,14 +24,26 @@ external magic : 'a -> 'b = "%identity" external is_block : t -> bool = "caml_obj_is_block" external is_int : t -> bool = "%obj_is_int" external tag : t -> int = "caml_obj_tag" -external set_tag : t -> int -> unit = "caml_obj_set_tag" external size : t -> int = "%obj_size" external field : t -> int -> t = "%obj_field" (** When using flambda: + [set_field] MUST NOT be called on immutable blocks. (Blocks allocated - in C stubs, or with [new_block] below, are always considered mutable.) *) + in C stubs, or with [new_block] below, are always considered mutable.) + + The same goes for [set_double_field] and [set_tag]. However, for + [set_tag], in the case of immutable blocks where the middle-end optimizers + never see code that discriminates on their tag (for example records), the + operation should be safe. Such uses are nonetheless discouraged. + + For experts only: + [set_field] et al can be made safe by first wrapping the block in + [Sys.opaque_identity], so any information about its contents will not + be propagated. +*) external set_field : t -> int -> t -> unit = "%obj_set_field" +external set_tag : t -> int -> unit = "caml_obj_set_tag" val double_field : t -> int -> float (* @since 3.11.2 *) val set_double_field : t -> int -> float -> unit (* @since 3.11.2 *) @@ -73,3 +85,45 @@ val marshal : t -> bytes [@@ocaml.deprecated "Use Marshal.to_bytes instead."] val unmarshal : bytes -> int -> t * int [@@ocaml.deprecated "Use Marshal.from_bytes and Marshal.total_size instead."] + +module Ephemeron: sig + (** Ephemeron with arbitrary arity and untyped *) + + type obj_t = t + (** alias for {!Obj.t} *) + + type t + (** an ephemeron cf {!Ephemeron} *) + + val create: int -> t + (** [create n] returns an ephemeron with [n] keys. + All the keys and the data are initially empty *) + val length: t -> int + (** return the number of keys *) + + val get_key: t -> int -> obj_t option + (** Same as {!Ephemeron.K1.get_key} *) + val get_key_copy: t -> int -> obj_t option + (** Same as {!Ephemeron.K1.get_key_copy} *) + val set_key: t -> int -> obj_t -> unit + (** Same as {!Ephemeron.K1.set_key} *) + val unset_key: t -> int -> unit + (** Same as {!Ephemeron.K1.unset_key} *) + val check_key: t -> int -> bool + (** Same as {!Ephemeron.K1.check_key} *) + val blit_key : t -> int -> t -> int -> int -> unit + (** Same as {!Ephemeron.K1.blit_key} *) + + val get_data: t -> obj_t option + (** Same as {!Ephemeron.K1.get_data} *) + val get_data_copy: t -> obj_t option + (** Same as {!Ephemeron.K1.get_data_copy} *) + val set_data: t -> obj_t -> unit + (** Same as {!Ephemeron.K1.set_data} *) + val unset_data: t -> unit + (** Same as {!Ephemeron.K1.unset_data} *) + val check_data: t -> bool + (** Same as {!Ephemeron.K1.check_data} *) + val blit_data : t -> t -> unit + (** Same as {!Ephemeron.K1.blit_data} *) +end diff --git a/stdlib/stdlib.mllib b/stdlib/stdlib.mllib index b41bc2d93..bdbd831d8 100644 --- a/stdlib/stdlib.mllib +++ b/stdlib/stdlib.mllib @@ -39,6 +39,7 @@ Oo CamlinternalMod Genlex Weak +Ephemeron Filename Complex ArrayLabels diff --git a/stdlib/weak.ml b/stdlib/weak.ml index 71385c9b7..79abf7fff 100644 --- a/stdlib/weak.ml +++ b/stdlib/weak.ml @@ -17,7 +17,7 @@ type 'a t;; external create : int -> 'a t = "caml_weak_create";; -let length x = Obj.size(Obj.repr x) - 1;; +let length x = Obj.size(Obj.repr x) - 2;; external set : 'a t -> int -> 'a option -> unit = "caml_weak_set";; external get : 'a t -> int -> 'a option = "caml_weak_get";; diff --git a/stdlib/weak.mli b/stdlib/weak.mli index a27dea5ce..d856dd8b0 100644 --- a/stdlib/weak.mli +++ b/stdlib/weak.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(** Arrays of weak pointers and hash tables of weak pointers. *) +(** Arrays of weak pointers and hash sets of weak pointers. *) (** {6 Low-level functions} *) @@ -86,13 +86,13 @@ val blit : 'a t -> int -> 'a t -> int -> int -> unit do not designate a valid subarray of [ar2].*) -(** {6 Weak hash tables} *) +(** {6 Weak hash sets} *) -(** A weak hash table is a hashed set of values. Each value may +(** A weak hash set is a hashed set of values. Each value may magically disappear from the set when it is not used by the rest of the program any more. This is normally used to share data structures without inducing memory leaks. - Weak hash tables are defined on values from a {!Hashtbl.HashedType} + Weak hash sets are defined on values from a {!Hashtbl.HashedType} module; the [equal] relation and [hash] function are taken from that module. We will say that [v] is an instance of [x] if [equal x v] is [true]. @@ -106,11 +106,11 @@ module type S = sig (** The type of the elements stored in the table. *) type t (** The type of tables that contain elements of type [data]. - Note that weak hash tables cannot be marshaled using + Note that weak hash sets cannot be marshaled using {!Pervasives.output_value} or the functions of the {!Marshal} module. *) val create : int -> t - (** [create n] creates a new empty weak hash table, of initial + (** [create n] creates a new empty weak hash set, of initial size [n]. The table will grow as needed. *) val clear : t -> unit (** Remove all elements from the table. *) @@ -154,4 +154,7 @@ end;; (** The output signature of the functor {!Weak.Make}. *) module Make (H : Hashtbl.HashedType) : S with type data = H.t;; -(** Functor building an implementation of the weak hash table structure. *) +(** Functor building an implementation of the weak hash set structure. + [H.equal] can't be the physical equality, since only shallow + copies of the elements in the set are given to it. + *) diff --git a/testsuite/Makefile b/testsuite/Makefile index 1df26bca5..5ef712211 100644 --- a/testsuite/Makefile +++ b/testsuite/Makefile @@ -21,42 +21,31 @@ include ../config/Makefile default: @echo "Available targets:" @echo " all launch all tests" + @echo " all-foo launch all tests beginning with foo" @echo " list FILE=f launch the tests listed in f (one per line)" @echo " one DIR=p launch the tests located in path p" @echo " promote DIR=p promote the reference files for the tests in p" @echo " lib build library modules" @echo " clean delete generated files" @echo " report print the report for the last execution" + @echo + @echo "all* and list can automatically re-run failed test directories if" + @echo "MAX_TESTSUITE_DIR_RETRIES permits (default value = $(MAX_TESTSUITE_DIR_RETRIES))" .PHONY: all all: lib @for dir in tests/*; do \ $(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \ done 2>&1 | tee _log + @$(MAKE) $(NO_PRINT) retries @$(MAKE) report -all-basic: lib - @for dir in tests/basic*; do \ - $(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \ - done 2>&1 | tee _log - @$(MAKE) report - -all-lib: lib - @for dir in tests/lib-*; do \ - $(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \ - done 2>&1 | tee _log - @$(MAKE) report - -all-typing: lib - @for dir in tests/typing-*; do \ - $(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \ - done 2>&1 | tee _log - @$(MAKE) report - -all-tool: lib - @for dir in tests/tool-*; do \ +.PHONY: all-% +all-%: lib + @for dir in tests/$**; do \ $(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \ done 2>&1 | tee _log + @$(MAKE) $(NO_PRINT) retries @$(MAKE) report .PHONY: list @@ -68,6 +57,7 @@ list: lib @while read LINE; do \ $(MAKE) $(NO_PRINT) exec-one DIR=$$LINE; \ done <$(FILE) 2>&1 | tee _log + @$(MAKE) $(NO_PRINT) retries @$(MAKE) report .PHONY: one @@ -96,6 +86,18 @@ exec-one: $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) || echo '=> unexpected error'; \ fi +.PHONY: clean-one +clean-one: + @if [ ! -f $(DIR)/Makefile ]; then \ + for dir in $(DIR)/*; do \ + if [ -d $$dir ]; then \ + $(MAKE) clean-one DIR=$$dir; \ + fi; \ + done; \ + else \ + cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) clean; \ + fi + .PHONY: promote promote: @if [ -z "$(DIR)" ]; then \ @@ -124,5 +126,20 @@ report: @if [ ! -f _log ]; then echo "No '_log' file."; exit 1; fi @awk -f makefiles/summarize.awk <_log +retry-list: + @while read LINE; do \ + if [ -n "$$LINE" ] ; then \ + echo re-ran $$LINE>>_log; \ + $(MAKE) $(NO_PRINT) clean-one DIR=$$LINE; \ + $(MAKE) $(NO_PRINT) exec-one DIR=$$LINE 2>&1 | tee -a _log ; \ + fi \ + done <_retries; + @$(MAKE) $(NO_PRINT) retries + +retries: + @awk -v retries=1 -v max_retries=$(MAX_TESTSUITE_DIR_RETRIES) -f makefiles/summarize.awk <_log >_retries + @test `cat _retries | wc -l` -eq 0 || $(MAKE) $(NO_PRINT) retry-list + @rm -f _retries + .PHONY: empty empty: diff --git a/testsuite/makefiles/Makefile.common b/testsuite/makefiles/Makefile.common index c26f5c02c..289605b34 100644 --- a/testsuite/makefiles/Makefile.common +++ b/testsuite/makefiles/Makefile.common @@ -20,7 +20,6 @@ OTOPDIR=$(TOPDIR) CTOPDIR=$(TOPDIR) CYGPATH=echo DIFF=diff -q -CANKILL=true SORT=sort SET_LD_PATH=CAML_LD_LIBRARY_PATH="$(LD_PATH)" @@ -32,8 +31,6 @@ SET_LD_PATH=CAML_LD_LIBRARY_PATH="$(LD_PATH)" # CYGPATH is the command that translates unix-style file names into # whichever syntax is appropriate for arguments of OCaml programs. # DIFF is a "diff -q" command that ignores trailing CRs under Windows. -# CANKILL is true if a script launched by Make can kill an OCaml process, -# and false for the mingw and MSVC ports. # SORT is the Unix "sort" command. Usually a simple command, but may be an # absolute name if the Windows "sort" command is in the PATH. # SET_LD_PATH is a command prefix that sets the path for dynamic libraries @@ -43,7 +40,17 @@ SET_LD_PATH=CAML_LD_LIBRARY_PATH="$(LD_PATH)" include $(TOPDIR)/config/Makefile -OCAMLRUN=$(TOPDIR)/boot/ocamlrun$(EXE) +ifneq ($(USE_RUNTIME),) +#Check USE_RUNTIME value +ifeq ($(findstring $(USE_RUNTIME),d i),) +$(error If set, USE_RUNTIME must be equal to "d" (debug runtime) or "i" (instrumented runtime)) +endif + +RUNTIME_VARIANT=-I $(OTOPDIR)/asmrun -I $(OTOPDIR)/byterun -runtime-variant $(USE_RUNTIME) +export OCAMLRUNPARAM?=v=0 +endif + +OCAMLRUN=$(TOPDIR)/byterun/ocamlrun$(USE_RUNTIME)$(EXE) OCFLAGS=-nostdlib -I $(OTOPDIR)/stdlib $(COMPFLAGS) OCOPTFLAGS= @@ -56,15 +63,16 @@ endif OCAML=$(OCAMLRUN) $(OTOPDIR)/ocaml $(OCFLAGS) \ -init $(OTOPDIR)/testsuite/lib/empty -OCAMLC=$(OCAMLRUN) $(OTOPDIR)/ocamlc $(CUSTOM) $(OCFLAGS) -OCAMLOPT=$(OCAMLRUN) $(OTOPDIR)/ocamlopt $(OCFLAGS) +FLEXLINK_PREFIX=$(if $(FLEXLINK),$(if $(wildcard $(TOPDIR)/flexdll/Makefile),OCAML_FLEXLINK="$(WINTOPDIR)/boot/ocamlrun $(WINTOPDIR)/flexdll/flexlink.exe" )) +OCAMLC=$(FLEXLINK_PREFIX)$(OCAMLRUN) $(OTOPDIR)/ocamlc $(CUSTOM) $(OCFLAGS) $(RUNTIME_VARIANT) +OCAMLOPT=$(FLEXLINK_PREFIX)$(OCAMLRUN) $(OTOPDIR)/ocamlopt $(OCFLAGS) $(RUNTIME_VARIANT) OCAMLDOC=$(OCAMLRUN) $(OTOPDIR)/ocamldoc/ocamldoc OCAMLLEX=$(OCAMLRUN) $(OTOPDIR)/lex/ocamllex -OCAMLMKLIB=$(OCAMLRUN) $(OTOPDIR)/tools/ocamlmklib \ - -ocamlc "$(OTOPDIR)/boot/ocamlrun$(EXE) \ - $(OTOPDIR)/ocamlc $(OCFLAGS)" \ - -ocamlopt "$(OTOPDIR)/boot/ocamlrun$(EXE) \ - $(OTOPDIR)/ocamlopt $(OCFLAGS)" +OCAMLMKLIB=$(FLEXLINK_PREFIX)$(OCAMLRUN) $(OTOPDIR)/tools/ocamlmklib \ + -ocamlc "$(OTOPDIR)/byterun/ocamlrun$(USE_RUNTIME)$(EXE) \ + $(OTOPDIR)/ocamlc $(OCFLAGS) $(RUNTIME_VARIANT)" \ + -ocamlopt "$(OTOPDIR)/byterun/ocamlrun$(USE_RUNTIME)$(EXE) \ + $(OTOPDIR)/ocamlopt $(OCFLAGS) $(RUNTIME_VARIANT)" OCAMLYACC=$(TOPDIR)/yacc/ocamlyacc$(EXE) OCAMLBUILD=$(TOPDIR)/_build/ocamlbuild/ocamlbuild.native DUMPOBJ=$(OCAMLRUN) $(OTOPDIR)/tools/dumpobj @@ -83,7 +91,7 @@ defaultpromote: done defaultclean: - @rm -f *.cmo *.cmi *.cmx *.cma *.cmxa *.cmxs *.$(O) *.$(SO) *.$(A) + @rm -f *.cmo *.cmi *.cmx *.cma *.cmxa *.cmxs *.$(O) *.$(SO) *.$(A) *.exe @for dsym in *.dSYM; do \ if [ -d $$dsym ]; then \ rm -fr $$dsym; \ @@ -91,7 +99,7 @@ defaultclean: done .SUFFIXES: -.SUFFIXES: .mli .ml .mly .mll .cmi .cmo .cmx .cmm .cmxa .s .S .o .so .c .f +.SUFFIXES: .mli .ml .mly .mll .cmi .cmo .cmx .cmm .cmxa .s .S .$(O) .so .c .f .mli.cmi: @$(OCAMLC) -c $(ADD_COMPFLAGS) $< @@ -122,6 +130,11 @@ defaultclean: @$(OCAMLRUN) ./codegen $*.cmm > $*.s @$(ASM) -o $*.o $*.s +.cmm.obj: + @$(OCAMLRUN) ./codegen $*.cmm | grep -v "_caml_\(young_ptr\|young_limit\|extra_params\|allocN\|raise_exn\|reraise_exn\)" > $*.s + @set -o pipefail ; \ + $(ASM) $*.obj $*.s | tail -n +2 + .S.o: @$(ASPP) $(ASPPFLAGS) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) -o $*.o $*.S diff --git a/testsuite/makefiles/Makefile.one b/testsuite/makefiles/Makefile.one index cebf7fcc2..4fba264c3 100644 --- a/testsuite/makefiles/Makefile.one +++ b/testsuite/makefiles/Makefile.one @@ -29,17 +29,18 @@ CUSTOM_FLAG=`if [ -n "$(C_FILES)" ]; then echo '-custom'; fi` ADD_CFLAGS+=$(CUSTOM_FLAG) MYRUNTIME=`if [ -z "$(C_FILES)$(CUSTOM)" ]; then echo '$(OCAMLRUN)'; fi` -CC=$(NATIVECC) $(NATIVECCCOMPOPTS) +C_INCLUDES+=-I $(CTOPDIR)/byterun .PHONY: default default: @$(MAKE) compile - @$(SET_LD_PATH) $(MAKE) run + @$(NATIVECODE_ONLY) && $(BYTECODE_ONLY) && echo " ... testing => skipped" || \ + $(SET_LD_PATH) $(MAKE) run .PHONY: compile compile: $(ML_FILES) @for file in $(C_FILES); do \ - $(NATIVECC) $(NATIVECCCOMPOPTS) -c -I$(CTOPDIR)/byterun $$file.c; \ + $(OCAMLC) -c $(C_INCLUDES) $$file.c; \ done; @if $(NATIVECODE_ONLY); then : ; else \ rm -f program.byte program.byte.exe; \ diff --git a/testsuite/makefiles/Makefile.several b/testsuite/makefiles/Makefile.several index 541046306..8ed868f48 100644 --- a/testsuite/makefiles/Makefile.several +++ b/testsuite/makefiles/Makefile.several @@ -27,25 +27,35 @@ ADD_OPTFLAGS+=$(FORTRAN_LIB) C_INCLUDES+=-I $(CTOPDIR)/byterun -I$(CTOPDIR)/otherlibs/bigarray +SKIP=false + .PHONY: check check: @if [ -n "$(FORTRAN_COMPILER)" -o -z "$(F_FILES)" ]; then \ $(SET_LD_PATH) $(MAKE) run-all; \ + else \ + $(MAKE) C_FILES= F_FILES= SKIP=true run-all; \ fi .PHONY: run-all run-all: @for file in $(C_FILES); do \ - $(CC) $(C_INCLUDES) -c $$file.c; \ + $(OCAMLC) -c $(C_INCLUDES) -c $$file.c; \ done; @for file in $(F_FILES); do \ $(FORTRAN_COMPILER) -c $$file.f; \ done; @for file in *.ml; do \ - if [ -f `basename $$file ml`precheck ]; then \ - CANKILL=$(CANKILL) sh `basename $$file ml`precheck || continue; \ - fi; \ printf " ... testing '$$file':"; \ + if $(SKIP) ; then \ + echo " => skipped"; continue; \ + fi; \ + if [ -f `basename $$file ml`precheck ]; then \ + if ! TOOLCHAIN=$(TOOLCHAIN) sh `basename $$file ml`precheck ; then \ + echo " => skipped"; \ + continue; \ + fi; \ + fi; \ $(MAKE) run-file DESC=ocamlc COMP='$(OCAMLC)' \ RUNTIME='$(MYRUNTIME)' \ COMPFLAGS='-w a $(ADD_COMPFLAGS) $(ADD_CFLAGS) $(O_FILES) \ diff --git a/testsuite/makefiles/summarize.awk b/testsuite/makefiles/summarize.awk index 75ab95255..4e3f046da 100644 --- a/testsuite/makefiles/summarize.awk +++ b/testsuite/makefiles/summarize.awk @@ -24,26 +24,34 @@ function clear() { function record_pass() { check(); - ++ passed; + RESULTS[key] = "p"; + delete SKIPPED[curdir]; clear(); } function record_skip() { check(); - ++ skipped; + RESULTS[key] = "s"; + if (curdir in SKIPPED) SKIPPED[curdir] = 1; clear(); } +# The output cares only if the test passes at least once so if a test passes, +# but then fails in a re-run triggered by a different test, ignore it. function record_fail() { check(); - ++ failed; - fail[failidx++] = sprintf ("%s/%s", curdir, curfile); + if (!(key in RESULTS) || RESULTS[key] == "s"){ + RESULTS[key] = "f"; + } + delete SKIPPED[curdir]; clear(); } function record_unexp() { - ++ unexped; - unexp[unexpidx++] = sprintf ("%s/%s", curdir, curfile); + if (!(key in RESULTS) || RESULTS[key] == "s"){ + RESULTS[key] = "e"; + } + delete SKIPPED[curdir]; clear(); } @@ -51,6 +59,10 @@ function record_unexp() { if (in_test) record_unexp(); match($0, /Running tests from '[^']*'/); curdir = substr($0, RSTART+20, RLENGTH - 21); + # Use SKIPPED[curdir] as a sentintel to detect no output + SKIPPED[curdir] = 0; + key = curdir; + DIRS[key] = key; curfile = ""; } @@ -63,11 +75,15 @@ function record_unexp() { if (in_test) record_unexp(); match($0, /... testing '[^']*'/); curfile = substr($0, RSTART+13, RLENGTH-14); + key = sprintf ("%s/%s", curdir, curfile); + DIRS[key] = curdir; in_test = 1; } -/^ ... testing with / { +/^ ... testing (with|[^'])/ { if (in_test) record_unexp(); + key = curdir; + DIRS[key] = curdir; in_test = 1; } @@ -87,31 +103,95 @@ function record_unexp() { record_unexp(); } -# Not displaying "skipped" for the moment, as most of the skipped tests -# print nothing at all and are not counted. +/^re-ran / { + if (in_test){ + printf("error at line %d: found re-ran inside a test\n", NR); + errored = 1; + }else{ + RERAN[substr($0, 8, length($0)-7)] += 1; + ++ reran; + } +} END { if (errored){ printf ("\n#### Some fatal error occurred during testing.\n\n"); exit (3); }else{ - printf("\n"); - printf("Summary:\n"); - printf(" %3d test(s) passed\n", passed); - printf(" %3d test(s) failed\n", failed); - printf(" %3d unexpected error(s)\n", unexped); - if (failed != 0){ - printf("\nList of failed tests:\n"); - for (i=0; i < failed; i++) printf(" %s\n", fail[i]); - } - if (unexped != 0){ - printf("\nList of unexpected errors:\n"); - for (i=0; i < unexped; i++) printf(" %s\n", unexp[i]); - } - printf("\n"); - if (failed || unexped){ - printf("#### Some tests failed. Exiting with error status.\n\n"); - exit 4; + if (!retries){ + for (key in SKIPPED){ + if (!SKIPPED[key]){ + ++ empty; + blanks[emptyidx++] = key; + delete SKIPPED[key]; + } + } + for (key in RESULTS){ + r = RESULTS[key]; + if (r == "p"){ + ++ passed; + }else if (r == "f"){ + ++ failed; + fail[failidx++] = key; + }else if (r == "e"){ + ++ unexped; + unexp[unexpidx++] = key; + }else if (r == "s"){ + ++ skipped; + curdir = DIRS[key]; + if (curdir in SKIPPED){ + if (SKIPPED[curdir]){ + SKIPPED[curdir] = 0; + skips[skipidx++] = curdir; + } + }else{ + skips[skipidx++] = key; + } + } + } + printf("\n"); + printf("Summary:\n"); + printf(" %3d test%s passed\n", passed, (passed == 1 ? "" : "s")); + printf(" %3d test%s skipped\n", skipped, (skipped == 1 ? "" : "s")); + printf(" %3d test%s failed\n", failed, (failed == 1 ? "" : "s")); + printf(" %3d unexpected error%s\n", unexped, (unexped == 1 ? "" : "s")); + printf(" %3d tests considered%s\n", length(RESULTS), (length(RESULTS) != passed + skipped + failed + unexped ? " (totals don't add up??)": "")); + if (reran != 0){ + printf(" %3d test dir re-run%s\n", reran, (reran == 1 ? "" : "s")); + } + if (failed != 0){ + printf("\nList of failed tests:\n"); + for (i=0; i < failed; i++) printf(" %s\n", fail[i]); + } + if (unexped != 0){ + printf("\nList of unexpected errors:\n"); + for (i=0; i < unexped; i++) printf(" %s\n", unexp[i]); + } + if (skipped != 0){ + printf("\nList of skipped tests:\n"); + for (i=0; i < skipidx; i++) printf(" %s\n", skips[i]); + } + if (empty != 0){ + printf("\nList of directories returning no results:\n"); + for (i=0; i < empty; i++) printf(" %s\n", blanks[i]); + } + printf("\n"); + if (failed || unexped){ + printf("#### Something failed. Exiting with error status.\n\n"); + exit 4; + } + }else{ + for (key in RESULTS){ + if (RESULTS[key] == "f" || RESULTS[key] == "e"){ + key = DIRS[key]; + if (!(key in RERUNS)){ + RERUNS[key] = 1; + if (RERAN[key] < max_retries){ + printf("%s\n", key); + } + } + } + } } } } diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile index ee2b91578..f5ff07341 100644 --- a/testsuite/tests/asmcomp/Makefile +++ b/testsuite/tests/asmcomp/Makefile @@ -12,9 +12,6 @@ BASEDIR=../.. -CC=$(NATIVECC) -CFLAGS=$(NATIVECCCOMPOPTS) -g - INCLUDES=\ -I $(OTOPDIR)/utils \ -I $(OTOPDIR)/typing \ @@ -30,7 +27,7 @@ OBJS=parsecmmaux.cmo parsecmm.cmo lexcmm.cmo ADD_COMPFLAGS=$(INCLUDES) -w -40 -g default: - @if $(BYTECODE_ONLY) || [ -z "$(ASPP)" ]; then : ; else \ + @if $(BYTECODE_ONLY) || $(SKIP) ; then $(MAKE) skips ; else \ $(MAKE) all; \ fi @@ -47,7 +44,8 @@ parsecmm.mli parsecmm.ml: parsecmm.mly lexcmm.ml: lexcmm.mll @$(OCAMLLEX) -q lexcmm.mll -MLCASES=optargs staticalloc bind_tuples +MLCASES=optargs staticalloc bind_tuples is_static +ARGS_is_static=is_in_static_data.c CASES=fib tak quicksort quicksort2 soli \ arith checkbound tagged-fib tagged-integr tagged-quicksort tagged-tak @@ -64,31 +62,54 @@ ARGS_tagged-integr=-DINT_FLOAT -DFUN=test main.c ARGS_tagged-quicksort=-DSORT -DFUN=quicksort main.c ARGS_tagged-tak=-DUNIT_INT -DFUN=takmain main.c -tests: $(CASES:=.o) +skips: + @for c in $(CASES) $(MLCASES); do \ + echo " ... testing '$$c': => skipped"; \ + done + +one_ml: + @$(OCAMLOPT) $(ARGS_$(NAME)) -o $(NAME).exe $(NAME).ml && \ + ./$(NAME).exe $(FLAMBDA) && echo " => passed" || echo " => failed" + +one: + @$(call CC,$(NAME).out $(ARGS_$(NAME)) $(NAME).$(O) $(ARCH).$(O)) \ + && echo " => passed" || echo " => failed" + +clean: defaultclean + @rm -f ./codegen *.out *.$(O) *.exe + @rm -f parsecmm.ml parsecmm.mli lexcmm.ml + @rm -f $(CASES:=.s) + +include $(BASEDIR)/makefiles/Makefile.common + +ifeq "$(CCOMPTYPE)-$(ARCH)" "msvc-amd64" +# these tests are not ported to MSVC64 yet +SKIP=true +else +SKIP=false +endif + +ifeq ($(CCOMPTYPE),msvc) +CC=set -o pipefail ; $(NATIVECC) $(CFLAGS) /Fe$(1) | tail -n +2 +CFLAGS=$(NATIVECCCOMPOPTS) +else +CC=$(NATIVECC) $(CFLAGS) -o $(1) +CFLAGS=$(NATIVECCCOMPOPTS) -g +endif +tests: $(CASES:=.$(O)) @for c in $(CASES); do \ printf " ... testing '$$c':"; \ - $(MAKE) one CC="$(CC) $(CFLAGS)" NAME=$$c; \ + $(MAKE) one NAME=$$c; \ done @for c in $(MLCASES); do \ printf " ... testing '$$c':"; \ $(MAKE) one_ml NAME=$$c; \ done -one_ml: - @$(OCAMLOPT) -o $(NAME).exe $(NAME).ml && \ - ./$(NAME).exe && echo " => passed" || echo " => failed" - -one: - @$(CC) -o $(NAME).out $(ARGS_$(NAME)) $(NAME).o $(ARCH).o \ - && echo " => passed" || echo " => failed" - -clean: defaultclean - @rm -f ./codegen *.out *.o *.obj *.exe - @rm -f parsecmm.ml parsecmm.mli lexcmm.ml - @rm -f $(CASES:=.s) - -include $(BASEDIR)/makefiles/Makefile.common - promote: -arch: $(ARCH).o +arch: $(ARCH).$(O) + +i386.obj: i386nt.asm + @set -o pipefail ; \ + $(ASM) $@ $^ | tail -n +2 diff --git a/testsuite/tests/asmcomp/is_in_static_data.c b/testsuite/tests/asmcomp/is_in_static_data.c new file mode 100644 index 000000000..ccf0582c0 --- /dev/null +++ b/testsuite/tests/asmcomp/is_in_static_data.c @@ -0,0 +1,5 @@ +#include "caml/address_class.h" + +value caml_is_in_static_data(value v) { + return(Val_bool(Is_in_static_data(v))); +} diff --git a/testsuite/tests/asmcomp/is_static.ml b/testsuite/tests/asmcomp/is_static.ml new file mode 100644 index 000000000..aac61fd87 --- /dev/null +++ b/testsuite/tests/asmcomp/is_static.ml @@ -0,0 +1,123 @@ +external is_in_static_data : 'a -> bool = "caml_is_in_static_data" +let flambda = bool_of_string Sys.argv.(1) +let is_in_static_data_flambda x = + not flambda || is_in_static_data x + +(* Basic constant blocks should be static *) +let block1 = (1,2) +let () = assert(is_in_static_data block1) + +(* as pattern shouldn't prevent it *) +let (a, b) as block2 = (1,2) +let () = assert(is_in_static_data block2) + +(* Also in functions *) +let f () = + let block = (1,2) in + assert(is_in_static_data block) + +let () = (f [@inlined never]) () + +(* Also after inlining *) +let g x = + let block = (1,x) in + assert(is_in_static_data_flambda block) + +let () = (g [@inlined always]) 2 + +(* Toplevel immutable blocks should be static *) +let block3 = (Sys.opaque_identity 1, Sys.opaque_identity 2) +let () = assert(is_in_static_data_flambda block3) + +(* Not being bound shouldn't prevent it *) +let () = + assert(is_in_static_data_flambda (Sys.opaque_identity 1, Sys.opaque_identity 2)) + +(* Only with rounds >= 2 currently ! +(* Also after inlining *) +let h x = + let block = (Sys.opaque_identity 1,x) in + assert(is_in_static_data block) + +let () = (h [@inlined always]) (Sys.opaque_identity 2) +*) + +(* Closed functions should be static *) +let closed_function x = x + 1 (* + is a primitive, it cannot be in the closure *) +let () = assert(is_in_static_data closed_function) + +(* And functions using closed functions *) +let almost_closed_function x = + (closed_function [@inlined never]) x +let () = assert(is_in_static_data almost_closed_function) + +(* Recursive constant values should be static *) +let rec a = 1 :: b +and b = 2 :: a +let () = + assert(is_in_static_data_flambda a); + assert(is_in_static_data_flambda b) + +(* Recursive constant functions should be static *) +let rec f1 a = g1 a +and g1 a = f1 a +let () = + assert(is_in_static_data f1); + assert(is_in_static_data g1) + +(* And a mix *) +type e = E : 'a -> e + +let rec f1 a = E (g1 a, l1) +and g1 a = E (f1 a, l2) +and l1 = E (f1, l2) +and l2 = E (g1, l1) + +let () = + assert(is_in_static_data_flambda f1); + assert(is_in_static_data_flambda g1); + assert(is_in_static_data_flambda l1); + assert(is_in_static_data_flambda l2) + +(* Also in functions *) +let i () = + let rec f1 a = E (g1 a, l1) + and g1 a = E (f1 a, l2) + and l1 = E (f1, l2) + and l2 = E (g1, l1) in + + assert(is_in_static_data_flambda f1); + assert(is_in_static_data_flambda g1); + assert(is_in_static_data_flambda l1); + assert(is_in_static_data_flambda l2) + +let () = (i [@inlined never]) () + +module type P = module type of Pervasives +(* Top-level modules should be static *) +let () = assert(is_in_static_data_flambda (module Pervasives:P)) + +(* Not constant let rec to test extraction to initialize_symbol *) +let r = ref 0 +let rec a = (incr r; !r) :: b +and b = (incr r; !r) :: a + +let next = + let r = ref 0 in + fun () -> incr r; !r + +let () = + assert(is_in_static_data_flambda next) + +(* Exceptions without arguments should be static *) +exception No_argument +let () = assert(is_in_static_data_flambda No_argument) + +(* And also with constant arguments *) +exception Some_argument of string +let () = assert(is_in_static_data_flambda (Some_argument "some string")) + +(* Even when exposed by inlining *) +let () = + let exn = try (failwith [@inlined always]) "some other string" with exn -> exn in + assert(is_in_static_data_flambda exn) diff --git a/testsuite/tests/ast-invariants/Makefile b/testsuite/tests/ast-invariants/Makefile new file mode 100644 index 000000000..3efb7483b --- /dev/null +++ b/testsuite/tests/ast-invariants/Makefile @@ -0,0 +1,26 @@ +######################################################################### +# # +# OCaml # +# # +# Jeremie Dimino, Jane Street Europe # +# # +# Copyright 2015 Jane Street Group LLC # +# # +# All rights reserved. This file is distributed 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=../.. +COMPFLAGS=-I $(OTOPDIR)/parsing -I $(OTOPDIR)/utils +LIBRARIES=../../../compilerlibs/ocamlcommon +MODULES= +MAIN_MODULE=test + +include $(BASEDIR)/makefiles/Makefile.one +include $(BASEDIR)/makefiles/Makefile.common + +# This test is a bit slow and there is little value in testing both +# versions so we run only the native code one: +NATIVECODE_ONLY=true diff --git a/testsuite/tests/ast-invariants/test.ml b/testsuite/tests/ast-invariants/test.ml new file mode 100644 index 000000000..f30733c0a --- /dev/null +++ b/testsuite/tests/ast-invariants/test.ml @@ -0,0 +1,67 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2015 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed 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 test checks all ml files in the ocaml repository that are accepted + by the parser satisfy [Ast_invariants]. + + We don't check the invariants on the output of the parser, so this test + is to ensure that we the parser doesn't accept more than [Ast_invariants]. +*) + +let root = "../../.." +let () = assert (Sys.file_exists (Filename.concat root "VERSION")) + +type _ kind = + | Implem : Parsetree.structure kind + | Interf : Parsetree.signature kind + +let parse : type a. a kind -> Lexing.lexbuf -> a = function + | Implem -> Parse.implementation + | Interf -> Parse.interface + +let invariants : type a. a kind -> a -> unit = function + | Implem -> Ast_invariants.structure + | Interf -> Ast_invariants.signature + +let check_file kind fn = + Warnings.parse_options false "-a"; + let ic = open_in fn in + Location.input_name := fn; + let lexbuf = Lexing.from_channel ic in + Location.init lexbuf fn; + match parse kind lexbuf with + | exception _ -> + (* A few files don't parse as they are meant for the toplevel; + ignore them *) + close_in ic + | ast -> + close_in ic; + try + invariants kind ast + with exn -> + Location.report_exception Format.std_formatter exn + +let rec walk dir = + Array.iter + (fun fn -> + let fn = Filename.concat dir fn in + if Sys.is_directory fn then + walk fn + else if Filename.check_suffix fn ".mli" then + check_file Interf fn + else if Filename.check_suffix fn ".ml" then + check_file Implem fn) + (Sys.readdir dir) + +let () = walk root diff --git a/testsuite/tests/ast-invariants/test.reference b/testsuite/tests/ast-invariants/test.reference new file mode 100644 index 000000000..e69de29bb diff --git a/testsuite/tests/backtrace/Makefile b/testsuite/tests/backtrace/Makefile index 6faa1a26a..028bf3821 100644 --- a/testsuite/tests/backtrace/Makefile +++ b/testsuite/tests/backtrace/Makefile @@ -21,7 +21,7 @@ OTHERFILESNOINLINING_NATIVE=backtraces_and_finalizers.ml default: @$(MAKE) byte - @if $(BYTECODE_ONLY); then : ; else $(MAKE) native; fi + @if $(BYTECODE_ONLY); then $(MAKE) skip ; else $(MAKE) native; fi .PHONY: byte byte: @@ -50,6 +50,17 @@ byte: && echo " => passed" || echo " => failed"; \ done +.PHONY: skip +skip: + @for file in $(ABCDFILES); do \ + for arg in a b c d ''; do \ + echo " ... testing '$$file' with ocamlopt and argument '$$arg': => skipped"; \ + done; \ + done + @for file in $(OTHERFILES) $(OTHERFILESNOINLINING) $(OTHERFILESNOINLINING_NATIVE); do \ + echo " ... testing '$$file' with ocamlopt: => skipped"; \ + done + .PHONY: native native: @for file in $(ABCDFILES); do \ @@ -70,7 +81,7 @@ native: $(OCAMLOPT) -g -o $(EXECNAME) $$file; \ printf " ... testing '$$file' with ocamlopt:"; \ F="`basename $$file .ml`"; \ - (OCAMLRUNPARAM=$OCAMLRUNPARAM,b=1 \ + (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \ ./$(EXECNAME) $$arg || true) \ >$$F.native.result 2>&1; \ $(DIFF) $$F.reference $$F.native.result >/dev/null \ diff --git a/testsuite/tests/basic/patmatch.ml b/testsuite/tests/basic/patmatch.ml index 0f759bc40..861a264ec 100644 --- a/testsuite/tests/basic/patmatch.ml +++ b/testsuite/tests/basic/patmatch.ml @@ -1610,3 +1610,48 @@ let f = function | _ -> false let () = printf "PR#6676=Ok\n%!" + +(* GPR#234, allow ``[]`` as a user defined constructor *) +module GPR234HList = struct + + type _ cell = + | Int : int -> int cell + | Pair : int * int -> (int * int) cell + | StrInt : string -> string cell + | List : int list -> int list cell + + type hlist = + | [] : hlist + | ( :: ) : 'a cell * hlist -> hlist + + type 'b foldf = { + f: 'a. 'a cell -> 'b -> 'b + } + + let fold_hlist : 'b foldf -> 'b -> hlist -> 'b = fun f init l -> + let rec loop : hlist -> 'b -> 'b = fun l acc -> + match l with + | [] -> acc + | hd :: tl -> loop tl (f.f hd acc) in + loop l init + + let to_int_fold : type a. a cell -> int -> int = fun cell acc -> + match cell with + | Int x -> x + acc + | Pair (x, y) -> x + y + acc + | StrInt str -> int_of_string str + acc + | List l -> acc + List.fold_left (+) 0 l + + let sum l = fold_hlist {f=to_int_fold} 0 l + + let l = List [1; 2; 3] (* still fine to use normal list here *) + + let ll = [Int 3; Pair (4, 5); StrInt "30"; l] + + let test () = Printf.printf "%d\n" (sum ll) + +end + +let () = GPR234HList.test () + +let () = printf "GPR#234=Ok\n%!" diff --git a/testsuite/tests/basic/patmatch.reference b/testsuite/tests/basic/patmatch.reference index aafc1b5c4..868bcf535 100644 --- a/testsuite/tests/basic/patmatch.reference +++ b/testsuite/tests/basic/patmatch.reference @@ -73,3 +73,5 @@ PR#6322=Ok PR#6646=Ok PR#6646=Ok PR#6676=Ok +48 +GPR#234=Ok diff --git a/testsuite/tests/callback/Makefile b/testsuite/tests/callback/Makefile index d89c53263..8eb43aa81 100644 --- a/testsuite/tests/callback/Makefile +++ b/testsuite/tests/callback/Makefile @@ -21,12 +21,19 @@ default: @case " $(OTHERLIBRARIES) " in \ *' unix '*) $(SET_LD_PATH) $(MAKE) run-byte; \ $(SET_LD_PATH) $(MAKE) run-opt;; \ + *) $(MAKE) skip;; \ esac .PHONY: common common: @$(CC) -c callbackprim.c +.PHONY: skip +skip: + @for c in bytecode native; do \ + echo " ... testing '$$c': => skipped" ; \ + done + .PHONY: run-byte run-byte: common @printf " ... testing 'bytecode':" diff --git a/testsuite/tests/embedded/Makefile b/testsuite/tests/embedded/Makefile index 088b02165..0e07f57a2 100644 --- a/testsuite/tests/embedded/Makefile +++ b/testsuite/tests/embedded/Makefile @@ -14,8 +14,8 @@ BASEDIR=../.. .PHONY: default default: - $(MAKE) compile - $(MAKE) run + @$(MAKE) compile + @$(MAKE) run .PHONY: compile compile: diff --git a/testsuite/tests/formats-transition/legacy_incompatible_flags.ml.reference b/testsuite/tests/formats-transition/legacy_incompatible_flags.ml.reference new file mode 100644 index 000000000..814a5d33c --- /dev/null +++ b/testsuite/tests/formats-transition/legacy_incompatible_flags.ml.reference @@ -0,0 +1,8 @@ + +# * toto +# toto +# toto +# toto +# "toto" +# toto +# * * * diff --git a/testsuite/tests/lib-bigarray/bigarrays.ml b/testsuite/tests/lib-bigarray/bigarrays.ml index 1f2b5ccbe..c37571ff3 100644 --- a/testsuite/tests/lib-bigarray/bigarrays.ml +++ b/testsuite/tests/lib-bigarray/bigarrays.ml @@ -411,6 +411,14 @@ let _ = test 1 (Array1.dim (from_list int [1;2;3;4;5])) 5; test 2 (Array1.dim (from_list_fortran int [1;2;3])) 3; + testing_function "size_in_bytes_one"; + test 1 (Array1.size_in_bytes (from_list int [1;2;3;4;5])) + (5 * (kind_size_in_bytes int)); + test 2 (Array1.size_in_bytes (from_list int [])) 0; + let int64list = (from_list int64 (List.map Int64.of_int [1;2;3;4;5])) in + test 3 (Array1.size_in_bytes int64list) (5 * (kind_size_in_bytes int64)); + test 4 (Array1.size_in_bytes (from_list int64 (List.map Int64.of_int []))) 0; + testing_function "kind & layout"; let a = from_list int [1;2;3] in test 1 (Array1.kind a) int; @@ -595,6 +603,10 @@ let _ = test 3 (Array2.dim1 b) 4; test 4 (Array2.dim2 b) 6; + testing_function "size_in_bytes_two"; + let a = Array2.create int c_layout 4 6 in + test 1 (Array2.size_in_bytes a) (24 * (kind_size_in_bytes int)); + testing_function "sub"; let a = make_array2 int c_layout 0 5 3 id in let b = Array2.sub_left a 2 2 in @@ -746,6 +758,10 @@ let _ = test 5 (Array3.dim2 b) 5; test 6 (Array3.dim3 b) 6; + testing_function "size_in_bytes_three"; + let a = Array3.create int c_layout 4 5 6 in + test 1 (Array3.size_in_bytes a) (120 * (kind_size_in_bytes int)); + testing_function "slice1"; let a = make_array3 int c_layout 0 3 3 3 id in test 1 (Array3.slice_left_1 a 0 0) (from_list int [0;1;2]); @@ -757,6 +773,39 @@ let _ = test 6 (Array3.slice_right_1 a 1 2) (from_list_fortran int [112;212;312]); test 7 (Array3.slice_right_1 a 3 1) (from_list_fortran int [131;231;331]); + testing_function "size_in_bytes_general"; + let a = Genarray.create int c_layout [|2;2;2;2;2|] in + test 1 (Genarray.size_in_bytes a) (32 * (kind_size_in_bytes int)); + +(* Kind size *) + testing_function "kind_size_in_bytes"; + let arr1 = Array1.create Float32 c_layout 1 in + test 1 (kind_size_in_bytes Float32) (Array1.size_in_bytes arr1); + let arr1 = Array1.create Float64 c_layout 1 in + test 2 (kind_size_in_bytes Float64) (Array1.size_in_bytes arr1); + let arr1 = Array1.create Int8_signed c_layout 1 in + test 3 (kind_size_in_bytes Int8_signed) (Array1.size_in_bytes arr1); + let arr1 = Array1.create Int8_unsigned c_layout 1 in + test 4 (kind_size_in_bytes Int8_unsigned) (Array1.size_in_bytes arr1); + let arr1 = Array1.create Int16_signed c_layout 1 in + test 5 (kind_size_in_bytes Int16_signed) (Array1.size_in_bytes arr1); + let arr1 = Array1.create Int16_unsigned c_layout 1 in + test 6 (kind_size_in_bytes Int16_unsigned) (Array1.size_in_bytes arr1); + let arr1 = Array1.create Int32 c_layout 1 in + test 7 (kind_size_in_bytes Int32) (Array1.size_in_bytes arr1); + let arr1 = Array1.create Int64 c_layout 1 in + test 8 (kind_size_in_bytes Int64) (Array1.size_in_bytes arr1); + let arr1 = Array1.create Int c_layout 1 in + test 9 (kind_size_in_bytes Int) (Array1.size_in_bytes arr1); + let arr1 = Array1.create Nativeint c_layout 1 in + test 10 (kind_size_in_bytes Nativeint) (Array1.size_in_bytes arr1); + let arr1 = Array1.create Complex32 c_layout 1 in + test 11 (kind_size_in_bytes Complex32) (Array1.size_in_bytes arr1); + let arr1 = Array1.create Complex64 c_layout 1 in + test 12 (kind_size_in_bytes Complex64) (Array1.size_in_bytes arr1); + let arr1 = Array1.create Char c_layout 1 in + test 13 (kind_size_in_bytes Char) (Array1.size_in_bytes arr1); + (* Reshaping *) print_newline(); testing_function "------ Reshaping --------"; diff --git a/testsuite/tests/lib-bigarray/bigarrays.reference b/testsuite/tests/lib-bigarray/bigarrays.reference index af05f4ca5..40ab1ec49 100644 --- a/testsuite/tests/lib-bigarray/bigarrays.reference +++ b/testsuite/tests/lib-bigarray/bigarrays.reference @@ -11,6 +11,8 @@ comparisons 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... 21... 22... 23... 24... 25... 26... 27... 28... 29... 30... 31... 32... 44... 45... 46... 47... 48... 49... dim 1... 2... +size_in_bytes_one + 1... 2... 3... 4... kind & layout 1... 2... 1... 2... sub @@ -28,6 +30,8 @@ set/get (unsafe, specialized) 1... 2... dim 1... 2... 3... 4... +size_in_bytes_two + 1... sub 1... 2... slice @@ -43,8 +47,14 @@ set/get (unsafe, specialized) 1... dim 1... 2... 3... 4... 5... 6... +size_in_bytes_three + 1... slice1 1... 2... 3... 4... 5... 6... 7... +size_in_bytes_general + 1... +kind_size_in_bytes + 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... ------ Reshaping -------- diff --git a/testsuite/tests/lib-dynlink-bytecode/Makefile b/testsuite/tests/lib-dynlink-bytecode/Makefile index 28d6f1402..467ce95eb 100644 --- a/testsuite/tests/lib-dynlink-bytecode/Makefile +++ b/testsuite/tests/lib-dynlink-bytecode/Makefile @@ -39,7 +39,7 @@ compile: @rm -f main static custom custom.exe @$(OCAMLC) -o main dynlink.cma registry.cmo main.cmo @$(OCAMLC) -o static -linkall registry.cmo plug1.cma plug2.cma \ - -use-runtime $(OTOPDIR)/boot/ocamlrun$(EXE) + -use-runtime $(OTOPDIR)/byterun/ocamlrun$(USE_RUNTIME)$(EXE) @$(OCAMLC) -o custom$(EXE) -custom -linkall registry.cmo plug2.cma \ plug1.cma -I . @@ -65,6 +65,6 @@ promote: defaultpromote .PHONY: clean clean: defaultclean - @rm -f main static custom custom.exe *.result marshal.data + @rm -f main static custom custom.exe *.result marshal.data dllplug*.dll include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/lib-dynlink-csharp/Makefile b/testsuite/tests/lib-dynlink-csharp/Makefile index c576a0990..da0246974 100644 --- a/testsuite/tests/lib-dynlink-csharp/Makefile +++ b/testsuite/tests/lib-dynlink-csharp/Makefile @@ -16,15 +16,8 @@ CSC=csc COMPFLAGS=-I $(OTOPDIR)/otherlibs/bigarray LD_PATH=$(TOPDIR)/otherlibs/bigarray -.PHONY: default default: - @if ! $(SUPPORTS_SHARED_LIBRARIES); then \ - echo 'skipped (shared libraries not available)'; \ - elif $(BYTECODE_ONLY); then \ - echo 'skipped (native compiler not available)' ; \ - else \ - $(SET_LD_PATH) $(MAKE) all; \ - fi + @$(SET_LD_PATH) $(MAKE) all .PHONY: all all: prepare bytecode bytecode-dll native native-dll @@ -37,7 +30,7 @@ prepare: .PHONY: bytecode bytecode: @printf " ... testing 'bytecode':" - @if [ ! `which $(CSC) >/dev/null 2>&1` ]; then \ + @if ! $(SUPPORTS_SHARED_LIBRARIES) || [ ! `which $(CSC) >/dev/null 2>&1` ]; then \ echo " => skipped"; \ else \ $(OCAMLC) -output-obj -o main.dll dynlink.cma main.ml entry.c; \ @@ -50,7 +43,7 @@ bytecode: .PHONY: bytecode-dll bytecode-dll: @printf " ... testing 'bytecode-dll':" - @if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \ + @if ! $(SUPPORTS_SHARED_LIBRARIES) || [ ! `which $(CSC) > /dev/null 2>&1` ]; then \ echo " => skipped"; \ else \ $(OCAMLC) -output-obj -o main_obj.$(O) dynlink.cma entry.c main.ml; \ @@ -65,7 +58,7 @@ bytecode-dll: .PHONY: native native: @printf " ... testing 'native':" - @if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \ + @if ! $(SUPPORTS_SHARED_LIBRARIES) || $(BYTECODE_ONLY) || [ ! `which $(CSC) > /dev/null 2>&1` ]; then \ echo " => skipped"; \ else \ $(OCAMLOPT) -output-obj -o main.dll dynlink.cmxa entry.c main.ml; \ @@ -78,7 +71,7 @@ native: .PHONY: native-dll native-dll: @printf " ... testing 'native-dll':" - @if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \ + @if ! $(SUPPORTS_SHARED_LIBRARIES) || $(BYTECODE_ONLY) || [ ! `which $(CSC) > /dev/null 2>&1` ]; then \ echo " => skipped"; \ else \ $(OCAMLOPT) -output-obj -o main_obj.$(O) dynlink.cmxa entry.c \ diff --git a/testsuite/tests/lib-dynlink-native/Makefile b/testsuite/tests/lib-dynlink-native/Makefile index 803ee5673..34306051c 100644 --- a/testsuite/tests/lib-dynlink-native/Makefile +++ b/testsuite/tests/lib-dynlink-native/Makefile @@ -20,10 +20,8 @@ LD_PATH = $(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/systhreads\ .PHONY: default default: - @if ! $(SUPPORTS_SHARED_LIBRARIES); then \ - echo 'skipped (shared libraries not available)'; \ - elif $(BYTECODE_ONLY); then \ - echo 'skipped (native compiler not available)' ; \ + @if ! $(SUPPORTS_SHARED_LIBRARIES) || $(BYTECODE_ONLY) ; then \ + echo " ... testing 'main' => skipped"; \ else \ $(SET_LD_PATH) $(MAKE) all; \ fi @@ -77,7 +75,7 @@ sub/api.cmx: sub/api.cmi sub/api.ml @cd sub; $(OCAMLOPT) -c api.ml plugin.cmi: plugin.mli - $(OCAMLOPT) -c -opaque plugin.mli + @$(OCAMLOPT) -c -opaque plugin.mli plugin.cmx: api.cmx plugin.cmi sub/plugin.cmx: api.cmx @@ -115,6 +113,8 @@ factorial.$(O): factorial.c promote: @cp result reference +.PRECIOUS: %.cmx + .PHONY: clean clean: defaultclean @rm -f result *.so *.o *.cm* main main_ext *.exe *.s *.asm *.obj diff --git a/testsuite/tests/lib-hashtbl/htbl.ml b/testsuite/tests/lib-hashtbl/htbl.ml index c023d4bcd..205644140 100644 --- a/testsuite/tests/lib-hashtbl/htbl.ml +++ b/testsuite/tests/lib-hashtbl/htbl.ml @@ -67,20 +67,43 @@ module Test(H: Hashtbl.S) (M: Map.S with type key = H.key) = struct end -module MS = Map.Make(struct type t = string - let compare (x:t) (y:t) = Pervasives.compare x y - end) -module MI = Map.Make(struct type t = int - let compare (x:t) (y:t) = Pervasives.compare x y - end) +module SS = struct + type t = string + let compare (x:t) (y:t) = Pervasives.compare x y + let equal (x:t) (y:t) = x=y + let hash = Hashtbl.hash +end +module SI = struct + type t = int + let compare (x:t) (y:t) = Pervasives.compare x y + let equal (x:t) (y:t) = x=y + let hash = Hashtbl.hash +end +module SSP = struct + type t = string*string + let compare (x:t) (y:t) = Pervasives.compare x y + let equal (x:t) (y:t) = x=y + let hash = Hashtbl.hash +end +module SSL = struct + type t = string list + let compare (x:t) (y:t) = Pervasives.compare x y + let equal (x:t) (y:t) = x=y + let hash = Hashtbl.hash +end +module SSA = struct + type t = string array + let compare (x:t) (y:t) = Pervasives.compare x y + let equal (x:t) (y:t) = x=y + let hash = Hashtbl.hash +end -module MSP = Map.Make(struct type t = string*string - let compare (x:t) (y:t) = Pervasives.compare x y - end) +module MS = Map.Make(SS) +module MI = Map.Make(SI) +module MSP = Map.Make(SSP) +module MSL = Map.Make(SSL) +module MSA = Map.Make(SSA) -module MSL = Map.Make(struct type t = string list - let compare (x:t) (y:t) = Pervasives.compare x y - end) (* Generic hash wrapped as a functorial hash *) @@ -102,6 +125,7 @@ module HofM (M: Map.S) : Hashtbl.S with type key = M.key = let fold = Hashtbl.fold let length = Hashtbl.length let stats = Hashtbl.stats + let filter_map_inplace = Hashtbl.filter_map_inplace end module HS1 = HofM(MS) @@ -111,13 +135,16 @@ module HSL = HofM(MSL) (* Specific functorial hashes *) -module HS2 = Hashtbl.Make(struct type t = string - let equal (x:t) (y:t) = x=y - let hash = Hashtbl.hash end) +module HS2 = Hashtbl.Make(SS) +module HI2 = Hashtbl.Make(SI) + +(* Specific weak functorial hashes *) +module WS = Ephemeron.K1.Make(SS) +module WSP1 = Ephemeron.K1.Make(SSP) +module WSP2 = Ephemeron.K2.Make(SS)(SS) +module WSL = Ephemeron.K1.Make(SSL) +module WSA = Ephemeron.Kn.Make(SS) -module HI2 = Hashtbl.Make(struct type t = int - let equal (x:t) (y:t) = x=y - let hash = Hashtbl.hash end) (* Instantiating the test *) module TS1 = Test(HS1)(MS) @@ -126,6 +153,11 @@ module TI1 = Test(HI1)(MI) module TI2 = Test(HI2)(MI) module TSP = Test(HSP)(MSP) module TSL = Test(HSL)(MSL) +module TWS = Test(WS)(MS) +module TWSP1 = Test(WSP1)(MSP) +module TWSP2 = Test(WSP2)(MSP) +module TWSL = Test(WSL)(MSL) +module TWSA = Test(WSA)(MSA) (* Data set: strings from a file, associated with their line number *) @@ -171,7 +203,7 @@ let pair_data data = (* Data set: lists *) let list_data data = - let d = Array.make (Array.length data / 10) ([], 0) in + let d = Array.make (Array.length data / 10) ([], "0") in let j = ref 0 in let rec mklist n = if n <= 0 || !j >= Array.length data then [] else begin @@ -181,7 +213,7 @@ let list_data data = hd :: tl end in for i = 0 to Array.length d - 1 do - d.(i) <- (mklist (Random.int 16), i) + d.(i) <- (mklist (Random.int 16), string_of_int i) done; d @@ -201,4 +233,17 @@ let _ = printf "-- Pairs of strings\n%!"; TSP.test (pair_data d); printf "-- Lists of strings\n%!"; - TSL.test (list_data d) + TSL.test (list_data d); + (* weak *) + let d = + try file_data "../../LICENSE" with Sys_error _ -> string_data in + printf "-- Weak K1 -- Strings, functorial interface\n%!"; + TWS.test d; + printf "-- Weak K1 -- Pairs of strings\n%!"; + TWSP1.test (pair_data d); + printf "-- Weak K2 -- Pairs of strings\n%!"; + TWSP2.test (pair_data d); + printf "-- Weak K1 -- Lists of strings\n%!"; + TWSL.test (list_data d); + printf "-- Weak Kn -- Arrays of strings\n%!"; + TWSA.test (Array.map (fun (l,i) -> (Array.of_list l,i)) (list_data d)) diff --git a/testsuite/tests/lib-hashtbl/htbl.reference b/testsuite/tests/lib-hashtbl/htbl.reference index 08ca22f07..9f42ee4bc 100644 --- a/testsuite/tests/lib-hashtbl/htbl.reference +++ b/testsuite/tests/lib-hashtbl/htbl.reference @@ -22,3 +22,23 @@ Removal: passed Insertion: passed Insertion: passed Removal: passed +-- Weak K1 -- Strings, functorial interface +Insertion: passed +Insertion: passed +Removal: passed +-- Weak K1 -- Pairs of strings +Insertion: passed +Insertion: passed +Removal: passed +-- Weak K2 -- Pairs of strings +Insertion: passed +Insertion: passed +Removal: passed +-- Weak K1 -- Lists of strings +Insertion: passed +Insertion: passed +Removal: passed +-- Weak Kn -- Arrays of strings +Insertion: passed +Insertion: passed +Removal: passed diff --git a/testsuite/tests/lib-str/t01.ml b/testsuite/tests/lib-str/t01.ml index ba171eb7a..3255ca8be 100644 --- a/testsuite/tests/lib-str/t01.ml +++ b/testsuite/tests/lib-str/t01.ml @@ -842,69 +842,69 @@ let automated_test() = in let _XML_SPE = _TextSE ^ "\\|" ^ _MarkupSPE in let input = "\ - - - - -]> - - - - - 65 - 20 - 300 - 2400 - 300 - 25 - 50 - - - Avocado Dip - Sunnydale - 29 - - 11 - 3 - 5 - 210 - 2 - 0 - 1 - - 0 - 0 - - - 0 - 0 - - - +\n\ +\n\ +\n\ +\ \n\ +]>\n\ +\n\ + \n\ +\n\ +\n\ +\t65\n\ +\t20\n\ +\t300\n\ +\t2400\n\ +\t300\n\ +\t25\n\ +\t50\n\ +\n\ +\n\ +\tAvocado Dip\n\ +\tSunnydale\n\ +\t29\n\ +\t\n\ +\t11\n\ +\t3\n\ +\t5\n\ +\t210\n\ +\t2\n\ +\t0\n\ +\t1\n\ +\t\n\ +\t\t0\n\ +\t\t0\n\ +\t\n\ +\t\n\ +\t\t0\n\ +\t\t0\n\ +\t\n\ +\n\ +\n\ " in let result = [ ""; diff --git a/testsuite/tests/lib-threads/Makefile b/testsuite/tests/lib-threads/Makefile index fc098713f..a55ee0ebf 100644 --- a/testsuite/tests/lib-threads/Makefile +++ b/testsuite/tests/lib-threads/Makefile @@ -16,5 +16,15 @@ ADD_COMPFLAGS=-thread -I $(OTOPDIR)/otherlibs/systhreads \ -I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix LD_PATH=$(TOPDIR)/otherlibs/systhreads:$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix +default: + @$(if $(filter msvc mingw,$(TOOLCHAIN)),$(MAKE) sigint.exe,true) + @$(SET_LD_PATH) $(MAKE) run-all + include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common + +sigint.exe: sigint.$(O) + @$(CC) $(if $(filter msvc,$(CCOMPTYPE)),/Fe$@,-o $@) $^ + +%.obj: %.c + @$(CC) -c $*.c > /dev/null diff --git a/testsuite/tests/lib-threads/sigint.c b/testsuite/tests/lib-threads/sigint.c new file mode 100644 index 000000000..89536fd32 --- /dev/null +++ b/testsuite/tests/lib-threads/sigint.c @@ -0,0 +1,37 @@ +#include +#include + +int main(int argc, char** argv) +{ + DWORD pid; + HANDLE hProcess; + + if (argc != 2) { + printf("Usage: %s pid\n", argv[0]); + return 1; + } + + pid = atoi(argv[1]); + hProcess = OpenProcess(SYNCHRONIZE, FALSE, pid); + + if (!hProcess) { + printf("Process %d not found!\n", pid); + return 1; + } + + FreeConsole(); + + if (!AttachConsole(pid)) { + printf("Failed to attach to console of Process %d\n", pid); + CloseHandle(hProcess); + return 1; + } + + SetConsoleCtrlHandler(NULL, TRUE); + GenerateConsoleCtrlEvent(0, 0); + WaitForSingleObject(hProcess, INFINITE); + CloseHandle(hProcess); + FreeConsole(); + + return 0; +} diff --git a/testsuite/tests/lib-threads/signal.precheck b/testsuite/tests/lib-threads/signal.precheck index aa357092a..d04af9a43 100644 --- a/testsuite/tests/lib-threads/signal.precheck +++ b/testsuite/tests/lib-threads/signal.precheck @@ -1,13 +1 @@ -######################################################################### -# # -# OCaml # -# # -# Damien Doligez, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2013 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -$CANKILL +test "$TOOLCHAIN" != "msvc" -a "$TOOLCHAIN" != "mingw" diff --git a/testsuite/tests/lib-threads/signal.runner b/testsuite/tests/lib-threads/signal.runner index eec95bcce..3be86d1fe 100644 --- a/testsuite/tests/lib-threads/signal.runner +++ b/testsuite/tests/lib-threads/signal.runner @@ -13,4 +13,4 @@ $RUNTIME ./program >signal.result & pid=$! sleep 2 -kill -INT $pid +test -e ./sigint.exe && ./sigint $pid || kill -INT $pid diff --git a/testsuite/tests/lib-threads/signal2.precheck b/testsuite/tests/lib-threads/signal2.precheck index aa357092a..b4532ac0a 100644 --- a/testsuite/tests/lib-threads/signal2.precheck +++ b/testsuite/tests/lib-threads/signal2.precheck @@ -10,4 +10,4 @@ # # ######################################################################### -$CANKILL +test "$TOOLCHAIN" != "msvc" -a "$TOOLCHAIN" != "mingw" diff --git a/testsuite/tests/lib-threads/sockets.precheck b/testsuite/tests/lib-threads/sockets.precheck deleted file mode 100644 index 6d41158ef..000000000 --- a/testsuite/tests/lib-threads/sockets.precheck +++ /dev/null @@ -1,23 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Damien Doligez, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2013 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - - -########################################## -########################################## -#### TEMPORARY #### -########################################## -########################################## - -# disable this test on Windows non-cygwin ports until we decide -# how to fix PR#5325 and PR#5578 - -$CANKILL diff --git a/testsuite/tests/misc/ephetest.ml b/testsuite/tests/misc/ephetest.ml new file mode 100644 index 000000000..3061d83f0 --- /dev/null +++ b/testsuite/tests/misc/ephetest.ml @@ -0,0 +1,172 @@ +(*************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2008 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(*************************************************************************) + +let debug = false + +open Printf +open Ephemeron + +let is_true test s b = printf "%s %s: %s\n" test s (if b then "OK" else "FAIL") +let is_false test s b = is_true test s (not b) + +let is_data_value test eph (v:int) = + match K1.get_data_copy eph with + | Some x -> + if !x = v + then printf "%s data set: OK\n" test + else printf "%s data set: FAIL(bad value %i)\n" test (!x) + | None -> printf "%s data set: FAIL\n" test + +let is_key_value test eph (v:int) = + match K1.get_key_copy eph with + | Some x -> + if !x = v + then printf "%s key set: OK\n" test + else printf "%s key set: FAIL(bad value %i)\n" test (!x) + | None -> printf "%s key unset: FAIL\n" test + +let is_key_unset test eph = + is_false test "key unset" (K1.check_key eph) + +let is_data_unset test eph = + is_false test "data unset" (K1.check_data eph) + +let ra = ref (ref 1) +let rb = ref (ref (ref 2)) + +(** test: key alive data dangling *) +let () = + let test = "test1" in + Gc.minor (); + Gc.full_major (); + let eph : (int ref, int ref) K1.t = K1.create () in + K1.set_key eph (!ra); + K1.set_data eph (ref 42); + is_key_value test eph 1; + is_data_value test eph 42; + Gc.minor (); + is_key_value test eph 1; + is_data_value test eph 42; + Gc.full_major (); + is_key_value test eph 1; + is_data_value test eph 42; + ra := ref 12; + Gc.full_major (); + is_key_unset test eph; + is_data_unset test eph + +(** test: key dangling data dangling *) +let () = + let test = "test2" in + Gc.minor (); + Gc.full_major (); + let eph : (int ref, int ref) K1.t = K1.create () in + K1.set_key eph (ref 125); + K1.set_data eph (ref 42); + is_key_value test eph 125; + is_data_value test eph 42; + ra := ref 13; + Gc.minor (); + is_key_unset test eph; + is_data_unset test eph + + +(** test: key dangling data alive *) +let () = + let test = "test3" in + Gc.minor (); + Gc.full_major (); + let eph : (int ref, int ref) K1.t = K1.create () in + K1.set_key eph (ref 125); + K1.set_data eph (!ra); + is_key_value test eph 125; + is_data_value test eph 13; + ra := ref 14; + Gc.minor (); + is_key_unset test eph; + is_data_unset test eph + +(** test: key alive but one away, data dangling *) +let () = + let test = "test4" in + Gc.minor (); + Gc.full_major (); + let eph : (int ref, int ref) K1.t = K1.create () in + rb := ref (ref 3); + K1.set_key eph (!(!rb)); + K1.set_data eph (ref 43); + is_key_value test eph 3; + is_data_value test eph 43; + Gc.minor (); + Gc.minor (); + is_key_value test eph 3; + is_data_value test eph 43 + +(** test: key dangling but one away, data dangling *) +let () = + let test = "test5" in + Gc.minor (); + Gc.full_major (); + let eph : (int ref, int ref) K1.t = K1.create () in + rb := ref (ref 3); + K1.set_key eph (!(!rb)); + K1.set_data eph (ref 43); + is_key_value test eph 3; + is_data_value test eph 43; + !rb := ref 4; + Gc.minor (); + Gc.minor (); + is_key_unset test eph; + is_data_unset test eph + +(** test: key accessible from data but all dangling *) +let () = + let test = "test6" in + Gc.minor (); + Gc.full_major (); + let eph : (int ref, int ref ref) K1.t = K1.create () in + rb := ref (ref 3); + K1.set_key eph (!(!rb)); + K1.set_data eph (ref (!(!rb))); + Gc.minor (); + is_key_value test eph 3; + !rb := ref 4; + Gc.full_major (); + is_key_unset test eph; + is_data_unset test eph + +(** test: ephemeron accessible from data but they are dangling *) +type t = + | No + | Ephe of (int ref, t) K1.t + +let rc = ref No + +let () = + let test = "test7" in + Gc.minor (); + Gc.full_major (); + ra := ref 42; + let weak : t Weak.t = Weak.create 1 in + let eph : (int ref, t) K1.t ref = ref (K1.create ()) in + rc := Ephe !eph; + Weak.set weak 0 (Some !rc); + K1.set_key !eph !ra; + K1.set_data !eph !rc; + Gc.minor (); + is_true test "before" (Weak.check weak 0); + eph := K1.create (); + rc := No; + Gc.full_major (); + Gc.full_major (); + Gc.full_major (); + is_false test "after" (Weak.check weak 0) diff --git a/testsuite/tests/misc/ephetest.reference b/testsuite/tests/misc/ephetest.reference new file mode 100644 index 000000000..2699fdf7f --- /dev/null +++ b/testsuite/tests/misc/ephetest.reference @@ -0,0 +1,29 @@ +test1 key set: OK +test1 data set: OK +test1 key set: OK +test1 data set: OK +test1 key set: OK +test1 data set: OK +test1 key unset: OK +test1 data unset: OK +test2 key set: OK +test2 data set: OK +test2 key unset: OK +test2 data unset: OK +test3 key set: OK +test3 data set: OK +test3 key unset: OK +test3 data unset: OK +test4 key set: OK +test4 data set: OK +test4 key set: OK +test4 data set: OK +test5 key set: OK +test5 data set: OK +test5 key unset: OK +test5 data unset: OK +test6 key set: OK +test6 key unset: OK +test6 data unset: OK +test7 before: OK +test7 after: OK diff --git a/testsuite/tests/misc/ephetest2.ml b/testsuite/tests/misc/ephetest2.ml new file mode 100644 index 000000000..d1da44865 --- /dev/null +++ b/testsuite/tests/misc/ephetest2.ml @@ -0,0 +1,161 @@ +(*************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2008 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(*************************************************************************) + +(*** + This test evaluate boolean formula composed by conjunction and + disjunction using ephemeron: + - true == alive, false == garbage collected + - and == an n-ephemeron, or == many 1-ephemeron + +*) + +let nb_test = 4 +let max_level = 10 + (** probability that a branch is not linked to a previous one *) +let proba_no_shared = 0.2 +let arity_max = 4 + +let proba_new = proba_no_shared ** (1./.(float_of_int max_level)) + +open Format +open Ephemeron + +let is_true test s b = printf "%s %s: %s\n" test s (if b then "OK" else "FAIL") +let is_false test s b = is_true test s (not b) + +type varephe = int ref +type ephe = (varephe,varephe) Kn.t + +type formula = + | Constant of bool + | And of var array + | Or of var array + +and var = { + form: formula; + value: bool; + ephe: varephe Weak.t; +} + +let print_short_bool fmt b = + if b + then pp_print_string fmt "t" + else pp_print_string fmt "f" + +let rec pp_form fmt = function + | Constant b -> + fprintf fmt "%b" b + | And a -> + fprintf fmt "And[@[%a@]]" (fun fmt -> Array.iter (pp_var fmt)) a + | Or a -> + fprintf fmt "Or[@[%a@]]" (fun fmt -> Array.iter (pp_var fmt)) a + +and pp_var fmt v = + fprintf fmt "%a%a:%a;@ " + print_short_bool v.value + print_short_bool (Weak.check v.ephe 0) + pp_form v.form + +type env = { + (** resizeable array for cheap *) + vars : (int,var) Hashtbl.t; + (** the ephemerons must be alive *) + ephes : ephe Stack.t; + (** keep alive the true constant *) + varephe_true : varephe Stack.t; +(** keep temporarily alive the false constant *) + varephe_false : varephe Stack.t; +} + +let new_env () = { + vars = Hashtbl.create 100; + ephes = Stack.create (); + varephe_true = Stack.create (); + varephe_false = Stack.create (); +} + +let evaluate = function + | Constant b -> b + | And a -> Array.fold_left (fun acc e -> acc && e.value) true a + | Or a -> Array.fold_left (fun acc e -> acc || e.value) false a + +let get_ephe v = + match Weak.get v.ephe 0 with + | None -> + invalid_arg "Error: weak dead but nothing have been released" + | Some r -> r + +(** create a variable and its definition in the boolean world and + ephemerons world *) +let rec create env rem_level (** remaining level *) = + let varephe = ref 1 in + let form = + if rem_level = 0 then (** Constant *) + if Random.bool () + then (Stack.push varephe env.varephe_true ; Constant true ) + else (Stack.push varephe env.varephe_false; Constant false) + else + let size = (Random.int (arity_max - 1)) + 2 in + let new_link _ = + if (Hashtbl.length env.vars) = 0 || Random.float 1. < proba_new + then create env (rem_level -1) + else Hashtbl.find env.vars (Random.int (Hashtbl.length env.vars)) + in + let args = Array.init size new_link in + if Random.bool () + then begin (** Or *) + Array.iter (fun v -> + let r = get_ephe v in + let e = Kn.create 1 in + Kn.set_key e 0 r; + Kn.set_data e varephe; + Stack.push e env.ephes + ) args; Or args + end + else begin (** And *) + let e = Kn.create (Array.length args) in + for i=0 to Array.length args - 1 do + Kn.set_key e i (get_ephe args.(i)); + done; + Kn.set_data e varephe; + Stack.push e env.ephes; + And args + end + in + let create_weak e = + let w = Weak.create 1 in + Weak.set w 0 (Some e); + w + in + let v = {form; value = evaluate form; + ephe = create_weak varephe; + } in + Hashtbl.add env.vars (Hashtbl.length env.vars) v; + v + + +let check_var v = v.value = Weak.check v.ephe 0 + +let run test init = + Random.init init; + let env = new_env () in + let _top = create env max_level in + (** release false ref *) + Stack.clear env.varephe_false; + Gc.full_major (); + let res = Hashtbl.fold (fun _ v acc -> acc && check_var v) env.vars true in + is_true test "check" res + +let () = + for i = 0 to nb_test do + run ("test"^(string_of_int i)) i; + done diff --git a/testsuite/tests/misc/ephetest2.reference b/testsuite/tests/misc/ephetest2.reference new file mode 100644 index 000000000..db17cd7aa --- /dev/null +++ b/testsuite/tests/misc/ephetest2.reference @@ -0,0 +1,5 @@ +test0 check: OK +test1 check: OK +test2 check: OK +test3 check: OK +test4 check: OK diff --git a/testsuite/tests/misc/ephetest3.ml b/testsuite/tests/misc/ephetest3.ml new file mode 100644 index 000000000..3c49b47fe --- /dev/null +++ b/testsuite/tests/misc/ephetest3.ml @@ -0,0 +1,133 @@ +(*************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2008 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(*************************************************************************) + +(** This test weak table by application to the memoization of collatz + (also known as syracuse) algorithm suite computation *) + +(** We use Int64 because they are boxed *) + +(** number of element of the suite to compute (more are computed) *) +let n = 1000 + +let two = Int64.of_int 2 +let three = Int64.of_int 3 + +let collatz x = + if Int64.equal (Int64.rem x two) Int64.zero + then Int64.div x two + else Int64.succ (Int64.mul x three) + +module S = struct + include Int64 + let hash (x:t) = Hashtbl.hash x +end + +let pp = Int64.to_string + +module HW = Ephemeron.K1.Make(S) +module SW = Weak.Make(S) + + +let sw = SW.create n +let hashcons x = SW.merge sw x + +let hw = HW.create n + +let rec fill_hw x = + if not (HW.mem hw x) then begin + let y = hashcons (collatz x) in + HW.add hw x y; + fill_hw y + end + +exception InvariantBroken of string +let test b = Printf.ksprintf (fun s -> if not b then raise (InvariantBroken s)) + +let rec check_hw_aux cache x = + (** We use int so that the cache doesn't make x alive *) + if not (Hashtbl.mem cache (Int64.to_int x)) then begin + test (HW.mem hw x) "missing %s%!" (pp x); + let y = + try HW.find hw x + with Not_found -> + test (not (HW.mem hw x)) "key in the table but data missing %s!%!" + (pp x); + test false "missing %s%!" (pp x); + assert false + in + let y' = collatz x in + test (Int64.equal y y') "bad result for %s: %s instead of %s%!" + (pp x) (pp y) (pp y'); + let y'' = hashcons y' in + test (y == y'') "bad result for %s: not physically equal%!" (pp x); + Hashtbl.add cache (Int64.to_int x) (); + check_hw_aux cache y + end + +let check_hw iter = + let cache = Hashtbl.create n in + iter (fun x -> check_hw_aux cache x) + +(** tests *) + +let run ~next ~check = + HW.reset hw; + SW.clear sw; + (* Gc.full_major (); *) + for x=0 to n do + let x' = next x in + fill_hw x'; + check x; + done; + Gc.full_major (); + HW.clean hw; + Printf.printf "length: %i\n%!" (HW.length hw) + +let print_stats () = + let print_stats name stats = + Printf.printf "%s (%3i,%3i,%3i): %!" + name + stats.Hashtbl.num_bindings + stats.Hashtbl.num_buckets + stats.Hashtbl.max_bucket_length; + Array.iteri (fun i n -> Printf.printf "%i: %i, %!" i n) + stats.Hashtbl.bucket_histogram; + Printf.printf "\n%!"; + in + print_stats "stats : " (HW.stats hw); + print_stats "stats_alive: " (HW.stats_alive hw) + +let test_keep_last d d' = + Printf.printf "## Keep last %i alive, check each %i ##\n%!" (n/d) (n/d'); + let keep_alive = Array.create (n/d) Int64.zero in + let next x = + let x' = hashcons (Int64.of_int x) in + Array.set keep_alive (x mod (n/d)) x'; + x' + in + let check x = + if x mod (n/d') = 0 || x = n then begin + check_hw (fun f -> Array.iter f keep_alive) + end + in + run ~next ~check; + (** keep the array alive until the end *) + let s = + Array.fold_left (fun acc x -> Int64.add x acc) Int64.zero keep_alive in + Printf.printf "sum of kept alive %s\n%!" (pp s); + print_stats (); + Printf.printf "\n%!" + +let () = + test_keep_last 1 10; + test_keep_last 50 10; + test_keep_last 100 2 diff --git a/testsuite/tests/misc/ephetest3.reference b/testsuite/tests/misc/ephetest3.reference new file mode 100644 index 000000000..4fd03fb90 --- /dev/null +++ b/testsuite/tests/misc/ephetest3.reference @@ -0,0 +1,18 @@ +## Keep last 1000 alive, check each 100 ## +length: 2228 +sum of kept alive 500500 +stats : (2228,2048, 6): 0: 658, 1: 791, 2: 413, 3: 143, 4: 34, 5: 8, 6: 1, +stats_alive: (2228,2048, 6): 0: 658, 1: 791, 2: 413, 3: 143, 4: 34, 5: 8, 6: 1, + +## Keep last 20 alive, check each 100 ## +length: 458 +sum of kept alive 19810 +stats : (458,2048, 3): 0: 1636, 1: 370, 2: 38, 3: 4, +stats_alive: (458,2048, 3): 0: 1636, 1: 370, 2: 38, 3: 4, + +## Keep last 10 alive, check each 500 ## +length: 339 +sum of kept alive 9955 +stats : (339,2048, 3): 0: 1740, 1: 279, 2: 27, 3: 2, +stats_alive: (339,2048, 3): 0: 1740, 1: 279, 2: 27, 3: 2, + diff --git a/testsuite/tests/misc/weaklifetime2.ml b/testsuite/tests/misc/weaklifetime2.ml new file mode 100644 index 000000000..4e18640ea --- /dev/null +++ b/testsuite/tests/misc/weaklifetime2.ml @@ -0,0 +1,69 @@ +(*************************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(*************************************************************************) + +let n = 500 +let loop = 2 + +let alive = ref (Array.init n (fun _ -> Array.make 10 0)) + +let create_weaks () = + Array.init n (fun i -> + let w = Weak.create 1 in + Weak.set w 0 (Some (!alive.(i))); + w + ) + +(** We are trying to keep the weak pointer of weak2 set when the + weak pointer of weak1 and weak3 are wrongly unset. + [weak1], [weak2] and [weak3] are identical. + *) + +let weak1 = create_weaks () +let weak2 = create_weaks () +let weak3 = create_weaks () + +(** put the weak pointers in the major heap *) +let () = + let dummy = ref [||] in + for l=0 to 10 do + dummy := Array.make 300 0 + done + +let gccount () = (Gc.quick_stat ()).Gc.major_collections;; + +let () = + for _l=1 to loop do + let bad = ref 0 in + for i=0 to n-1 do + (** make *this* weak key alive *) + for _j=0 to n*10 do + ignore (Weak.get weak2.(i) 0); + done; + (** Check that if it is alive in weak2 it is alive in weak1 *) + if Weak.check weak2.(i) 0 && + not (Weak.check weak1.(i) 0) && + Weak.check weak2.(i) 0 + then incr bad; + (** Check that if it is alive in weak2 it is alive in weak3 + This case was failing before the addition of the clean phase in the gc + *) + if Weak.check weak2.(i) 0 && + not (Weak.check weak3.(i) 0) && + Weak.check weak2.(i) 0 + then incr bad; + !alive.(i) <- Array.make 10 0; + done; + (* Printf.printf "bad: %i\ gccount:%i\n%!" !bad (gccount ()); *) + if !bad > 0 + then Printf.printf "failing\n%!" + else Printf.printf "success\n%!" + done diff --git a/testsuite/tests/misc/weaklifetime2.reference b/testsuite/tests/misc/weaklifetime2.reference new file mode 100644 index 000000000..cfb2161cc --- /dev/null +++ b/testsuite/tests/misc/weaklifetime2.reference @@ -0,0 +1,2 @@ +success +success diff --git a/testsuite/tests/no-alias-deps/Makefile b/testsuite/tests/no-alias-deps/Makefile index 072505bdc..5076c716e 100644 --- a/testsuite/tests/no-alias-deps/Makefile +++ b/testsuite/tests/no-alias-deps/Makefile @@ -27,7 +27,7 @@ clean: defaultclean @rm -f *.result b.cmi: b.cmi.pre - cp b.cmi.pre b.cmi + @cp b.cmi.pre b.cmi BASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/opaque/Makefile b/testsuite/tests/opaque/Makefile index 4efc1de8f..22c64fb28 100644 --- a/testsuite/tests/opaque/Makefile +++ b/testsuite/tests/opaque/Makefile @@ -14,10 +14,17 @@ BASEDIR=../.. .PHONY: default default: - @if $(BYTECODE_ONLY); then : ; else \ + @if $(BYTECODE_ONLY); then $(MAKE) skip ; else \ $(MAKE) compile; \ fi +.PHONY: skip +skip: + @echo " ... testing 'test' with ordinary compilation => skipped" + @echo " ... testing 'test' with change to opaque interface => skipped" + @echo " ... testing 'test' with change to opaque implementation => skipped" + @echo " ... testing 'test' with change to non-opaque implementation => skipped" + .PHONY: compile compile: @$(OCAMLOPT) -I intf -opaque -c intf/opaque_intf.mli @@ -55,9 +62,9 @@ promote: .PHONY: clean clean: defaultclean - @rm -f *.cmi *.cmx *.o a.out + @rm -f *.cmi *.cmx *.$(O) a.out camlprog.exe @rm -f intf/*.cmi - @rm -f fst/*.cmi fst/*.cmx fst/*.o fst/*.mli - @rm -f snd/*.cmi snd/*.cmx snd/*.o snd/*.mli + @rm -f fst/*.cmi fst/*.cmx fst/*.$(O) fst/*.mli + @rm -f snd/*.cmi snd/*.cmx snd/*.$(O) snd/*.mli include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/runtime-errors/Makefile b/testsuite/tests/runtime-errors/Makefile index 2c0bed9b6..682f7b3be 100644 --- a/testsuite/tests/runtime-errors/Makefile +++ b/testsuite/tests/runtime-errors/Makefile @@ -14,8 +14,8 @@ BASEDIR=../.. .PHONY: default default: - $(MAKE) compile - $(MAKE) run + @$(MAKE) compile + @$(MAKE) run .PHONY: compile compile: @@ -30,20 +30,37 @@ compile: @grep -q HAS_STACK_OVERFLOW_DETECTION $(TOPDIR)/config/s.h \ || rm -f stackoverflow.native$(EXE) +# Cygwin doesn't allow the stack limit to be changed - the 4096 is +# intended to be larger than the its default stack size. The logic +# causes the test to be skipped if the stacksize cannot be brought +# below this value (uname -s value exits with an error status in Cygwin) .PHONY: run run: - @ulimit -s 1024; \ + @ul=`ulimit -s`; \ + if ( [ "$$ul" = "unlimited" ] || [ $$ul -gt 4096 ] ) ; then \ + ulimit -s 1024 && ul=1 || ul=0 ; \ + else \ + ul=1; \ + fi; \ for f in *.bytecode; do \ printf " ... testing '$$f':"; \ - $(OCAMLRUN) ./$$f >$$f.result 2>&1 || true; \ - DIFF="$(DIFF)" sh $$f.checker \ - && echo " => passed" || echo " => failed"; \ - fn=`basename $$f bytecode`native; \ - if $(BYTECODE_ONLY) || [ ! -f "$${fn}$(EXE)" ] ; then : ; else \ - printf " ... testing '$$fn':"; \ - ./$${fn}$(EXE) >$$fn.result 2>&1 || true; \ - DIFF="$(DIFF)" sh $$fn.checker \ + if [ $$ul -eq 1 ] ; then \ + $(OCAMLRUN) ./$$f >$$f.result 2>&1 || true; \ + DIFF="$(DIFF)" sh $$f.checker \ && echo " => passed" || echo " => failed"; \ + else \ + echo " => unexpected error"; \ + fi; \ + fn=`basename $$f bytecode`native; \ + if $(BYTECODE_ONLY) || [ ! -f "$${fn}$(EXE)" ] ; then echo " ... testing '$$fn': => skipped" ; else \ + printf " ... testing '$$fn':"; \ + if [ $$ul -eq 1 ] ; then \ + ./$${fn}$(EXE) >$$fn.result 2>&1 || true; \ + DIFF="$(DIFF)" sh $$fn.checker \ + && echo " => passed" || echo " => failed"; \ + else \ + echo " => unexpected error"; \ + fi; \ fi; \ done diff --git a/testsuite/tests/tool-ocamldep-modalias/Makefile b/testsuite/tests/tool-ocamldep-modalias/Makefile index c11819930..476a8ace7 100644 --- a/testsuite/tests/tool-ocamldep-modalias/Makefile +++ b/testsuite/tests/tool-ocamldep-modalias/Makefile @@ -67,7 +67,7 @@ compare: $(DEPENDS) done clean: - @rm -f *.cm* *.o *.a $(DEPENDS) $(LINKS) lib.ml *~ *.byt* *.opt* + @rm -f *.cm* *.$(O) *.$(A) $(DEPENDS) $(LINKS) lib.ml *~ *.byt* *.opt* BASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/typing-gadts/didier.ml.reference b/testsuite/tests/typing-gadts/didier.ml.reference new file mode 100644 index 000000000..295d38bb5 --- /dev/null +++ b/testsuite/tests/typing-gadts/didier.ml.reference @@ -0,0 +1,34 @@ + +# Characters 94-122: + ..match tag with + | Bool -> x +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a value that is not matched: +Int +type 'a ty = Int : int ty | Bool : bool ty +val fbool : 'a -> 'a ty -> 'a = +# Characters 132-163: + ..match tag with + | Int -> x > 0 +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a value that is not matched: +Bool +val fint : 'a -> 'a ty -> bool = +# * * Characters 376-381: + | Int -> x > 0 + ^^^^^ +Error: This expression has type bool but an expression was expected of type + t = int +# Characters 45-47: + let idb1 = (fun id -> let _ = id true in id) id;; + ^^ +Error: Unbound value id +# Characters 26-28: + let idb2 : bool -> bool = id;; + ^^ +Error: Unbound value id +# val idb3 : bool -> bool = +# +Characters 184-184: + Error: Syntax error +# diff --git a/testsuite/tests/typing-gadts/pr6690.ml.reference b/testsuite/tests/typing-gadts/pr6690.ml.reference index 3f435f67b..06db19675 100644 --- a/testsuite/tests/typing-gadts/pr6690.ml.reference +++ b/testsuite/tests/typing-gadts/pr6690.ml.reference @@ -5,18 +5,16 @@ type 'a local_visit_action type ('a, 'result, 'visit_action) context = Local : ('a, 'a * insert, 'a local_visit_action) context | Global : ('a, 'a, 'a visit_action) context -# Characters 11-166: - ..........(type visit_action) - : (_, _, visit_action) context -> _ -> visit_action = +# Characters 35-166: + ....: (_, _, visit_action) context -> _ -> visit_action = function | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit Error: This expression has type ($0, $0 * insert, 'a) context -> 'b -> 'a but an expression was expected of type 'c The type constructor $0 would escape its scope -# Characters 11-174: - ..........(type visit_action) - : ('a, 'result, visit_action) context -> 'a -> visit_action = +# Characters 35-174: + ....: ('a, 'result, visit_action) context -> 'a -> visit_action = function | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit diff --git a/testsuite/tests/typing-gadts/test.ml.principal.reference b/testsuite/tests/typing-gadts/test.ml.principal.reference index 262eb0042..b69bb6b67 100644 --- a/testsuite/tests/typing-gadts/test.ml.principal.reference +++ b/testsuite/tests/typing-gadts/test.ml.principal.reference @@ -360,9 +360,9 @@ Error: This expression has type t = < foo : int; .. > but an expression was expected of type < bar : int; foo : int > Type $0 = < bar : int; .. > is not compatible with type < bar : int > The first object type has an abstract row, it cannot be closed -# Characters 98-99: +# Characters 97-121: (x:) - ^ + ^^^^^^^^^^^^^^^^^^^^^^^^ Error: This expression has type < bar : int; foo : int; .. > but an expression was expected of type 'a The type constructor $1 would escape its scope diff --git a/testsuite/tests/typing-gadts/test.ml.reference b/testsuite/tests/typing-gadts/test.ml.reference index af8b63526..2ef37155a 100644 --- a/testsuite/tests/typing-gadts/test.ml.reference +++ b/testsuite/tests/typing-gadts/test.ml.reference @@ -347,9 +347,9 @@ Error: This expression has type t = < foo : int; .. > but an expression was expected of type < bar : int; foo : int > Type $0 = < bar : int; .. > is not compatible with type < bar : int > The first object type has an abstract row, it cannot be closed -# Characters 98-99: +# Characters 97-121: (x:) - ^ + ^^^^^^^^^^^^^^^^^^^^^^^^ Error: This expression has type < bar : int; foo : int; .. > but an expression was expected of type 'a The type constructor $1 would escape its scope diff --git a/testsuite/tests/typing-missing-cmi/Makefile b/testsuite/tests/typing-missing-cmi/Makefile new file mode 100644 index 000000000..efbc9c5d5 --- /dev/null +++ b/testsuite/tests/typing-missing-cmi/Makefile @@ -0,0 +1,12 @@ + +default: subdir/m.ml a.ml b.ml main.ml + @printf " ... testing 'main.ml'"; + @$(OCAMLC) -c subdir/m.ml; + @$(OCAMLC) -c -I subdir a.ml; + @$(OCAMLC) -c -I subdir b.ml; + @$(OCAMLC) -c main.ml 2>&1 | cat > main.ml.result; + @$(DIFF) main.ml.result main.ml.reference >/dev/null \ + && echo " => passed" || echo " => failed" + +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/typing-missing-cmi/a.ml b/testsuite/tests/typing-missing-cmi/a.ml new file mode 100644 index 000000000..0631d4394 --- /dev/null +++ b/testsuite/tests/typing-missing-cmi/a.ml @@ -0,0 +1 @@ +let (a : M.a) = 2 diff --git a/testsuite/tests/typing-missing-cmi/b.ml b/testsuite/tests/typing-missing-cmi/b.ml new file mode 100644 index 000000000..eb1e004ad --- /dev/null +++ b/testsuite/tests/typing-missing-cmi/b.ml @@ -0,0 +1 @@ +let (b : M.b) = 2 diff --git a/testsuite/tests/typing-missing-cmi/main.ml b/testsuite/tests/typing-missing-cmi/main.ml new file mode 100644 index 000000000..1bf8c9911 --- /dev/null +++ b/testsuite/tests/typing-missing-cmi/main.ml @@ -0,0 +1 @@ +let _ = A.a = B.b diff --git a/testsuite/tests/typing-missing-cmi/main.ml.reference b/testsuite/tests/typing-missing-cmi/main.ml.reference new file mode 100644 index 000000000..dfcfd0204 --- /dev/null +++ b/testsuite/tests/typing-missing-cmi/main.ml.reference @@ -0,0 +1,5 @@ +File "main.ml", line 1, characters 14-17: +Error: This expression has type M.b but an expression was expected of type + M.a +M.b is abstract because no corresponding cmi file was found in path. +M.a is abstract because no corresponding cmi file was found in path. diff --git a/testsuite/tests/typing-missing-cmi/subdir/m.ml b/testsuite/tests/typing-missing-cmi/subdir/m.ml new file mode 100644 index 000000000..32870c88c --- /dev/null +++ b/testsuite/tests/typing-missing-cmi/subdir/m.ml @@ -0,0 +1,2 @@ +type a = int +type b = a diff --git a/testsuite/tests/typing-modules/b.ml.reference b/testsuite/tests/typing-modules/b.ml.reference new file mode 100644 index 000000000..9faafbf65 --- /dev/null +++ b/testsuite/tests/typing-modules/b.ml.reference @@ -0,0 +1,5 @@ + +# * * * * * +Characters 352-352: + Error: Syntax error +# diff --git a/testsuite/tests/typing-modules/b2.ml.reference b/testsuite/tests/typing-modules/b2.ml.reference new file mode 100644 index 000000000..9b4558624 --- /dev/null +++ b/testsuite/tests/typing-modules/b2.ml.reference @@ -0,0 +1,5 @@ + +# * * +Characters 312-312: + Error: Syntax error +# diff --git a/testsuite/tests/typing-modules/d.ml.reference b/testsuite/tests/typing-modules/d.ml.reference new file mode 100644 index 000000000..06308c781 --- /dev/null +++ b/testsuite/tests/typing-modules/d.ml.reference @@ -0,0 +1,5 @@ + +# +Characters 42-42: + Error: Syntax error +# diff --git a/testsuite/tests/typing-unboxed/test.ml b/testsuite/tests/typing-unboxed/test.ml index f872c5bd3..decf43d52 100644 --- a/testsuite/tests/typing-unboxed/test.ml +++ b/testsuite/tests/typing-unboxed/test.ml @@ -11,22 +11,22 @@ (***********************************************************************) -external a : (int [@untagged]) -> unit = "a" -external b : (int32 [@unboxed]) -> unit = "b" -external c : (int64 [@unboxed]) -> unit = "c" -external d : (nativeint [@unboxed]) -> unit = "d" -external e : (float [@unboxed]) -> unit = "e" +external a : (int [@untagged]) -> unit = "a" "a_nat" +external b : (int32 [@unboxed]) -> unit = "b" "b_nat" +external c : (int64 [@unboxed]) -> unit = "c" "c_nat" +external d : (nativeint [@unboxed]) -> unit = "d" "d_nat" +external e : (float [@unboxed]) -> unit = "e" "e_nat" type t = private int -external f : (t [@untagged]) -> unit = "f" +external f : (t [@untagged]) -> unit = "f" "f_nat" module M : sig - external a : int -> (int [@untagged]) = "a" - external b : (int [@untagged]) -> int = "b" + external a : int -> (int [@untagged]) = "a" "a_nat" + external b : (int [@untagged]) -> int = "b" "b_nat" end = struct - external a : int -> (int [@untagged]) = "a" - external b : (int [@untagged]) -> int = "b" + external a : int -> (int [@untagged]) = "a" "a_nat" + external b : (int [@untagged]) -> int = "b" "b_nat" end;; module Global_attributes = struct @@ -38,11 +38,12 @@ module Global_attributes = struct external d : float -> float = "d" "noalloc" external e : float -> float = "e" + (* Should outputs a warning: no native implementation provided *) external f : (int32 [@unboxed]) -> (int32 [@unboxed]) = "f" "noalloc" - external g : int32 -> int32 = "g" [@@unboxed] [@@noalloc] + external g : int32 -> int32 = "g" "g_nat" [@@unboxed] [@@noalloc] - external h : (int [@untagged]) -> (int [@untagged]) = "h" "noalloc" - external i : int -> int = "i" [@@untagged] [@@noalloc] + external h : (int [@untagged]) -> (int [@untagged]) = "h" "h_nat" "noalloc" + external i : int -> int = "i" "i_nat" [@@untagged] [@@noalloc] end;; module Old_style_warning = struct @@ -51,74 +52,87 @@ module Old_style_warning = struct external b : float -> float = "b" "noalloc" "b_nat" external c : float -> float = "c" "c_nat" "float" external d : float -> float = "d" "noalloc" + external e : float -> float = "c" "float" end (* Bad: attributes not reported in the interface *) module Bad1 : sig - external f : int -> int = "f" + external f : int -> int = "f" "f_nat" end = struct - external f : int -> (int [@untagged]) = "f" + external f : int -> (int [@untagged]) = "f" "f_nat" end;; module Bad2 : sig - external f : int -> int = "a" + external f : int -> int = "a" "a_nat" end = struct - external f : (int [@untagged]) -> int = "f" + external f : (int [@untagged]) -> int = "f" "f_nat" end;; module Bad3 : sig - external f : float -> float = "f" + external f : float -> float = "f" "f_nat" end = struct - external f : float -> (float [@unboxed]) = "f" + external f : float -> (float [@unboxed]) = "f" "f_nat" end;; module Bad4 : sig - external f : float -> float = "a" + external f : float -> float = "a" "a_nat" end = struct - external f : (float [@unboxed]) -> float = "f" + external f : (float [@unboxed]) -> float = "f" "f_nat" end;; (* Bad: attributes in the interface but not in the implementation *) module Bad5 : sig - external f : int -> (int [@untagged]) = "f" + external f : int -> (int [@untagged]) = "f" "f_nat" end = struct - external f : int -> int = "f" + external f : int -> int = "f" "f_nat" end;; module Bad6 : sig - external f : (int [@untagged]) -> int = "f" + external f : (int [@untagged]) -> int = "f" "f_nat" end = struct - external f : int -> int = "a" + external f : int -> int = "a" "a_nat" end;; module Bad7 : sig - external f : float -> (float [@unboxed]) = "f" + external f : float -> (float [@unboxed]) = "f" "f_nat" end = struct - external f : float -> float = "f" + external f : float -> float = "f" "f_nat" end;; module Bad8 : sig - external f : (float [@unboxed]) -> float = "f" + external f : (float [@unboxed]) -> float = "f" "f_nat" end = struct - external f : float -> float = "a" + external f : float -> float = "a" "a_nat" end;; (* Bad: unboxed or untagged with the wrong type *) -external g : (float [@untagged]) -> float = "g";; -external h : (int [@unboxed]) -> float = "h";; +external g : (float [@untagged]) -> float = "g" "g_nat";; +external h : (int [@unboxed]) -> float = "h" "h_nat";; + +(* Bad: unboxing the function type *) +external i : int -> float [@unboxed] = "i" "i_nat";; + +(* Bad: unboxing a "deep" sub-type. *) +external j : int -> (float [@unboxed]) * float = "j" "j_nat";; (* This should be rejected, but it is quite complicated to do in the current state of things *) -external i : int -> float [@unboxed] = "i";; -external j : int -> (float [@unboxed]) * float = "j";; -external k : int -> (float [@unboxd]) = "k";; +external k : int -> (float [@unboxd]) = "k" "k_nat";; (* Bad: old style annotations + new style attributes *) external l : float -> float = "l" "l_nat" "float" [@@unboxed];; external m : (float [@unboxed]) -> float = "m" "m_nat" "float";; external n : float -> float = "n" "noalloc" [@@noalloc];; + +(* Warnings: unboxed / untagged without any native implementation *) +external o : (float[@unboxed]) -> float = "o";; +external p : float -> (float[@unboxed]) = "p";; +external q : (int[@untagged]) -> float = "q";; +external r : int -> (int[@untagged]) = "r";; +external s : int -> int = "s" [@@untagged];; +external t : float -> float = "t" [@@unboxed];; diff --git a/testsuite/tests/typing-unboxed/test.ml.reference b/testsuite/tests/typing-unboxed/test.ml.reference index 68c9c9534..d6f1af192 100644 --- a/testsuite/tests/typing-unboxed/test.ml.reference +++ b/testsuite/tests/typing-unboxed/test.ml.reference @@ -1,29 +1,21 @@ -# external a : (int [@untagged]) -> unit = "a" -external b : (int32 [@unboxed]) -> unit = "b" -external c : (int64 [@unboxed]) -> unit = "c" -external d : (nativeint [@unboxed]) -> unit = "d" -external e : (float [@unboxed]) -> unit = "e" +# external a : (int [@untagged]) -> unit = "a" "a_nat" +external b : (int32 [@unboxed]) -> unit = "b" "b_nat" +external c : (int64 [@unboxed]) -> unit = "c" "c_nat" +external d : (nativeint [@unboxed]) -> unit = "d" "d_nat" +external e : (float [@unboxed]) -> unit = "e" "e_nat" type t = private int -external f : (t [@untagged]) -> unit = "f" +external f : (t [@untagged]) -> unit = "f" "f_nat" module M : sig - external a : int -> (int [@untagged]) = "a" - external b : (int [@untagged]) -> int = "b" + external a : int -> (int [@untagged]) = "a" "a_nat" + external b : (int [@untagged]) -> int = "b" "b_nat" end -# module Global_attributes : - sig - external a : float -> float = "a" "a_nat" [@@unboxed] [@@noalloc] - external b : float -> float = "b" "b_nat" [@@noalloc] - external c : float -> float = "c" "c_nat" [@@unboxed] [@@noalloc] - external d : float -> float = "d" [@@noalloc] - external e : float -> float = "e" - external f : int32 -> int32 = "f" [@@unboxed] [@@noalloc] - external g : int32 -> int32 = "g" [@@unboxed] [@@noalloc] - external h : int -> int = "h" [@@untagged] [@@noalloc] - external i : int -> int = "i" [@@untagged] [@@noalloc] - end -# Characters 63-122: +# Characters 383-452: + external f : (int32 [@unboxed]) -> (int32 [@unboxed]) = "f" "noalloc" + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present +# Characters 63-122: external a : float -> float = "a" "noalloc" "a_nat" "float" ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 3: deprecated: [@@unboxed] + [@@noalloc] should be used instead of "float" @@ -39,121 +31,127 @@ Characters 231-274: external d : float -> float = "d" "noalloc" ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 3: deprecated: [@@noalloc] should be used instead of "noalloc" -Characters 389-445: +Characters 441-505: ......struct - external f : int -> (int [@untagged]) = "f" + external f : int -> (int [@untagged]) = "f" "f_nat" end.. Error: Signature mismatch: Modules do not match: - sig external f : int -> (int [@untagged]) = "f" end + sig external f : int -> (int [@untagged]) = "f" "f_nat" end is not included in - sig external f : int -> int = "f" end + sig external f : int -> int = "f" "f_nat" end Values do not match: - external f : int -> (int [@untagged]) = "f" + external f : int -> (int [@untagged]) = "f" "f_nat" is not included in - external f : int -> int = "f" -# Characters 57-113: + external f : int -> int = "f" "f_nat" +# Characters 65-129: ......struct - external f : (int [@untagged]) -> int = "f" + external f : (int [@untagged]) -> int = "f" "f_nat" end.. Error: Signature mismatch: Modules do not match: - sig external f : (int [@untagged]) -> int = "f" end + sig external f : (int [@untagged]) -> int = "f" "f_nat" end is not included in - sig external f : int -> int = "a" end + sig external f : int -> int = "a" "a_nat" end Values do not match: - external f : (int [@untagged]) -> int = "f" + external f : (int [@untagged]) -> int = "f" "f_nat" is not included in - external f : int -> int = "a" -# Characters 61-120: + external f : int -> int = "a" "a_nat" +# Characters 69-136: ......struct - external f : float -> (float [@unboxed]) = "f" + external f : float -> (float [@unboxed]) = "f" "f_nat" end.. Error: Signature mismatch: Modules do not match: - sig external f : float -> (float [@unboxed]) = "f" end + sig external f : float -> (float [@unboxed]) = "f" "f_nat" end is not included in - sig external f : float -> float = "f" end + sig external f : float -> float = "f" "f_nat" end Values do not match: - external f : float -> (float [@unboxed]) = "f" + external f : float -> (float [@unboxed]) = "f" "f_nat" is not included in - external f : float -> float = "f" -# Characters 61-120: + external f : float -> float = "f" "f_nat" +# Characters 69-136: ......struct - external f : (float [@unboxed]) -> float = "f" + external f : (float [@unboxed]) -> float = "f" "f_nat" end.. Error: Signature mismatch: Modules do not match: - sig external f : (float [@unboxed]) -> float = "f" end + sig external f : (float [@unboxed]) -> float = "f" "f_nat" end is not included in - sig external f : float -> float = "a" end + sig external f : float -> float = "a" "a_nat" end Values do not match: - external f : (float [@unboxed]) -> float = "f" + external f : (float [@unboxed]) -> float = "f" "f_nat" is not included in - external f : float -> float = "a" -# Characters 141-183: + external f : float -> float = "a" "a_nat" +# Characters 149-199: ......struct - external f : int -> int = "f" + external f : int -> int = "f" "f_nat" end.. Error: Signature mismatch: Modules do not match: - sig external f : int -> int = "f" end + sig external f : int -> int = "f" "f_nat" end is not included in - sig external f : int -> (int [@untagged]) = "f" end + sig external f : int -> (int [@untagged]) = "f" "f_nat" end Values do not match: - external f : int -> int = "f" + external f : int -> int = "f" "f_nat" is not included in - external f : int -> (int [@untagged]) = "f" -# Characters 71-113: + external f : int -> (int [@untagged]) = "f" "f_nat" +# Characters 79-129: ......struct - external f : int -> int = "a" + external f : int -> int = "a" "a_nat" end.. Error: Signature mismatch: Modules do not match: - sig external f : int -> int = "a" end + sig external f : int -> int = "a" "a_nat" end is not included in - sig external f : (int [@untagged]) -> int = "f" end + sig external f : (int [@untagged]) -> int = "f" "f_nat" end Values do not match: - external f : int -> int = "a" + external f : int -> int = "a" "a_nat" is not included in - external f : (int [@untagged]) -> int = "f" -# Characters 74-120: + external f : (int [@untagged]) -> int = "f" "f_nat" +# Characters 82-136: ......struct - external f : float -> float = "f" + external f : float -> float = "f" "f_nat" end.. Error: Signature mismatch: Modules do not match: - sig external f : float -> float = "f" end + sig external f : float -> float = "f" "f_nat" end is not included in - sig external f : float -> (float [@unboxed]) = "f" end + sig external f : float -> (float [@unboxed]) = "f" "f_nat" end Values do not match: - external f : float -> float = "f" + external f : float -> float = "f" "f_nat" is not included in - external f : float -> (float [@unboxed]) = "f" -# Characters 74-120: + external f : float -> (float [@unboxed]) = "f" "f_nat" +# Characters 82-136: ......struct - external f : float -> float = "a" + external f : float -> float = "a" "a_nat" end.. Error: Signature mismatch: Modules do not match: - sig external f : float -> float = "a" end + sig external f : float -> float = "a" "a_nat" end is not included in - sig external f : (float [@unboxed]) -> float = "f" end + sig external f : (float [@unboxed]) -> float = "f" "f_nat" end Values do not match: - external f : float -> float = "a" + external f : float -> float = "a" "a_nat" is not included in - external f : (float [@unboxed]) -> float = "f" + external f : (float [@unboxed]) -> float = "f" "f_nat" # Characters 67-72: - external g : (float [@untagged]) -> float = "g";; + external g : (float [@untagged]) -> float = "g" "g_nat";; ^^^^^ Error: Don't know how to untag this type. Only int can be untagged # Characters 14-17: - external h : (int [@unboxed]) -> float = "h";; + external h : (int [@unboxed]) -> float = "h" "h_nat";; ^^^ Error: Don't know how to unbox this type. Only float, int32, int64 and nativeint can be unboxed -# * external i : int -> float = "i" -# external j : int -> float * float = "j" -# external k : int -> float = "k" +# Characters 52-64: + external i : int -> float [@unboxed] = "i" "i_nat";; + ^^^^^^^^^^^^ +Error: Don't know how to unbox this type. Only float, int32, int64 and nativeint can be unboxed +# Characters 61-66: + external j : int -> (float [@unboxed]) * float = "j" "j_nat";; + ^^^^^ +Error: The attribute '@unboxed' should be attached to a direct argument or result of the primitive, it should not occur deeply into its type +# * external k : int -> float = "k" "k_nat" # Characters 58-119: external l : float -> float = "l" "l_nat" "float" [@@unboxed];; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ @@ -166,4 +164,28 @@ Error: Cannot use "float" in conjunction with [@unboxed]/[@untagged] external n : float -> float = "n" "noalloc" [@@noalloc];; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Cannot use "noalloc" in conjunction with [@@noalloc] +# Characters 70-115: + external o : (float[@unboxed]) -> float = "o";; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present +# Characters 0-45: + external p : float -> (float[@unboxed]) = "p";; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present +# Characters 0-44: + external q : (int[@untagged]) -> float = "q";; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present +# Characters 0-42: + external r : int -> (int[@untagged]) = "r";; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present +# Characters 0-42: + external s : int -> int = "s" [@@untagged];; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present +# Characters 0-45: + external t : float -> float = "t" [@@unboxed];; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present # diff --git a/testsuite/tests/unboxed-primitive-args/Makefile b/testsuite/tests/unboxed-primitive-args/Makefile index cda32a72f..c187eb382 100644 --- a/testsuite/tests/unboxed-primitive-args/Makefile +++ b/testsuite/tests/unboxed-primitive-args/Makefile @@ -15,6 +15,7 @@ LIBRARIES=unix bigarray MODULES=common MAIN_MODULE=main C_FILES=test_common stubs +C_INCLUDES=-I $(OTOPDIR)/otherlibs/bigarray ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/bigarray \ -I $(OTOPDIR)/otherlibs/$(UNIXLIB) diff --git a/testsuite/tests/warnings/Makefile b/testsuite/tests/warnings/Makefile index b9c1568eb..30e1dffc9 100644 --- a/testsuite/tests/warnings/Makefile +++ b/testsuite/tests/warnings/Makefile @@ -15,7 +15,7 @@ FLAGS=-w A run-all: @$(OCAMLC) $(FLAGS) -c deprecated_module.mli - @$(OCAMLOPT) $(FLAGS) -c module_without_cmx.mli + @$(OCAMLC) $(FLAGS) -c module_without_cmx.mli @for file in *.ml; do \ printf " ... testing '$$file':"; \ F="`basename $$file .ml`"; \ @@ -25,10 +25,12 @@ run-all: done; @for file in *.opt.ml; do \ printf " ... testing '$$file' with ocamlopt:"; \ - F="`basename $$file .ml`"; \ - $(OCAMLOPT) $(FLAGS) -c $$file 2>$$F.opt_result; \ - $(DIFF) $$F.opt_reference $$F.opt_result >/dev/null \ - && echo " => passed" || echo " => failed"; \ + if $(BYTECODE_ONLY); then echo " => skipped"; else \ + F="`basename $$file .ml`"; \ + $(OCAMLOPT) $(FLAGS) -c $$file 2>$$F.opt_result; \ + $(DIFF) $$F.opt_reference $$F.opt_result >/dev/null \ + && echo " => passed" || echo " => failed"; \ + fi \ done; promote: defaultpromote diff --git a/testsuite/typing b/testsuite/typing index 4357fdf3c..eac3b6378 100644 --- a/testsuite/typing +++ b/testsuite/typing @@ -14,6 +14,7 @@ tests/typing-implicit_unpack tests/typing-labels tests/typing-misc tests/typing-misc-bugs +tests/typing-missing-cmi tests/typing-modules tests/typing-modules-bugs tests/typing-objects diff --git a/tools/Makefile.nt b/tools/Makefile.nt index 1e5f9cc8c..e748554ae 100644 --- a/tools/Makefile.nt +++ b/tools/Makefile.nt @@ -12,10 +12,12 @@ include Makefile.shared +CAMLOPT:=$(if $(wildcard ../flexdll/Makefile),OCAML_FLEXLINK="../boot/ocamlrun ../flexdll/flexlink.exe") $(CAMLOPT) + # To make custom toplevels OCAMLMKTOP=ocamlmktop.cmo -OCAMLMKTOP_IMPORTS=misc.cmo identifiable.cmo numbers.cmo config.cmo clflags.cmo ccomp.cmo +OCAMLMKTOP_IMPORTS=misc.cmo identifiable.cmo numbers.cmo config.cmo arg_helper.cmo clflags.cmo ccomp.cmo ocamlmktop: $(OCAMLMKTOP) $(CAMLC) $(LINKFLAGS) -o ocamlmktop $(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP) @@ -24,4 +26,4 @@ install:: cp ocamlmktop $(INSTALL_BINDIR)/ocamlmktop$(EXE) clean:: - rm -f ocamlmktop$(EXE) + rm -f ocamlmktop objinfo_helper$(EXE).manifest diff --git a/tools/Makefile.shared b/tools/Makefile.shared index df2372a87..ba50ba662 100644 --- a/tools/Makefile.shared +++ b/tools/Makefile.shared @@ -36,10 +36,11 @@ opt.opt: ocamldep.opt read_cmt.opt CAMLDEP_OBJ=depend.cmo ocamldep.cmo CAMLDEP_IMPORTS=timings.cmo misc.cmo config.cmo identifiable.cmo numbers.cmo \ - clflags.cmo terminfo.cmo \ + arg_helper.cmo clflags.cmo terminfo.cmo \ warnings.cmo location.cmo longident.cmo docstrings.cmo \ syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo \ - ccomp.cmo ast_mapper.cmo pparse.cmo compenv.cmo builtin_attributes.cmo + ccomp.cmo ast_mapper.cmo ast_iterator.cmo ast_invariants.cmo pparse.cmo compenv.cmo \ + builtin_attributes.cmo ocamldep: depend.cmi $(CAMLDEP_OBJ) $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ) @@ -67,7 +68,7 @@ install:: CSLPROF=ocamlprof.cmo CSLPROF_IMPORTS=misc.cmo config.cmo identifiable.cmo numbers.cmo \ - clflags.cmo terminfo.cmo \ + arg_helper.cmo clflags.cmo terminfo.cmo \ warnings.cmo location.cmo longident.cmo docstrings.cmo \ syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo @@ -75,10 +76,12 @@ ocamlprof: $(CSLPROF) profiling.cmo $(CAMLC) $(LINKFLAGS) -o ocamlprof $(CSLPROF_IMPORTS) $(CSLPROF) ocamlcp: ocamlcp.cmo - $(CAMLC) $(LINKFLAGS) -o ocamlcp warnings.cmo main_args.cmo ocamlcp.cmo + $(CAMLC) $(LINKFLAGS) -o ocamlcp misc.cmo warnings.cmo config.cmo \ + identifiable.cmo numbers.cmo arg_helper.cmo clflags.cmo main_args.cmo ocamlcp.cmo ocamloptp: ocamloptp.cmo - $(CAMLC) $(LINKFLAGS) -o ocamloptp warnings.cmo main_args.cmo \ + $(CAMLC) $(LINKFLAGS) -o ocamloptp misc.cmo warnings.cmo config.cmo \ + identifiable.cmo numbers.cmo arg_helper.cmo clflags.cmo main_args.cmo \ ocamloptp.cmo opt:: profiling.cmx @@ -99,7 +102,7 @@ clean:: # To help building mixed-mode libraries (OCaml + C) ocamlmklib: ocamlmklibconfig.cmo ocamlmklib.cmo - $(CAMLC) $(LINKFLAGS) -o ocamlmklib ocamlmklibconfig.cmo ocamlmklib.cmo + $(CAMLC) $(LINKFLAGS) -o ocamlmklib ocamlmklibconfig.cmo config.cmo ocamlmklib.cmo install:: cp ocamlmklib $(INSTALL_BINDIR)/ocamlmklib$(EXE) @@ -107,12 +110,9 @@ install:: clean:: rm -f ocamlmklib -ocamlmklibconfig.ml: ../config/Makefile +ocamlmklibconfig.ml: ../config/Makefile Makefile (echo 'let bindir = "$(BINDIR)"'; \ - echo 'let ext_lib = "$(EXT_LIB)"'; \ - echo 'let ext_dll = "$(EXT_DLL)"'; \ echo 'let supports_shared_libraries = $(SUPPORTS_SHARED_LIBRARIES)';\ - echo 'let mkdll = "$(MKDLL)"'; \ echo 'let byteccrpath = "$(BYTECCRPATH)"'; \ echo 'let nativeccrpath = "$(NATIVECCRPATH)"'; \ echo 'let mksharedlibrpath = "$(MKSHAREDLIBRPATH)"'; \ @@ -160,7 +160,7 @@ clean:: # Insert labels following an interface file (upgrade 3.02 to 3.03) -ADDLABELS_IMPORTS=misc.cmo config.cmo clflags.cmo \ +ADDLABELS_IMPORTS=misc.cmo config.cmo arg_helper.cmo clflags.cmo \ identifiable.cmo numbers.cmo terminfo.cmo \ warnings.cmo location.cmo longident.cmo docstrings.cmo \ syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo diff --git a/tools/objinfo.ml b/tools/objinfo.ml index 5faa42de9..3b8c26daa 100644 --- a/tools/objinfo.ml +++ b/tools/objinfo.ml @@ -113,8 +113,14 @@ open Cmx_format let print_cmx_infos (ui, crc) = print_general_infos ui.ui_name crc ui.ui_defines ui.ui_imports_cmi ui.ui_imports_cmx; - printf "Approximation:\n"; - Format.fprintf Format.std_formatter " %a@." Printclambda.approx ui.ui_approx; + begin match ui.ui_export_info with + | Clambda approx -> + printf "Approximation:\n"; + Format.fprintf Format.std_formatter " %a@." Printclambda.approx approx + | Flambda _ -> () + (* CR mshinwell: This should print the flambda export info. + Unfortunately this needs some surgery in the Makefiles. *) + end; let pr_funs _ fns = List.iter (fun arity -> printf " %d" arity) fns in printf "Currying functions:%a\n" pr_funs ui.ui_curry_fun; diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml index 76f73bc5a..931e557b5 100644 --- a/tools/ocamlcp.ml +++ b/tools/ocamlcp.ml @@ -108,6 +108,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _dtypedtree = option "-dtypedtree" let _drawlambda = option "-drawlambda" let _dlambda = option "-dlambda" + let _dflambda = option "-dflambda" let _dinstr = option "-dinstr" let _dtimings = option "-dtimings" let anonymous = process_file diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml index 1c9320822..522ba4ed1 100644 --- a/tools/ocamldep.ml +++ b/tools/ocamldep.ml @@ -367,7 +367,7 @@ let mli_file_dependencies source_file = end let process_file_as process_fun def source_file = - Compenv.readenv ppf Before_compile; + Compenv.readenv ppf (Before_compile source_file); load_path := []; List.iter add_to_load_path ( (!Compenv.last_include_dirs @ diff --git a/tools/ocamlmklib.ml b/tools/ocamlmklib.ml index 69cb0452f..54e29893b 100644 --- a/tools/ocamlmklib.ml +++ b/tools/ocamlmklib.ml @@ -244,9 +244,9 @@ let build_libs () = if !dynlink then begin let retcode = command (Printf.sprintf "%s %s -o %s %s %s %s %s %s" - mkdll + Config.mkdll (if !debug then "-g" else "") - (prepostfix "dll" !output_c ext_dll) + (prepostfix "dll" !output_c Config.ext_dll) (String.concat " " !c_objs) (String.concat " " !c_opts) (String.concat " " !ld_opts) @@ -256,9 +256,9 @@ let build_libs () = in if retcode <> 0 then if !failsafe then dynlink := false else exit 2 end; - safe_remove (prepostfix "lib" !output_c ext_lib); + safe_remove (prepostfix "lib" !output_c Config.ext_lib); scommand - (mklib (prepostfix "lib" !output_c ext_lib) + (mklib (prepostfix "lib" !output_c Config.ext_lib) (String.concat " " !c_objs) ""); end; if !bytecode_objs <> [] then diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml index 9429d65ed..bf4d347e7 100644 --- a/tools/ocamloptp.ml +++ b/tools/ocamloptp.ml @@ -23,6 +23,9 @@ let option_with_arg opt arg = let option_with_int opt arg = compargs := (string_of_int 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;; @@ -51,6 +54,7 @@ module Options = Main_args.Make_optcomp_options (struct 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 _for_pack s = option_with_arg "-for-pack" s @@ -58,7 +62,21 @@ module Options = Main_args.Make_optcomp_options (struct 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 n = option_with_int "-inline" n + let _inline s = option_with_arg "-inline" s + let _inline_toplevel n = option_with_arg "-inline-toplevel" n + let _inlining_stats = option "-inlining-report" + let _dump_pass = option_with_arg "-dump-pass" + let _max_inlining_depth n = option_with_arg "-max-inlining-depth" n + let _rounds n = option_with_int "-rounds" n + let _unroll n = option_with_arg "-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 _branch_inline_factor n = option_with_arg "-branch-inline-factor" n + let _classic_inlining = option "-classic-inlining" 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" @@ -71,9 +89,12 @@ module Options = Main_args.Make_optcomp_options (struct let _noassert = option "-noassert" let _noautolink = option "-noautolink" let _nodynlink = option "-nodynlink" + let _no_inline_recursive_functions = option "-no-inline-recursive-functions" let _nolabels = option "-nolabels" let _nostdlib = option "-nostdlib" 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" @@ -83,6 +104,7 @@ module Options = Main_args.Make_optcomp_options (struct let _ppx _s = incompatible "-ppx" let _principal = option "-principal" let _rectypes = option "-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" @@ -91,6 +113,7 @@ module Options = Main_args.Make_optcomp_options (struct let _strict_formats = option "-strict-formats" let _shared = option "-shared" let _thread = option "-thread" + let _unbox_closures = option "-unbox-closures" let _unsafe = option "-unsafe" let _unsafe_string = option "-unsafe-string" let _v = option "-v" @@ -109,7 +132,12 @@ module Options = Main_args.Make_optcomp_options (struct let _dtypedtree = option "-dtypedtree" let _drawlambda = option "-drawlambda" let _dlambda = option "-dlambda" + let _drawclambda = option "-drawclambda" let _dclambda = option "-dclambda" + let _dflambda = option "-dflambda" + let _dflambda_invariants = option "-dflambda-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" diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml index bb5b5e05b..a612d0678 100644 --- a/toplevel/opttoploop.ml +++ b/toplevel/opttoploop.ml @@ -61,9 +61,35 @@ type directive_fun = (* Return the value referred to by a path *) +let remembered = ref Ident.empty + +let rec remember phrase_name i = function + | [] -> () + | Sig_value (id, _) :: rest + | Sig_module (id, _, _) :: rest + | Sig_typext (id, _, _) :: rest + | Sig_class (id, _, _) :: rest -> + remembered := Ident.add id (phrase_name, i) !remembered; + remember phrase_name (succ i) rest + | _ :: rest -> remember phrase_name i rest + let toplevel_value id = - let (glb,pos) = Translmod.nat_toplevel_name id in - (Obj.magic (global_symbol glb)).(pos) + try Ident.find_same id !remembered + with _ -> Misc.fatal_error @@ "Unknown ident: " ^ Ident.unique_name id + +let close_phrase lam = + let open Lambda in + IdentSet.fold (fun id l -> + let glb, pos = toplevel_value id in + let glob = Lprim (Pfield pos, [Lprim (Pgetglobal glb, [])]) in + Llet(Strict, id, glob, l) + ) (free_variables lam) lam + +let toplevel_value id = + let glob, pos = + if Config.flambda then toplevel_value id else Translmod.nat_toplevel_name id + in + (Obj.magic (global_symbol glob)).(pos) let rec eval_path = function | Pident id -> @@ -155,7 +181,26 @@ let toplevel_startup_hook = ref (fun () -> ()) let phrase_seqid = ref 0 let phrase_name = ref "TOP" -let load_lambda ppf (size, lam) = +(* CR trefis for mshinwell: copy/pasted from Optmain. Should it be shared or? *) +module Backend = struct + (* See backend_intf.mli. *) + + let symbol_for_global' = Compilenv.symbol_for_global' + let closure_symbol = Compilenv.closure_symbol + + let really_import_approx = Import_approx.really_import_approx + let import_symbol = Import_approx.import_symbol + + let size_int = Arch.size_int + let big_endian = Arch.big_endian + + (* CR mshinwell: this needs tying through to [Proc], although it may + necessitate the introduction of a new field in that module. *) + let max_sensible_number_of_arguments = 9 +end +let backend = (module Backend : Backend_intf.S) + +let load_lambda ppf ~module_ident lam size = if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam; let slam = Simplif.simplify_lambda lam in if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam; @@ -165,8 +210,16 @@ let load_lambda ppf (size, lam) = else Filename.temp_file ("caml" ^ !phrase_name) ext_dll in let fn = Filename.chop_extension dll in - Asmgen.compile_implementation ~source_provenance:Timings.Toplevel - ~toplevel:need_symbol fn ppf (size, slam); + if not Config.flambda then + Asmgen.compile_implementation_clambda ~source_provenance:Timings.Toplevel + ~toplevel:need_symbol fn ppf + { Lambda.code=lam ; main_module_block_size=size } + else + Asmgen.compile_implementation_flambda ~source_provenance:Timings.Toplevel + ~backend ~toplevel:need_symbol fn ppf + (Middle_end.middle_end ppf + ~source_provenance:Timings.Toplevel ~prefixname:"" ~backend ~size + ~module_ident ~module_initializer:lam); Asmlink.call_linker_shared [fn ^ ext_obj] dll; Sys.remove (fn ^ ext_obj); @@ -221,29 +274,68 @@ let execute_phrase print_outcome ppf phr = Compilenv.reset ~source_provenance:Timings.Toplevel ?packname:None !phrase_name; Typecore.reset_delayed_checks (); + let sstr, rewritten = + match sstr with + | [ { pstr_desc = Pstr_eval (e, attrs) ; pstr_loc = loc } ] + | [ { pstr_desc = Pstr_value (Asttypes.Nonrecursive, + [{ pvb_expr = e + ; pvb_pat = { ppat_desc = Ppat_any ; _ } + ; pvb_attributes = attrs + ; _ }]) + ; pstr_loc = loc } + ] -> + let pat = Ast_helper.Pat.var (Location.mknoloc "_$") in + let vb = Ast_helper.Vb.mk ~loc ~attrs pat e in + [ Ast_helper.Str.value ~loc Asttypes.Nonrecursive [vb] ], true + | _ -> sstr, false + in let (str, sg, newenv) = Typemod.type_toplevel_phrase oldenv sstr in if !Clflags.dump_typedtree then Printtyped.implementation ppf str; let sg' = Typemod.simplify_signature sg in + (* Why is this done? *) ignore (Includemod.signatures oldenv sg sg'); Typecore.force_delayed_checks (); - let res = Translmod.transl_store_phrases !phrase_name str in + let module_ident, res, size = + if Config.flambda then + let ((module_ident, size), res) = + Translmod.transl_implementation_flambda !phrase_name + (str, Tcoerce_none) + in + remember module_ident 0 sg'; + module_ident, close_phrase res, size + else + let size, res = Translmod.transl_store_phrases !phrase_name str in + Ident.create_persistent !phrase_name, res, size + in Warnings.check_fatal (); begin try toplevel_env := newenv; - let res = load_lambda ppf res in + let res = load_lambda ppf ~module_ident res size in let out_phr = match res with | Result v -> - Compilenv.record_global_approx_toplevel (); + if Config.flambda then + (* CR-someday trefis: *) + () + else + Compilenv.record_global_approx_toplevel (); if print_outcome then Printtyp.wrap_printing_env oldenv (fun () -> match str.str_items with - | [ {str_desc = Tstr_eval (exp, _attrs)} ] -> - let outv = outval_of_value newenv v exp.exp_type in - let ty = Printtyp.tree_of_type_scheme exp.exp_type in - Ophr_eval (outv, ty) | [] -> Ophr_signature [] - | _ -> Ophr_signature (pr_item newenv sg')) + | _ -> + if rewritten then + match sg' with + | [ Sig_value (id, vd) ] -> + let outv = + outval_of_value newenv (toplevel_value id) + vd.val_type + in + let ty = Printtyp.tree_of_type_scheme vd.val_type in + Ophr_eval (outv, ty) + | _ -> assert false + else + Ophr_signature (pr_item newenv sg')) else Ophr_signature [] | Exception exn -> toplevel_env := oldenv; diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml index c44e173e2..3820d26dd 100644 --- a/toplevel/opttopmain.ml +++ b/toplevel/opttopmain.ml @@ -68,7 +68,65 @@ module Options = Main_args.Make_opttop_options (struct include_dirs := dir :: !include_dirs let _init s = init_file := Some s let _noinit = set noinit - let _inline n = inline_threshold := n * 8 + let _clambda_checks () = clambda_checks := true + let _inline spec = + Float_arg_helper.parse spec ~update:inline_threshold + ~help_text:"Syntax: -inline | =[,...]" + let _inline_indirect_cost spec = + Int_arg_helper.parse spec ~update:inline_indirect_cost + ~help_text:"Syntax: -inline-indirect-cost | =[,...]" + let _inline_toplevel spec = + Int_arg_helper.parse spec ~update:inline_toplevel_threshold + ~help_text:"Syntax: -inline-toplevel | =[,...]" + let _inlining_stats () = inlining_stats := true + let _dump_pass pass = set_dumped_pass pass true + let _rounds n = simplify_rounds := n + let _unroll spec = + Int_arg_helper.parse spec ~update:unroll + ~help_text:"Syntax: -unroll | =[,...]" + let _classic_inlining () = classic_inlining := true + let _inline_call_cost spec = + Int_arg_helper.parse spec ~update:inline_call_cost + ~help_text:"Syntax: -inline-call-cost | =[,...]" + let _inline_alloc_cost spec = + Int_arg_helper.parse spec ~update:inline_alloc_cost + ~help_text:"Syntax: -inline-alloc-cost | =[,...]" + let _inline_prim_cost spec = + Int_arg_helper.parse spec ~update:inline_prim_cost + ~help_text:"Syntax: -inline-prim-cost | =[,...]" + let _inline_branch_cost spec = + Int_arg_helper.parse spec ~update:inline_branch_cost + ~help_text:"Syntax: -inline-branch-cost | =[,...]" + let _inline_lifting_benefit spec = + Int_arg_helper.parse spec ~update:inline_lifting_benefit + ~help_text:"Syntax: -inline-lifting-benefit | =[,...]" + let _branch_inline_factor spec = + Float_arg_helper.parse spec ~update:branch_inline_factor + ~help_text:"Syntax: -branch-inline-factor | =[,...]" + let _max_inlining_depth spec = + Int_arg_helper.parse spec ~update:max_inlining_depth + ~help_text:"Syntax: -max-inlining-depth | =[,...]" + let _o s = output_name := Some s + let _o2 () = + simplify_rounds := 2; + use_inlining_arguments_set ~round:1 o1_arguments; + use_inlining_arguments_set ~round:2 o2_arguments + let _o3 () = + simplify_rounds := 3; + use_inlining_arguments_set ~round:1 o1_arguments; + use_inlining_arguments_set ~round:2 o2_arguments; + use_inlining_arguments_set ~round:3 o3_arguments + let _no_inline_recursive_functions = clear inline_recursive_functions + let _remove_unused_arguments = set remove_unused_arguments + let _unbox_closures = set unbox_closures + let _drawclambda = set dump_rawclambda + let _dclambda = set dump_clambda + let _dflambda = set dump_flambda + let _dflambda_let stamp = dump_flambda_let := Some stamp + let _dflambda_verbose () = + set dump_flambda (); + set dump_flambda_verbose () + let _dflambda_invariants = set flambda_invariant_checks let _labels = clear classic let _no_alias_deps = set transparent_modules let _no_app_funct = clear applicative_functors @@ -98,6 +156,7 @@ module Options = Main_args.Make_opttop_options (struct let _dtypedtree = set dump_typedtree let _drawlambda = set dump_rawlambda let _dlambda = set dump_lambda + let _drawclambda = set dump_rawclambda let _dclambda = set dump_clambda let _dcmm = set dump_cmm let _dsel = set dump_selection @@ -121,6 +180,7 @@ module Options = Main_args.Make_opttop_options (struct end);; let main () = + native_code := true; Arg.parse Options.list file_argument usage; if not (prepare Format.err_formatter) then exit 2; Opttoploop.loop Format.std_formatter diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml index 991a42557..efc8158db 100644 --- a/toplevel/topmain.ml +++ b/toplevel/topmain.ml @@ -96,6 +96,7 @@ module Options = Main_args.Make_bytetop_options (struct let _dsource = set dump_source let _drawlambda = set dump_rawlambda let _dlambda = set dump_lambda + let _dflambda = set dump_flambda let _dtimings = set print_timings let _dinstr = set dump_instr diff --git a/typing/env.ml b/typing/env.ml index 3a9398788..82f68d26f 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -97,8 +97,7 @@ end = struct match !x with Thunk a -> Some a | _ -> None let create x = - let x = ref (Thunk x) in - x + ref (Thunk x) end diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 6cffd5afe..2698d6c8a 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -767,7 +767,7 @@ let complete_constrs p all_tags = let build_other_constrs env p = match p.pat_desc with - Tpat_construct (_, {cstr_tag=Cstr_constant _|Cstr_block _}, _) -> + Tpat_construct (_, {cstr_tag=Cstr_constant _|Cstr_block _}, _) -> let get_tag = function | {pat_desc = Tpat_construct (_,c,_)} -> c.cstr_tag | _ -> fatal_error "Parmatch.get_tag" in @@ -976,7 +976,7 @@ let rec satisfiables pss qs = match pss with satisfiables pss (q::qs) | {pat_desc = (Tpat_any | Tpat_var(_))}::qs -> let q0 = discr_pat omega pss in - let wild p = + let wild p = List.map (fun qs -> p::qs) (satisfiables (filter_extra pss) qs) in begin match filter_all q0 pss with (* first column of pss is made of variables only *) @@ -2202,8 +2202,7 @@ let filter_all = to get the definitive list of groups *) let env = filter_rec [] rs in (* then add the omega rows to all groups *) - let env = filter_omega env rs in - env + filter_omega env rs (* Compute stable bindings *) @@ -2216,7 +2215,7 @@ let rec do_stable rs = match rs with match filter_all rs with | [] -> do_stable (List.map snd rs) - | (_,rs)::env -> + | (_,rs)::env -> List.fold_left (fun xs (_,rs) -> IdSet.inter xs (do_stable rs)) (do_stable rs) env @@ -2238,8 +2237,8 @@ let stable p = do_stable [{unseen=[p]; seen=[];}] Not doing so will yield excessive warning in (module (M:S) } ...) when true -> .... - as M is always present in - let module M_mod = unpack M .. in true + as M is always present in + let module M_mod = unpack M .. in true *) let all_rhs_idents exp = @@ -2278,7 +2277,7 @@ let all_rhs_idents exp = let check_ambiguous_bindings = let open Warnings in - let warn0 = Ambiguous_pattern [] in + let warn0 = Ambiguous_pattern [] in fun cases -> if is_active warn0 then List.iter diff --git a/typing/primitive.ml b/typing/primitive.ml index efe55b138..74d6eba1c 100644 --- a/typing/primitive.ml +++ b/typing/primitive.ml @@ -34,6 +34,7 @@ type description = type error = | Old_style_float_with_native_repr_attribute | Old_style_noalloc_with_noalloc_attribute + | No_native_primitive_with_repr_attribute exception Error of Location.t * error @@ -113,6 +114,11 @@ let parse_declaration valdecl ~native_repr_args ~native_repr_res = Location.prerr_warning valdecl.pval_loc (Warnings.Deprecated "[@@noalloc] should be used instead of \ \"noalloc\""); + if native_name = "" && + not (List.for_all is_ocaml_repr native_repr_args && + is_ocaml_repr native_repr_res) then + raise (Error (valdecl.pval_loc, + No_native_primitive_with_repr_attribute)); let noalloc = old_style_noalloc || noalloc_attribute in let native_repr_args, native_repr_res = if old_style_float then @@ -200,6 +206,10 @@ let report_error ppf err = | Old_style_noalloc_with_noalloc_attribute -> Format.fprintf ppf "Cannot use \"noalloc\" in conjunction with \ [%@%@noalloc]" + | No_native_primitive_with_repr_attribute -> + Format.fprintf ppf + "The native code version of the primitive is mandatory when \ + attributes [%@untagged] or [%@unboxed] are present" let () = Location.register_error_of_exn diff --git a/typing/primitive.mli b/typing/primitive.mli index 4d2e89018..5dabc0966 100644 --- a/typing/primitive.mli +++ b/typing/primitive.mli @@ -63,5 +63,6 @@ val byte_name: description -> string type error = | Old_style_float_with_native_repr_attribute | Old_style_noalloc_with_noalloc_attribute + | No_native_primitive_with_repr_attribute exception Error of Location.t * error diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 7bc7c75c0..02ba195f1 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -1437,6 +1437,19 @@ let explanation unif t3 t4 ppf = end | _ -> () + +let warn_on_missing_def env ppf t = + match t.desc with + | Tconstr (p,_,_) -> + begin + try + ignore(Env.find_type p env : Types.type_declaration) + with Not_found -> + fprintf ppf + "@,@[%a is abstract because no corresponding cmi file was found in path.@]" path p + end + | _ -> () + let explanation unif mis ppf = match mis with None -> () @@ -1466,7 +1479,7 @@ let rec trace_same_names = function type_same_name t1 t2; type_same_name t1' t2'; trace_same_names rem | _ -> () -let unification_error unif tr txt1 ppf txt2 = +let unification_error env unif tr txt1 ppf txt2 = reset (); trace_same_names tr; let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in @@ -1490,6 +1503,11 @@ let unification_error unif tr txt1 ppf txt2 = txt2 (type_expansion t2) t2' (trace false "is not compatible with type") tr (explanation unif mis); + if env <> Env.empty + then begin + warn_on_missing_def env ppf t1; + warn_on_missing_def env ppf t2 + end; print_labels := true with exn -> print_labels := true; @@ -1497,7 +1515,7 @@ let unification_error unif tr txt1 ppf txt2 = let report_unification_error ppf env ?(unif=true) tr txt1 txt2 = - wrap_printing_env env (fun () -> unification_error unif tr txt1 ppf txt2) + wrap_printing_env env (fun () -> unification_error env unif tr txt1 ppf txt2) ;; let trace fst keep_last txt ppf tr = diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 0597a0dd1..c5965caba 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -980,9 +980,7 @@ and class_expr cl_num val_env met_env scl = cl_attributes = scl.pcl_attributes; } | Pcl_apply (scl', sargs) -> - if sargs = [] then - Syntaxerr.ill_formed_ast scl.pcl_loc - "Function application with no argument."; + assert (sargs <> []); if !Clflags.principal then Ctype.begin_def (); let cl = class_expr cl_num val_env met_env scl' in if !Clflags.principal then begin diff --git a/typing/typecore.ml b/typing/typecore.ml index d2e86f8ee..62835302e 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -265,31 +265,31 @@ let type_constant = function | Const_nativeint _ -> instance_def Predef.type_nativeint let constant : Parsetree.constant -> (Asttypes.constant, error) result = function - | PConst_int (i,None) -> + | Pconst_integer (i,None) -> begin try Ok (Const_int (Misc.Int_literal_converter.int i)) with Failure _ -> Error (Literal_overflow "int") end - | PConst_int (i,Some 'l') -> + | Pconst_integer (i,Some 'l') -> begin try Ok (Const_int32 (Misc.Int_literal_converter.int32 i)) with Failure _ -> Error (Literal_overflow "int32") end - | PConst_int (i,Some 'L') -> + | Pconst_integer (i,Some 'L') -> begin try Ok (Const_int64 (Misc.Int_literal_converter.int64 i)) with Failure _ -> Error (Literal_overflow "int64") end - | PConst_int (i,Some 'n') -> + | Pconst_integer (i,Some 'n') -> begin try Ok (Const_nativeint (Misc.Int_literal_converter.nativeint i)) with Failure _ -> Error (Literal_overflow "nativeint") end - | PConst_int (i,Some c) -> Error (Unknown_literal (i, c)) - | PConst_char c -> Ok (Const_char c) - | PConst_string (s,d) -> Ok (Const_string (s,d)) - | PConst_float (f,None)-> Ok (Const_float f) - | PConst_float (f,Some c) -> Error (Unknown_literal (f, c)) + | Pconst_integer (i,Some c) -> Error (Unknown_literal (i, c)) + | Pconst_char c -> Ok (Const_char c) + | Pconst_string (s,d) -> Ok (Const_string (s,d)) + | Pconst_float (f,None)-> Ok (Const_float f) + | Pconst_float (f,Some c) -> Error (Unknown_literal (f, c)) let constant_or_raise env loc cst = match constant cst with @@ -1070,14 +1070,14 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env pat_type = expected_ty; pat_attributes = sp.ppat_attributes; pat_env = !env } - | Ppat_interval (PConst_char c1, PConst_char c2) -> + | Ppat_interval (Pconst_char c1, Pconst_char c2) -> let open Ast_helper.Pat in let gloc = {loc with Location.loc_ghost=true} in let rec loop c1 c2 = - if c1 = c2 then constant ~loc:gloc (PConst_char c1) + if c1 = c2 then constant ~loc:gloc (Pconst_char c1) else or_ ~loc:gloc - (constant ~loc:gloc (PConst_char c1)) + (constant ~loc:gloc (Pconst_char c1)) (loop (Char.chr(Char.code c1 + 1)) c2) in let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in @@ -1087,8 +1087,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env | Ppat_interval _ -> raise (Error (loc, !env, Invalid_interval)) | Ppat_tuple spl -> - if List.length spl < 2 then - Syntaxerr.ill_formed_ast loc "Tuples must have at least 2 components."; + assert (List.length spl >= 2); let spl_ann = List.map (fun p -> (p,newvar ())) spl in let ty = newty (Ttuple(List.map snd spl_ann)) in unify_pat_types loc !env ty expected_ty; @@ -1210,8 +1209,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env | _ -> k None end | Ppat_record(lid_sp_list, closed) -> - if lid_sp_list = [] then - Syntaxerr.ill_formed_ast loc "Records cannot be empty."; + assert (lid_sp_list <> []); let opath, record_ty = try let (p0, p,_) = extract_concrete_record !env expected_ty in @@ -1866,12 +1864,33 @@ let duplicate_ident_types loc caselist env = to keep the same internal 'slot' to track unused opens. *) List.fold_left (fun env s -> Env.update_value s upd env) env idents + +(* Getting proper location of already typed expressions. + + Used to avoid confusing locations on type error messages in presence of + type constraints. + For example: + + (* Before patch *) + # let x : string = (5 : int);; + ^ + (* After patch *) + # let x : string = (5 : int);; + ^^^^^^^^^ +*) +let proper_exp_loc exp = + let rec aux = function + | [] -> exp.exp_loc + | ((Texp_constraint _ | Texp_coerce _), loc, _) :: _ -> loc + | _ :: rest -> aux rest + in + aux exp.exp_extra + (* Typing of expressions *) let unify_exp env exp expected_ty = - (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type - Printtyp.raw_type_expr expected_ty; *) - unify_exp_types exp.exp_loc env exp.exp_type expected_ty + let loc = proper_exp_loc exp in + unify_exp_types loc env exp.exp_type expected_ty let rec type_exp ?recarg env sexp = (* We now delegate everything to type_expect *) @@ -1948,7 +1967,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = exp_attributes = sexp.pexp_attributes; exp_env = env } end - | Pexp_constant(PConst_string (str, _) as cst) -> ( + | Pexp_constant(Pconst_string (str, _) as cst) -> ( let cst = constant_or_raise env loc cst in (* Terrible hack for format strings *) let ty_exp = expand_head env ty_expected in @@ -2044,8 +2063,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = type_function ?in_function loc sexp.pexp_attributes env ty_expected Nolabel caselist | Pexp_apply(sfunct, sargs) -> - if sargs = [] then - Syntaxerr.ill_formed_ast loc "Function application with no argument."; + assert (sargs <> []); begin_def (); (* one more level for non-returning functions *) if !Clflags.principal then begin_def (); let funct = type_exp env sfunct in @@ -2115,8 +2133,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_tuple sexpl -> - if List.length sexpl < 2 then - Syntaxerr.ill_formed_ast loc "Tuples must have at least 2 components."; + assert (List.length sexpl >= 2); let subtypes = List.map (fun _ -> newgenvar ()) sexpl in let to_unify = newgenty (Ttuple subtypes) in unify_exp_types loc env to_unify ty_expected; @@ -2167,8 +2184,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = exp_env = env } end | Pexp_record(lid_sexp_list, opt_sexp) -> - if lid_sexp_list = [] then - Syntaxerr.ill_formed_ast loc "Records cannot be empty."; + assert (lid_sexp_list <> []); let opt_exp = match opt_sexp with None -> None @@ -2990,9 +3006,9 @@ and type_format loc str env = | _ :: _ :: _ -> Some (mk_exp_loc (Pexp_tuple args)) in mk_exp_loc (Pexp_construct (mk_lid_loc lid, arg)) in let mk_cst cst = mk_exp_loc (Pexp_constant cst) in - let mk_int n = mk_cst (PConst_int (string_of_int n, None)) - and mk_string str = mk_cst (PConst_string (str, None)) - and mk_char chr = mk_cst (PConst_char chr) in + let mk_int n = mk_cst (Pconst_integer (string_of_int n, None)) + and mk_string str = mk_cst (Pconst_string (str, None)) + and mk_char chr = mk_cst (Pconst_char chr) in let rec mk_formatting_lit fmting = match fmting with | Close_box -> mk_constr "Close_box" [] diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 1b9f1011e..15f89d702 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -50,6 +50,7 @@ type error = | Val_in_structure | Multiple_native_repr_attributes | Cannot_unbox_or_untag_type of native_repr_kind + | Deep_unbox_or_untag_attribute of native_repr_kind open Typedtree @@ -152,8 +153,7 @@ let make_params env params = List.map make_param params let transl_labels loc env closed lbls = - if lbls = [] then - Syntaxerr.ill_formed_ast loc "Records cannot be empty."; + assert (lbls <> []); let all_labels = ref StringSet.empty in List.iter (fun {pld_name = {txt=name; loc}} -> @@ -237,9 +237,7 @@ let transl_declaration env sdecl id = match sdecl.ptype_kind with Ptype_abstract -> Ttype_abstract, Type_abstract | Ptype_variant scstrs -> - if scstrs = [] then - Syntaxerr.ill_formed_ast sdecl.ptype_loc - "Variant types cannot be empty."; + assert (scstrs <> []); let all_constrs = ref StringSet.empty in List.iter (fun {pcd_name = {txt = name}} -> @@ -1393,9 +1391,29 @@ let native_repr_of_type env kind ty = | _ -> None +(* Raises an error when [core_type] contains an [@unboxed] or [@untagged] + attribute in a strict sub-term. *) +let error_if_has_deep_native_repr_attributes core_type = + let open Ast_iterator in + let this_iterator = + { default_iterator with typ = fun iterator core_type -> + begin + match + get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None + with + | Native_repr_attr_present kind -> + raise (Error (core_type.ptyp_loc, Deep_unbox_or_untag_attribute kind)) + | Native_repr_attr_absent -> () + end; + default_iterator.typ iterator core_type } + in + default_iterator.typ this_iterator core_type + let make_native_repr env core_type ty ~global_repr = + error_if_has_deep_native_repr_attributes core_type; match get_native_repr_attribute core_type.ptyp_attributes ~global_repr with - | Native_repr_attr_absent -> Same_as_ocaml_repr + | Native_repr_attr_absent -> + Same_as_ocaml_repr | Native_repr_attr_present kind -> begin match native_repr_of_type env kind ty with | None -> @@ -1404,14 +1422,18 @@ let make_native_repr env core_type ty ~global_repr = end let rec parse_native_repr_attributes env core_type ty ~global_repr = - match core_type.ptyp_desc, (Ctype.repr ty).desc with - | Ptyp_arrow (_, ct1, ct2), Tarrow (_, t1, t2, _) -> + match core_type.ptyp_desc, (Ctype.repr ty).desc, + get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None + with + | Ptyp_arrow _, Tarrow _, Native_repr_attr_present kind -> + raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind)) + | Ptyp_arrow (_, ct1, ct2), Tarrow (_, t1, t2, _), _ -> let repr_arg = make_native_repr env ct1 t1 ~global_repr in let repr_args, repr_res = parse_native_repr_attributes env ct2 t2 ~global_repr in (repr_arg :: repr_args, repr_res) - | Ptyp_arrow _, _ | _, Tarrow _ -> assert false + | Ptyp_arrow _, _, _ | _, Tarrow _, _ -> assert false | _ -> ([], make_native_repr env core_type ty ~global_repr) (* Translate a value declaration *) @@ -1799,6 +1821,11 @@ let report_error ppf = function | Cannot_unbox_or_untag_type Untagged -> fprintf ppf "Don't know how to untag this type. Only int \ can be untagged" + | Deep_unbox_or_untag_attribute kind -> + fprintf ppf + "The attribute '%s' should be attached to a direct argument or \ + result of the primitive, it should not occur deeply into its type" + (match kind with Unboxed -> "@unboxed" | Untagged -> "@untagged") let () = Location.register_error_of_exn diff --git a/typing/typedecl.mli b/typing/typedecl.mli index 7b0bdb6b6..b0d0de0d1 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -87,6 +87,7 @@ type error = | Val_in_structure | Multiple_native_repr_attributes | Cannot_unbox_or_untag_type of native_repr_kind + | Deep_unbox_or_untag_attribute of native_repr_kind exception Error of Location.t * error diff --git a/typing/typemod.ml b/typing/typemod.ml index a45f8281e..7a81c8343 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -1465,8 +1465,8 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let type_toplevel_phrase env s = Env.reset_required_globals (); begin - let map = Builtin_attributes.emit_external_warnings in - ignore (map.Ast_mapper.structure map s) + let iter = Builtin_attributes.emit_external_warnings in + iter.Ast_iterator.structure iter s end; type_structure ~toplevel:true false None env s Location.none let type_module_alias = type_module ~alias:true true false None @@ -1570,8 +1570,8 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = Typecore.reset_delayed_checks (); Env.reset_required_globals (); begin - let map = Builtin_attributes.emit_external_warnings in - ignore (map.Ast_mapper.structure map ast) + let iter = Builtin_attributes.emit_external_warnings in + iter.Ast_iterator.structure iter ast end; let (str, sg, finalenv) = @@ -1639,8 +1639,8 @@ let save_signature modname tsg outputprefix source_file initial_env cmi = let type_interface env ast = begin - let map = Builtin_attributes.emit_external_warnings in - ignore (map.Ast_mapper.signature map ast) + let iter = Builtin_attributes.emit_external_warnings in + iter.Ast_iterator.signature iter ast end; transl_signature env ast diff --git a/typing/typetexp.ml b/typing/typetexp.ml index ffe108afd..0dbad0356 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -155,11 +155,8 @@ let find_value env loc lid = r let lookup_module ?(load=false) env loc lid = - let (path, decl) as r = - find_component (fun ?loc lid env -> (Env.lookup_module ~load ?loc lid env, ())) - (fun lid -> Unbound_module lid) env loc lid - in - path + find_component (fun ?loc lid env -> (Env.lookup_module ~load ?loc lid env)) + (fun lid -> Unbound_module lid) env loc lid let find_module env loc lid = let path = lookup_module ~load:true env loc lid in @@ -334,8 +331,7 @@ let rec transl_type env policy styp = let ty = newty (Tarrow(l, ty1, cty2.ctyp_type, Cok)) in ctyp (Ttyp_arrow (l, cty1, cty2)) ty | Ptyp_tuple stl -> - if List.length stl < 2 then - Syntaxerr.ill_formed_ast loc "Tuples must have at least 2 components."; + assert (List.length stl >= 2); let ctys = List.map (transl_type env policy) stl in let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in ctyp (Ttyp_tuple ctys) ty diff --git a/typing/untypeast.ml b/typing/untypeast.ml index 4fd29d4b4..67605436b 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -113,13 +113,13 @@ let fresh_name s env = (** Mapping functions. *) let constant = function - | Const_char c -> PConst_char c - | Const_string (s,d) -> PConst_string (s,d) - | Const_int i -> PConst_int (string_of_int i, None) - | Const_int32 i -> PConst_int (Int32.to_string i, Some 'l') - | Const_int64 i -> PConst_int (Int64.to_string i, Some 'L') - | Const_nativeint i -> PConst_int (Nativeint.to_string i, Some 'n') - | Const_float f -> PConst_float (f,None) + | Const_char c -> Pconst_char c + | Const_string (s,d) -> Pconst_string (s,d) + | Const_int i -> Pconst_integer (string_of_int i, None) + | Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l') + | Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L') + | Const_nativeint i -> Pconst_integer (Nativeint.to_string i, Some 'n') + | Const_float f -> Pconst_float (f,None) let attribute sub (s, p) = (map_loc sub s, p) let attributes sub l = List.map (sub.attribute sub) l diff --git a/utils/arg_helper.ml b/utils/arg_helper.ml new file mode 100644 index 000000000..bfbd1870a --- /dev/null +++ b/utils/arg_helper.ml @@ -0,0 +1,103 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2015--2016 OCamlPro SAS *) +(* Copyright 2015--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file ../LICENSE. *) +(* *) +(**************************************************************************) + +let fatal err = + prerr_endline err; + exit 2 + +module Make (S : sig + module Key : sig + type t + val of_string : string -> t + module Map : Map.S with type key = t + end + + module Value : sig + type t + val of_string : string -> t + end +end) = struct + type parsed = { + default : S.Value.t; + override : S.Value.t S.Key.Map.t; + } + + let default v = { default = v; override = S.Key.Map.empty } + + let no_equals value = + match String.index value '=' with + | exception Not_found -> true + | _index -> false + + exception Parse_failure of exn + + let parse_exn str ~update = + let values = Misc.Stdlib.String.split str ~on:',' in + let parsed = + List.fold_left (fun acc value -> + match String.index value '=' with + | exception Not_found -> + begin match S.Value.of_string value with + | value -> { acc with default = value } + | exception exn -> raise (Parse_failure exn) + end + | equals -> + let key_value_pair = value in + let length = String.length key_value_pair in + assert (equals >= 0 && equals < length); + if equals = 0 then begin + raise (Parse_failure ( + Failure "Missing key in argument specification")) + end; + let key = + let key = String.sub key_value_pair 0 equals in + try S.Key.of_string key + with exn -> raise (Parse_failure exn) + in + let value = + let value = + String.sub key_value_pair (equals + 1) (length - equals - 1) + in + try S.Value.of_string value + with exn -> raise (Parse_failure exn) + in + { acc with override = S.Key.Map.add key value acc.override }) + !update + values + in + update := parsed + + let parse str ~help_text ~update = + match parse_exn str ~update with + | () -> () + | exception (Parse_failure exn) -> + fatal (Printf.sprintf "%s: %s" (Printexc.to_string exn) help_text) + + type parse_result = + | Ok + | Parse_failed of exn + + let parse_no_error str ~update = + match parse_exn str ~update with + | () -> Ok + | exception (Parse_failure exn) -> Parse_failed exn + + let get ~key parsed = + match S.Key.Map.find key parsed.override with + | provided -> provided + | exception Not_found -> + parsed.default +end diff --git a/utils/arg_helper.mli b/utils/arg_helper.mli new file mode 100644 index 000000000..75258daa7 --- /dev/null +++ b/utils/arg_helper.mli @@ -0,0 +1,56 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2015--2016 OCamlPro SAS *) +(* Copyright 2015--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file ../LICENSE. *) +(* *) +(**************************************************************************) + +(** Decipher command line arguments of the form + | =[,...] + (as used for example for the specification of inlining parameters + varying by simplification round). +*) + +module Make (S : sig + module Key : sig + type t + + (** The textual representation of a key must not contain '=' or ','. *) + val of_string : string -> t + + module Map : Map.S with type key = t + end + + module Value : sig + type t + + (** The textual representation of a value must not contain ','. *) + val of_string : string -> t + end +end) : sig + type parsed = { + default : S.Value.t; + override : S.Value.t S.Key.Map.t; + } + + val default : S.Value.t -> parsed + + val parse : string -> help_text:string -> update:parsed ref -> unit + + type parse_result = + | Ok + | Parse_failed of exn + + val parse_no_error : string -> update:parsed ref -> parse_result + + val get : key:S.Key.t -> parsed -> S.Value.t +end diff --git a/utils/ccomp.ml b/utils/ccomp.ml index f8b840497..a45014255 100644 --- a/utils/ccomp.ml +++ b/utils/ccomp.ml @@ -48,25 +48,59 @@ let quote_optfile = function | None -> "" | Some f -> Filename.quote f +let display_msvc_output file name = + let c = open_in file in + try + let first = input_line c in + if first <> Filename.basename name then + print_string first; + while true do + print_string (input_line c) + done + with _ -> + close_in c; + Sys.remove file + let compile_file ~output_name name = - command - (Printf.sprintf - "%s%s -c %s %s %s %s %s" - (match !Clflags.c_compiler with - | Some cc -> cc - | None -> - if !Clflags.native_code - then Config.native_c_compiler - else Config.bytecomp_c_compiler) - (match output_name, Config.ccomp_type with - | Some n, "msvc" -> " /Fo" ^ Filename.quote n - | Some n, _ -> " -o " ^ Filename.quote n - | None, _ -> "") - (if !Clflags.debug && Config.ccomp_type <> "msvc" then "-g" else "") - (String.concat " " (List.rev !Clflags.all_ccopts)) - (quote_prefixed "-I" (List.rev !Clflags.include_dirs)) - (Clflags.std_include_flag "-I") - (Filename.quote name)) + let (pipe, file) = + if Config.ccomp_type = "msvc" && not !Clflags.verbose then + try + let (t, c) = Filename.open_temp_file "msvc" "stdout" in + close_out c; + (Printf.sprintf " > %s" (Filename.quote t), t) + with _ -> + ("", "") + else + ("", "") in + let exit = + command + (Printf.sprintf + "%s%s -c %s %s %s %s %s%s" + (match !Clflags.c_compiler with + | Some cc -> cc + | None -> + if !Clflags.native_code + then Config.native_c_compiler + else Config.bytecomp_c_compiler) + (match output_name, Config.ccomp_type with + | Some n, "msvc" -> " /Fo" ^ Filename.quote n + | Some n, _ -> " -o " ^ Filename.quote n + | None, _ -> "") + (if !Clflags.debug && Config.ccomp_type <> "msvc" then "-g" else "") + (String.concat " " (List.rev !Clflags.all_ccopts)) + (quote_prefixed "-I" (List.rev !Clflags.include_dirs)) + (Clflags.std_include_flag "-I") + (Filename.quote name) + (* cl tediously includes the name of the C file as the first thing it + outputs (in fairness, the tedious thing is that there's no switch to + disable this behaviour). In the absence of the Unix module, use + a temporary file to filter the output (cannot pipe the output to a + filter because this removes the exit status of cl, which is wanted. + *) + pipe) in + if pipe <> "" + then display_msvc_output file name; + exit let create_archive archive file_list = Misc.remove_file archive; diff --git a/utils/clflags.ml b/utils/clflags.ml index af1fa5c4b..f63284b49 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -12,6 +12,29 @@ (* Command-line parameters *) +module Int_arg_helper = Arg_helper.Make (struct + module Key = struct + include Numbers.Int + let of_string = int_of_string + end + + module Value = struct + include Numbers.Int + let of_string = int_of_string + end +end) +module Float_arg_helper = Arg_helper.Make (struct + module Key = struct + include Numbers.Int + let of_string = int_of_string + end + + module Value = struct + include Numbers.Float + let of_string = float_of_string + end +end) + let objfiles = ref ([] : string list) (* .cmo and .cma files *) and ccobjs = ref ([] : string list) (* .o, .a, .so and -cclib -lxxx *) and dllibs = ref ([] : string list) (* .so and -dllib -lxxx *) @@ -69,7 +92,11 @@ let dump_parsetree = ref false (* -dparsetree *) and dump_typedtree = ref false (* -dtypedtree *) and dump_rawlambda = ref false (* -drawlambda *) and dump_lambda = ref false (* -dlambda *) +and dump_rawclambda = ref false (* -drawclambda *) and dump_clambda = ref false (* -dclambda *) +and dump_flambda = ref false (* -dflambda *) +and dump_flambda_let = ref (None : int option) (* -dflambda-let=... *) +and dump_flambda_verbose = ref false (* -dflambda-verbose *) and dump_instr = ref false (* -dinstr *) let keep_asm_file = ref false (* -S *) @@ -91,8 +118,16 @@ let dump_linear = ref false (* -dlinear *) let keep_startup_file = ref false (* -dstartup *) let dump_combine = ref false (* -dcombine *) let native_code = ref false (* set to true under ocamlopt *) -let inline_threshold = ref 10 +let o2 = ref false (* -O2 *) +let o3 = ref false (* -O3 *) +let default_inline_threshold = if Config.flambda then 10. else 10. /. 8. +let inline_threshold = ref (Float_arg_helper.default default_inline_threshold) +let inlining_stats = ref false +let simplify_rounds = ref 1 +let default_unroll = 0 +let unroll = ref (Int_arg_helper.default default_unroll) let force_slash = ref false (* for ocamldep *) +let clambda_checks = ref false (* -clambda-checks *) let dont_write_files = ref false (* set to true under ocamldoc *) @@ -117,7 +152,181 @@ let runtime_variant = ref "";; (* -runtime-variant *) let keep_docs = ref false (* -keep-docs *) let keep_locs = ref false (* -keep-locs *) let unsafe_string = ref true;; (* -safe-string / -unsafe-string *) -let print_timings = ref false (* -dtimings *) + +let inline_toplevel_multiplier = 16 +let default_inline_toplevel_threshold = + int_of_float ((float inline_toplevel_multiplier) *. default_inline_threshold) +let inline_toplevel_threshold = + ref (Int_arg_helper.default default_inline_toplevel_threshold) + +let default_inline_call_cost = 5 +let default_inline_alloc_cost = 3 +let default_inline_prim_cost = 3 +let default_inline_branch_cost = 3 +let default_inline_indirect_cost = 2 +let default_branch_inline_factor = 0.1 +let default_inline_lifting_benefit = 1300 + +let inline_call_cost = ref (Int_arg_helper.default default_inline_call_cost) +let inline_alloc_cost = ref (Int_arg_helper.default default_inline_alloc_cost) +let inline_prim_cost = ref (Int_arg_helper.default default_inline_prim_cost) +let inline_branch_cost = + ref (Int_arg_helper.default default_inline_branch_cost) +let inline_indirect_cost = + ref (Int_arg_helper.default default_inline_indirect_cost) +let branch_inline_factor = + ref (Float_arg_helper.default default_branch_inline_factor) +let inline_lifting_benefit = + ref (Int_arg_helper.default default_inline_lifting_benefit) + +let print_timings = ref false (* -timings *) + +let unbox_closures = ref false (* -unbox-closures *) +let remove_unused_arguments = ref false (* -remove-unused-arguments *) +let inline_recursive_functions = ref true (* -no-inline-recursive-functions *) + +let classic_inlining = ref false (* -classic-inlining *) + +let default_max_inlining_depth = 1 +let max_inlining_depth = + ref (Int_arg_helper.default default_max_inlining_depth) + +type inlining_arguments = { + inline_call_cost : int option; + inline_alloc_cost : int option; + inline_prim_cost : int option; + inline_branch_cost : int option; + inline_indirect_cost : int option; + inline_lifting_benefit : int option; + branch_inline_factor : float option; + max_inlining_depth : int option; + unroll : int option; + inline_threshold : float option; + inline_toplevel_threshold : int option; +} + +let set_int_arg round (arg:Int_arg_helper.parsed ref) value = + let open Int_arg_helper in + match value with + | None -> () + | Some value -> + let parsed = + match round with + | None -> { !arg with default = value } + | Some round -> + { !arg with + override = Numbers.Int.Map.add round value !arg.override } + in + arg := parsed + +let set_float_arg round (arg:Float_arg_helper.parsed ref) value = + let open Float_arg_helper in + match value with + | None -> () + | Some value -> + let parsed = + match round with + | None -> { !arg with default = value } + | Some round -> + { !arg with + override = Numbers.Int.Map.add round value !arg.override } + in + arg := parsed + +let use_inlining_arguments_set ?round (arg:inlining_arguments) = + let set_int = set_int_arg round in + let set_float = set_float_arg round in + set_int inline_call_cost arg.inline_call_cost; + set_int inline_alloc_cost arg.inline_alloc_cost; + set_int inline_prim_cost arg.inline_prim_cost; + set_int inline_branch_cost arg.inline_branch_cost; + set_int inline_indirect_cost arg.inline_indirect_cost; + set_int inline_lifting_benefit arg.inline_lifting_benefit; + set_float branch_inline_factor arg.branch_inline_factor; + set_int max_inlining_depth arg.max_inlining_depth; + set_int unroll arg.unroll; + set_float inline_threshold arg.inline_threshold; + set_int inline_toplevel_threshold arg.inline_toplevel_threshold + +(* o1 is the default *) +let o1_arguments = { + inline_call_cost = None; + inline_alloc_cost = None; + inline_prim_cost = None; + inline_branch_cost = None; + inline_indirect_cost = None; + inline_lifting_benefit = None; + branch_inline_factor = None; + max_inlining_depth = None; + unroll = None; + inline_threshold = None; + inline_toplevel_threshold = None; +} + +let classic_arguments = { + inline_call_cost = None; + inline_alloc_cost = None; + inline_prim_cost = None; + inline_branch_cost = None; + inline_indirect_cost = None; + inline_lifting_benefit = None; + branch_inline_factor = None; + max_inlining_depth = None; + unroll = None; + (* [inline_threshold] matches the current compiler's default. + Note that this particular fraction can be expressed exactly in + floating point. *) + inline_threshold = Some (10. /. 8.); + (* [inline_toplevel_threshold] is not used in classic mode. *) + inline_toplevel_threshold = Some 1; +} + +let o2_arguments = { + inline_call_cost = Some (2 * default_inline_call_cost); + inline_alloc_cost = Some (2 * default_inline_alloc_cost); + inline_prim_cost = Some (2 * default_inline_prim_cost); + inline_branch_cost = Some (2 * default_inline_branch_cost); + inline_indirect_cost = Some (2 * default_inline_indirect_cost); + inline_lifting_benefit = None; + branch_inline_factor = None; + max_inlining_depth = Some 2; + unroll = None; + inline_threshold = Some 25.; + inline_toplevel_threshold = Some (25 * inline_toplevel_multiplier); +} + +let o3_arguments = { + inline_call_cost = Some (3 * default_inline_call_cost); + inline_alloc_cost = Some (3 * default_inline_alloc_cost); + inline_prim_cost = Some (3 * default_inline_prim_cost); + inline_branch_cost = Some (3 * default_inline_branch_cost); + inline_indirect_cost = Some (3 * default_inline_indirect_cost); + inline_lifting_benefit = None; + branch_inline_factor = Some 0.; + max_inlining_depth = Some 3; + unroll = Some 1; + inline_threshold = Some 50.; + inline_toplevel_threshold = Some (50 * inline_toplevel_multiplier); +} + +let all_passes = ref [] +let dumped_passes_list = ref [] +let dumped_pass s = + assert(List.mem s !all_passes); + List.mem s !dumped_passes_list + +let set_dumped_pass s enabled = + assert(List.mem s !all_passes); + let passes_without_s = List.filter ((<>) s) !dumped_passes_list in + let dumped_passes = + if enabled then + s :: passes_without_s + else + passes_without_s + in + dumped_passes_list := dumped_passes + +let flambda_invariant_checks = ref false let parse_color_setting = function | "auto" -> Some Misc.Color.Auto diff --git a/utils/clflags.mli b/utils/clflags.mli index a30adde71..08cf340ab 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -10,6 +10,63 @@ (* *) (***********************************************************************) +(** Optimization parameters represented as ints indexed by round number. *) +module Int_arg_helper : sig + type parsed = { + default : int; + override : int Numbers.Int.Map.t; + } + + val parse : string -> help_text:string -> update:parsed ref -> unit + + type parse_result = + | Ok + | Parse_failed of exn + val parse_no_error : string -> update:parsed ref -> parse_result + + val get : key:int -> parsed -> int +end + +(** Optimization parameters represented as floats indexed by round number. *) +module Float_arg_helper : sig + type parsed = { + default : float; + override : float Numbers.Int.Map.t; + } + + val parse : string -> help_text:string -> update:parsed ref -> unit + + type parse_result = + | Ok + | Parse_failed of exn + val parse_no_error : string -> update:parsed ref -> parse_result + + val get : key:int -> parsed -> float +end + +type inlining_arguments = { + inline_call_cost : int option; + inline_alloc_cost : int option; + inline_prim_cost : int option; + inline_branch_cost : int option; + inline_indirect_cost : int option; + inline_lifting_benefit : int option; + branch_inline_factor : float option; + max_inlining_depth : int option; + unroll : int option; + inline_threshold : float option; + inline_toplevel_threshold : int option; +} + +val classic_arguments : inlining_arguments +val o1_arguments : inlining_arguments +val o2_arguments : inlining_arguments +val o3_arguments : inlining_arguments + +(** Set all the inlining arguments for a round. + The default is set if no round is provided. *) +val use_inlining_arguments_set : ?round:int -> inlining_arguments -> unit + val objfiles : string list ref val ccobjs : string list ref val dllibs : string list ref @@ -66,7 +123,10 @@ val dump_parsetree : bool ref val dump_typedtree : bool ref val dump_rawlambda : bool ref val dump_lambda : bool ref +val dump_rawclambda : bool ref val dump_clambda : bool ref +val dump_flambda : bool ref +val dump_flambda_let : int option ref val dump_instr : bool ref val keep_asm_file : bool ref val optimize_for_speed : bool ref @@ -85,7 +145,30 @@ val dump_linear : bool ref val keep_startup_file : bool ref val dump_combine : bool ref val native_code : bool ref -val inline_threshold : int ref +val o2 : bool ref +val o3 : bool ref +val default_inline_threshold : float +val inline_threshold : Float_arg_helper.parsed ref +val inlining_stats : bool ref +val simplify_rounds : int ref +val default_unroll : int +val unroll : Int_arg_helper.parsed ref +val default_inline_toplevel_threshold : int +val inline_toplevel_threshold : Int_arg_helper.parsed ref +val default_inline_call_cost : int +val default_inline_alloc_cost : int +val default_inline_prim_cost : int +val default_inline_branch_cost : int +val default_inline_indirect_cost : int +val default_inline_lifting_benefit : int +val inline_call_cost : Int_arg_helper.parsed ref +val inline_alloc_cost : Int_arg_helper.parsed ref +val inline_prim_cost : Int_arg_helper.parsed ref +val inline_branch_cost : Int_arg_helper.parsed ref +val inline_indirect_cost : Int_arg_helper.parsed ref +val inline_lifting_benefit : Int_arg_helper.parsed ref +val default_branch_inline_factor : float +val branch_inline_factor : Float_arg_helper.parsed ref val dont_write_files : bool ref val std_include_flag : string -> string val std_include_dir : unit -> string list @@ -99,6 +182,19 @@ val keep_locs : bool ref val unsafe_string : bool ref val opaque : bool ref val print_timings : bool ref +val flambda_invariant_checks : bool ref +val unbox_closures : bool ref +val clambda_checks : bool ref +val default_max_inlining_depth : int +val max_inlining_depth : Int_arg_helper.parsed ref +val inline_recursive_functions : bool ref +val remove_unused_arguments : bool ref +val dump_flambda_verbose : bool ref +val classic_inlining : bool ref + +val all_passes : string list ref +val dumped_pass : string -> bool +val set_dumped_pass : string -> bool -> unit val parse_color_setting : string -> Misc.Color.setting option val color : Misc.Color.setting ref diff --git a/utils/config.mli b/utils/config.mli index c9b8904d7..5fc56d660 100644 --- a/utils/config.mli +++ b/utils/config.mli @@ -127,3 +127,6 @@ val target : string (* Whether the compiler is a cross-compiler *) val print_config : out_channel -> unit;; + +val flambda : bool + (* Whether the compiler was configured for flambda *) diff --git a/utils/config.mlp b/utils/config.mlp index 09f639cd8..e5af4d79d 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -44,16 +44,40 @@ let native_pack_linker = "%%PACKLD%%" let ranlib = "%%RANLIBCMD%%" let ar = "%%ARCMD%%" let cc_profile = "%%CC_PROFILE%%" -let mkdll = "%%MKDLL%%" -let mkexe = "%%MKEXE%%" -let mkmaindll = "%%MKMAINDLL%%" +let mkdll, mkexe, mkmaindll = + (* @@DRA Cygwin - but only if shared libraries are enabled, which we should be able to detect? *) + if Sys.os_type = "Win32" then + try + let flexlink = + let flexlink = Sys.getenv "OCAML_FLEXLINK" in + let f i = + let c = flexlink.[i] in + if c = '/' then '\\' else c in + (String.init (String.length flexlink) f) ^ " %%FLEXLINK_FLAGS%%" in + flexlink, + flexlink ^ " -exe", + flexlink ^ " -maindll" + with Not_found -> + "%%MKDLL%%", "%%MKEXE%%", "%%MKMAINDLL%%" + else + "%%MKDLL%%", "%%MKEXE%%", "%%MKMAINDLL%%" + +let flambda = %%FLAMBDA%% let exec_magic_number = "Caml1999X011" and cmi_magic_number = "Caml1999I020" and cmo_magic_number = "Caml1999O011" and cma_magic_number = "Caml1999A012" -and cmx_magic_number = "Caml1999Y015" -and cmxa_magic_number = "Caml1999Z014" +and cmx_magic_number = + if flambda then + "Caml1999Y016" + else + "Caml1999Y015" +and cmxa_magic_number = + if flambda then + "Caml1999Z015" + else + "Caml1999Z014" and ast_impl_magic_number = "Caml1999M019" and ast_intf_magic_number = "Caml1999N018" and cmxs_magic_number = "Caml2007D002" @@ -126,6 +150,7 @@ let print_config oc = p_bool "systhread_supported" systhread_supported; p "host" host; p "target" target; + p_bool "flambda" flambda; (* print the magic number *) p "exec_magic_number" exec_magic_number; diff --git a/utils/misc.ml b/utils/misc.ml index 98aee6178..79fe83243 100644 --- a/utils/misc.ml +++ b/utils/misc.ml @@ -628,3 +628,10 @@ module Color = struct ); () end + +let normalise_eol s = + let b = Buffer.create 80 in + for i = 0 to String.length s - 1 do + if s.[i] <> '\r' then Buffer.add_char b s.[i] + done; + Buffer.contents b diff --git a/utils/misc.mli b/utils/misc.mli index 235b782ed..3ae72ac2c 100644 --- a/utils/misc.mli +++ b/utils/misc.mli @@ -295,3 +295,8 @@ module Color : sig val set_color_tag_handling : Format.formatter -> unit (* adds functions to support color tags to the given formatter. *) end + +val normalise_eol : string -> string +(** [normalise_eol s] returns a fresh copy of [s] with any '\r' characters + removed. Intended for pre-processing text which will subsequently be printed + on a channel which performs EOL transformations (i.e. Windows) *) diff --git a/utils/warnings.ml b/utils/warnings.ml index 3166e7859..14001d756 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -76,6 +76,7 @@ type t = | Unreachable_case (* 56 *) | Ambiguous_pattern of string list (* 57 *) | No_cmx_file of string (* 58 *) + | Assignment_to_non_mutable_value (* 59 *) ;; (* If you remove a warning, leave a hole in the numbering. NEVER change @@ -143,10 +144,12 @@ let number = function | Unreachable_case -> 56 | Ambiguous_pattern _ -> 57 | No_cmx_file _ -> 58 + | Assignment_to_non_mutable_value -> 59 ;; -let last_warning_number = 58 +let last_warning_number = 59 ;; + (* Must be the max number returned by the [number] function. *) let letter = function @@ -268,7 +271,14 @@ let () = parse_options true defaults_warn_error;; let message = function | Comment_start -> "this is the start of a comment." | Comment_not_end -> "this is not the end of a comment." - | Deprecated s -> "deprecated: " ^ s + | Deprecated s -> + (* Reduce \r\n to \n: + - Prevents any \r characters being printed on Unix when processing + Windows sources + - Prevents \r\r\n being generated on Windows, which affects the + testsuite + *) + "deprecated: " ^ Misc.normalise_eol s | Fragile_match "" -> "this pattern-matching is fragile." | Fragile_match s -> @@ -445,6 +455,7 @@ let message = function Printf.sprintf "no cmx file was found in path for module %s, \ and its interface was not compiled with -opaque" name + | Assignment_to_non_mutable_value -> "Assignment to non-mutable value" ;; let nerrors = ref 0;; @@ -541,6 +552,7 @@ let descriptions = 56, "Unreachable case in a pattern-matching (based on type information)."; 57, "Ambiguous binding by pattern."; 58, "Missing cmx file"; + 59, "Assignment to non-mutable value"; ] ;; diff --git a/utils/warnings.mli b/utils/warnings.mli index 37de15ef0..1f9e79876 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -71,6 +71,7 @@ type t = | Unreachable_case (* 56 *) | Ambiguous_pattern of string list (* 57 *) | No_cmx_file of string (* 58 *) + | Assignment_to_non_mutable_value (* 59 *) ;; val parse_options : bool -> string -> unit;;